2001-05-20 23:15 UTC+1 JFL (mafact) <jfl@mafact.com>

harbour/ChangeLog

@@ -1,3 +1,16 @@
+2001-05-20 23:15 UTC+1 JFL (mafact) <jfl@mafact.com>
+   * harbour/source/vm/classes.c
+     + hb_objGetRealClsName(object, szmsg )
+       Return the real class name regarding the Message called
+       So as an inherited method will return it's real class parent 
+   * harbour/source/vm/proc.c
+     * modified PROCNAME() to call the new classes function
+   * harbour/include/hbapi.h
+     + added hb_objGetRealClsName
+   * harbour/include/hbclass.ch
+     + added xtranslate to allow MethodName as the same as ProcName
+       (a la class(y) )
+
 2001-05-20 13:35 GMT -3 Luiz Rafael Culik <culik@sl.conex.net>
 
 *contrib/hbzlib/zip.c

harbour/include/hbapi.h

@@ -419,6 +419,7 @@ extern void     hb_clsReleaseAll( void );    /* releases all defined classes */
 
 /* object management */
 extern char *   hb_objGetClsName( PHB_ITEM pObject ); /* retrieves an object class name */
+extern char *   hb_objGetRealClsName( PHB_ITEM pObject, char * szString  ); /* retrieves an object class name for a specific message */
 extern PHB_FUNC hb_objGetMethod( PHB_ITEM pObject, PHB_SYMB pSymMsg ); /* returns the method pointer of a object class */
 extern ULONG    hb_objHasMsg( PHB_ITEM pObject, char * szString ); /* returns TRUE/FALSE whether szString is an existing message for object */
 
@@ -535,7 +536,7 @@ extern void   hb_macroPushAliasedValue( HB_ITEM_PTR pAlias, HB_ITEM_PTR pVar );
 extern char * hb_macroGetType( HB_ITEM_PTR pItem ); /* determine the type of an expression */
 
 /* garbage collector */
-#define HB_GARBAGE_FUNC( hbfunc )   void hbfunc( void * Cargo )	/* callback function for cleaning garbage memory pointer */
+#define HB_GARBAGE_FUNC( hbfunc )   void hbfunc( void * Cargo ) /* callback function for cleaning garbage memory pointer */
 typedef HB_GARBAGE_FUNC( HB_GARBAGE_FUNC_ );
 typedef HB_GARBAGE_FUNC_ *HB_GARBAGE_FUNC_PTR;
 

harbour/include/hbclass.ch

@@ -144,6 +144,7 @@ DECLARE TClass ;
 /* CLASSY SYNTAX */
 #IFDEF HB_CLS_CSY
 #xtranslate CREATE CLASS => CLASS
+#xtranslate METHODNAME => PROCNAME
 #endif
 
 #ifndef HB_SHORTNAMES

harbour/source/vm/classes.c

@@ -601,6 +601,103 @@ char * hb_objGetClsName( PHB_ITEM pObject )
    return szClassName;
 }
 
+/*
+ * <szName> = ( pObject )
+ *
+ * Get the real class name of an object message
+ * Will return the class name from wich the message is inherited in case
+ * of inheritance.
+ *
+ */
+char * hb_objGetRealClsName( PHB_ITEM pObject, char * szName )
+{
+   char * szClassName;
+
+   HB_TRACE(HB_TR_DEBUG, ("hb_objGetrealClsName(%p)", pObject));
+
+   if( HB_IS_ARRAY( pObject ) )
+   {
+      if( ! pObject->item.asArray.value->uiClass )
+         szClassName = "ARRAY";
+      else
+       {
+         PHB_DYNS pMsg    = hb_dynsymFindName( szName );
+         USHORT uiClass;
+
+         /* default value to current class object */
+         uiClass = pObject->item.asArray.value->uiClass;
+
+         if( uiClass && uiClass <= s_uiClasses )
+         {
+            PCLASS pClass  = s_pClasses + ( uiClass - 1 );
+            USHORT uiAt    = ( USHORT ) ( ( ( hb_cls_MsgToNum( pMsg ) ) % pClass->uiHashKey ) * BUCKET );
+            USHORT uiMask  = ( USHORT ) ( pClass->uiHashKey * BUCKET );
+            USHORT uiLimit = ( USHORT ) ( uiAt ? ( uiAt - 1 ) : ( uiMask - 1 ) );
+
+            s_pMethod = NULL;                            /* Current method pointer   */
+
+            while( uiAt != uiLimit )
+            {
+               if( pClass->pMethods[ uiAt ].pMessage == pMsg )
+               {
+                  s_pMethod = pClass->pMethods + uiAt;
+                  uiClass = s_pMethod->uiSprClass;
+                  break;
+               }
+               uiAt++;
+               if( uiAt == uiMask )
+                  uiAt = 0;
+            }
+         }
+
+         szClassName =
+            ( s_pClasses + uiClass - 1 )->szName;
+
+       }
+   }
+   else                                         /* built in types */
+   {
+      switch( pObject->type )
+      {
+         case HB_IT_NIL:
+            szClassName = "NIL";
+            break;
+
+         case HB_IT_STRING:
+            szClassName = "CHARACTER";
+            break;
+
+         case HB_IT_BLOCK:
+            szClassName = "BLOCK";
+            break;
+
+         case HB_IT_SYMBOL:
+            szClassName = "SYMBOL";
+            break;
+
+         case HB_IT_DATE:
+            szClassName = "DATE";
+            break;
+
+         case HB_IT_INTEGER:
+         case HB_IT_LONG:
+         case HB_IT_DOUBLE:
+            szClassName = "NUMERIC";
+            break;
+
+         case HB_IT_LOGICAL:
+            szClassName = "LOGICAL";
+            break;
+
+         default:
+            szClassName = "UNKNOWN";
+            break;
+      }
+   }
+
+   return szClassName;
+}
+
 
 /*
  * <pFunc> = hb_objGetMethod( <pObject>, <pMessage> )

harbour/source/vm/proc.c

@@ -111,7 +111,7 @@ char * hb_procname( int iLevel, char * szName )
    {
       if( ( *( pBase + 1 ) )->type == HB_IT_ARRAY )  /* it is a method name */
       {
-         strcpy( szName, hb_objGetClsName( *( pBase + 1 ) ) );
+         strcpy( szName, hb_objGetRealClsName( *( pBase + 1 ), ( *pBase )->item.asSymbol.value->szName ) );
          strcat( szName, ":" );
          strcat( szName, ( *pBase )->item.asSymbol.value->szName );
       }