Enviando un mensaje a un objeto desde bajo nivel

[xmanuel]

Hola Antonio...

No sé si será un fallo mío, pero intento heredar en otra clase hecha en PRG de una hecha en C y me da un error...

[Antonio Linares]

Manu,

En este ejemplo se deriva una Clase en PRG desde una creada en C

Code: Select all  Expand view  RUN

// This example shows how to create a Harbour Class entirely from language C (low level)

#include "FiveWin.ch"

function Main()

   local o := Another():New()

   MsgInfo( o:ClassName() )
   MsgInfo( o:Data1 )
   
   o:Data1 = 345
   MsgInfo( o:Data1 )
   
   MsgInfo( o:Data2 )

return nil

init procedure First

   Test()
   
return  

CLASS Another FROM Test

ENDCLASS
   
#pragma BEGINDUMP

#include <hbapi.h>
#include <hbapiitm.h>
#include <hbapicls.h>
#include <hbstack.h>

HB_FUNC_STATIC( TESTGETDATA1 )
{
   PHB_ITEM pSelf = hb_param( 0, HB_IT_OBJECT );

   hb_arrayGet( pSelf, 1, hb_stackReturnItem() );
}

HB_FUNC_STATIC( TESTSETDATA1 )
{
   PHB_ITEM pSelf = hb_param( 0, HB_IT_OBJECT );

   hb_arraySet( pSelf, 1, hb_param( 1, HB_IT_ANY ) );
}

HB_FUNC_STATIC( TESTGETDATA2 )
{
   PHB_ITEM pSelf = hb_param( 0, HB_IT_OBJECT );

   hb_arrayGet( pSelf, 2, hb_stackReturnItem() );
}

HB_FUNC_STATIC( TESTSETDATA2 )
{
   PHB_ITEM pSelf = hb_param( 0, HB_IT_OBJECT );

   hb_arraySet( pSelf, 2, hb_param( 1, HB_IT_ANY ) );
}

HB_FUNC_STATIC( TESTNEW )
{
   PHB_ITEM pSelf = hb_param( 0, HB_IT_OBJECT );

   hb_arraySetNL( pSelf, 1, 123 ); // pSelf[ 1 ] = 123
   hb_arraySetC( pSelf, 2, "Hello world!" ); // pSelf[ 2 ] = "Hello world!"

   hb_itemReturn( pSelf );  // return Self
}

HB_FUNC( TEST )
{
   static HB_USHORT usClassH = 0;
   
   if( usClassH == 0 )
   {
      HB_SYMB symTest = { "TEST", { HB_FS_PUBLIC | HB_FS_LOCAL }, { HB_FUNCNAME( TEST ) }, NULL };

      hb_dynsymNew( &symTest );
     
      usClassH = hb_clsCreate( 2, "TEST" ); // 2 DATAs
   
      hb_clsAdd( usClassH, "DATA1",   HB_FUNCNAME( TESTGETDATA1 ) );
      hb_clsAdd( usClassH, "_DATA1",  HB_FUNCNAME( TESTSETDATA1 ) );
      hb_clsAdd( usClassH, "DATA2",   HB_FUNCNAME( TESTGETDATA2 ) );
      hb_clsAdd( usClassH, "_DATA2",  HB_FUNCNAME( TESTSETDATA2 ) );
      hb_clsAdd( usClassH, "NEW",     HB_FUNCNAME( TESTNEW ) );
   }
   
   hb_clsAssociate( usClassH ); // Creates an object of Class usClassH
}

#pragma ENDDUMP

Fíjate que la diferencia está en que la Clase Test se registre la primera:

Code: Select all  Expand view  RUN

init procedure First

   Test()
   
return  
 

y ademas se añade este código en la creación de la Clase Test:

Code: Select all  Expand view  RUN

     HB_SYMB symTest = { "TEST", { HB_FS_PUBLIC | HB_FS_LOCAL }, { HB_FUNCNAME( TEST ) }, NULL };

      hb_dynsymNew( &symTest );
 

En mi opinión esto no debería ser necesario, pero mientras se arregla ó no en Harbour, no he encontrado otra forma de solucionarlo sin modificar Harbour

[Antonio Linares]

Esta es otra forma, más simple, aunque no deja de ser un hackeo no recomendable, pero la ventaja es que este código funciona con Borland, msvc 2010 32 y 64 bits

Code: Select all  Expand view  RUN

// This example shows how to create a Harbour Class entirely from language C (low level)

#include "FiveWin.ch"

function Main()

   local o := Another( Test() ):New()

   MsgInfo( o:ClassName() )
   MsgInfo( o:Data1 )
   
   o:Data1 = 345
   MsgInfo( o:Data1 )
   
   MsgInfo( o:Data2 )

return nil

CLASS Another FROM Test

ENDCLASS

#pragma BEGINDUMP

#include <hbapi.h>
#include <hbapiitm.h>
#include <hbapicls.h>
#include <hbstack.h>

HB_FUNC_STATIC( TESTGETDATA1 )
{
   PHB_ITEM pSelf = hb_param( 0, HB_IT_OBJECT );

   hb_arrayGet( pSelf, 1, hb_stackReturnItem() );
}

HB_FUNC_STATIC( TESTSETDATA1 )
{
   PHB_ITEM pSelf = hb_param( 0, HB_IT_OBJECT );

   hb_arraySet( pSelf, 1, hb_param( 1, HB_IT_ANY ) );
}

HB_FUNC_STATIC( TESTGETDATA2 )
{
   PHB_ITEM pSelf = hb_param( 0, HB_IT_OBJECT );

   hb_arrayGet( pSelf, 2, hb_stackReturnItem() );
}

HB_FUNC_STATIC( TESTSETDATA2 )
{
   PHB_ITEM pSelf = hb_param( 0, HB_IT_OBJECT );

   hb_arraySet( pSelf, 2, hb_param( 1, HB_IT_ANY ) );
}

HB_FUNC_STATIC( TESTNEW )
{
   PHB_ITEM pSelf = hb_param( 0, HB_IT_OBJECT );

   hb_arraySetNL( pSelf, 1, 123 ); // pSelf[ 1 ] = 123
   hb_arraySetC( pSelf, 2, "Hello world!" ); // pSelf[ 2 ] = "Hello world!"

   hb_itemReturn( pSelf );  // return Self
}

HB_FUNC( TEST )
{
   static HB_USHORT usClassH = 0;
   
   if( usClassH == 0 )
   {
      hb_dynsymSymbol( hb_dynsymFindName( "TEST" ) )->scope.value |= HB_FS_LOCAL;
     
      usClassH = hb_clsCreate( 2, "TEST" ); // 2 DATAs
   
      hb_clsAdd( usClassH, "DATA1",   HB_FUNCNAME( TESTGETDATA1 ) );
      hb_clsAdd( usClassH, "_DATA1",  HB_FUNCNAME( TESTSETDATA1 ) );
      hb_clsAdd( usClassH, "DATA2",   HB_FUNCNAME( TESTGETDATA2 ) );
      hb_clsAdd( usClassH, "_DATA2",  HB_FUNCNAME( TESTSETDATA2 ) );
      hb_clsAdd( usClassH, "NEW",     HB_FUNCNAME( TESTNEW ) );
   }
   
   hb_clsAssociate( usClassH ); // Creates an object of Class usClassH
}

#pragma ENDDUMP

[xmanuel]

Muchas gracias Antonio

Seguro que al final se soluciona el tema y se podrá trabajar indistintamente creando clases desde ambos lenguajes y con toda la potencia que nos da la POO...

Saludos

PD:

Ya veo la marcha que le estás dando a Dialog

[Antonio Linares]

Ahora a ver si encontramos alguna versión de FiveOS2

[lailton.webmaster]

Mucho Impressionante

[xmanuel]

Hola Antonio...

se sabe si se va a solucionar el tema de la de la herencia en clases hechas en C totalmente?

[Antonio Linares]

Manu,

De momento no se ha publicado nada al respecto que yo sepa, pero el sistema que yo he publicado va bien!

[xmanuel]

Antonio, otra cosa...
Si una DATA es un objeto y se quiere delegar la ejecución de un método como se haría para hacer eso?
En prg:

...
DATA oObj
...

METHOD EjMetodo CLASS MiClase

::oObj:EjeElMetodo()

return nil

jaja te pongo en unos aprietos...!!!

Saludos y gracias por aguanterme de vez en cuando

[Antonio Linares]

Manu,

Prueba asi:

Code: Select all  Expand view  RUN

HB_FUNC_STATIC( TESTEJMETODO )
{
   PHB_ITEM pSelf = hb_param( 0, HB_IT_OBJECT );
   PHB_ITEM pObj = hb_itemNew( NULL );

   hb_arrayGet( pSelf, 3, pObj ); // 3 is the DATA position for DATA hObj
   hb_objSendMsg( pObj, "EJEELMETODO", 0 ); // 0 parameters sent
}

...
      hb_clsAdd( usClassH, "EJMETODO", HB_FUNCNAME( TESTEJMETODO ) );
...
 

[xmanuel]

OK...

Lo probaré y te digo...

Muchas gracias Antonio

[xmanuel]

Hola Antonio...

Vuelvo a las andadas

Ya hemos hecho heredar desde una hecha en C una en PRG ( y con ese truco va perfecto )

PERO Y AHORAAAAAAAAA:

1) Como podría heredar de una clase hecha en C desde una en C también...
Y
2) Una clase hecha en C desde una en PRG

O sea todas la posibilidades posibles:

C <- PRG ( Ya )
C <- C ( ? )
PRG <- C ( ? )

Saludos

[xmanuel]

Hi Antonio

Has podido mirar algo de lo que digo en el correo anterior?
Se puede? o es muy complicado?

Jeje

Saludossssssssssss

[xmanuel]

Jajaja aquí ando otra vez...

Antonio he podido observar en classes.c esta función que es la que se encarga de crear las clases y que es compatible con clipper

/* Harbour equivalent for Clipper internal __mdCreate() */
HB_USHORT hb_clsCreate( HB_USHORT usSize, const char * szClassName )
{
return hb_clsNew( szClassName, usSize, NULL, NULL, HB_FALSE );
}

Realmente es hb_clsNew la que hace la magia... el tercer parámetro que recibe es un array de handles de las superclases... pero desgraciadamente clsNew esta declarada como static y no es visible
Podrías cambiarla para que no fuera static o cambiar hb_clsCreate a:

HB_USHORT hb_clsCreate( HB_USHORT usSize, const char * szClassName, PHB_ITEM pSuperArray )

No sé si es mucho lo que pido o hay otras maneras de hacerlo, pero con eso quedaría resuelto todo lo referido a la herencia

Saludos

[xmanuel]

He hecho esto
generic.h

Code: Select all  Expand view  RUN

//-----------------------------------------------------------------------------
// De (x)Harbour

#include <hbapi.h>
#include <hbapiitm.h>
#include <hbstack.h>

// Compatibiliza
#if !defined(__XHARBOUR__)
   #include <hbapicls.h>
#else
    #include <classes.h>
   #define HB_USHORT USHORT
   #define HB_ULONG ULONG
#endif

//-----------------------------------------------------------------------------
// Manipulacion de Objetos

// Esta es para DATAs que van a tener una funcion get y otra set
#define IVAR( szName, pGetFuncName, pSetFuncName ) \
              hb_clsAdd( usClassH, szName, pGetFuncName ); \
              hb_clsAdd( usClassH, "_"szName, pSetFuncName )
// Esta es para DATAs que van a tener una funcion unica para get y set
#define SETGETVAR( szName, pFuncName ) \
                   hb_clsAdd( usClassH, szName, pFuncName ); \
                   hb_clsAdd( usClassH, "_"szName, pFuncName )
// Metodos
#define METHOD( szName, pFuncName ) hb_clsAdd( usClassH, szName, pFuncName )

//-----------------------------------------------------------------------------
// Funcion de clase

HB_USHORT CreateClass( const char * szClsName, HB_USHORT uiDatas );
void SetGet( HB_ULONG ulIndex );

//-----------------------------------------------------------------------------

 

generic.c

Code: Select all  Expand view  RUN

//---------------------------------------------------------------------------//

#include "generic.h"

//-----------------------------------------------------------------------------
// Crea la clase. Esta puede sergenerica

HB_USHORT CreateClass( const char * szClsName, HB_USHORT uiDatas )
{
    hb_dynsymSymbol( hb_dynsymFindName( szClsName ) )->scope.value |= HB_FS_LOCAL;

    return hb_clsCreate( uiDatas, szClsName );
}

//-----------------------------------------------------------------------------
// Funcion generica SET GET

void SetGet( HB_ULONG ulIndex )
{
   if( hb_pcount() )
   {
      hb_arraySet( hb_stackSelfItem(), ulIndex, hb_stackItemFromBase( 1 ) );
   }
   else
   {
      hb_arrayGet( hb_stackSelfItem(), ulIndex, hb_stackReturnItem() );
   }
}

//-----------------------------------------------------------------------------

 

test.c

Code: Select all  Expand view  RUN

//---------------------------------------------------------------------------//

#include "generic.h"
#include "mijerarquia.h"

//-----------------------------------------------------------------------------
// Funcion de clase

HB_FUNC( TEST )
{
    static HB_USHORT usClassH = 0;

   if( usClassH == 0 )
   {
    usClassH = CreateClass( "TEST", 3 );
    InheritTest( usClassH );
    }
   hb_clsAssociate( usClassH );
}

//-----------------------------------------------------------------------------
// DATAS

HB_FUNC_STATIC( TESTDATA1 ) { SetGet( 1 ); }
HB_FUNC_STATIC( TESTDATA2 ) { SetGet( 2 ); }
HB_FUNC_STATIC( TESTDATA3 ) { SetGet( 3 ); }

//-----------------------------------------------------------------------------
// Metodos

HB_FUNC_STATIC( TESTNEW )   // Constructor
{
   PHB_ITEM pSelf = hb_stackSelfItem();

   hb_arraySetNL( pSelf, 1, 123 );
   hb_arraySetC( pSelf, 2, "Hello world!" );
   hb_arraySet( pSelf, 3, hb_itemArrayNew( 0 ) );

   hb_itemReturn( pSelf );
}

//-----------------------------------------------------------------------------
// Copia de metodos y datas para el objeto

void InheritTest( HB_USHORT usClassH )
{
   SETGETVAR( "DATA1", HB_FUNCNAME( TESTDATA1 ) );
   SETGETVAR( "DATA2", HB_FUNCNAME( TESTDATA2 ) );
   SETGETVAR( "DATA3", HB_FUNCNAME( TESTDATA3 ) );

   METHOD( "NEW", HB_FUNCNAME( TESTNEW ) );
}

//-----------------------------------------------------------------------------


 

another.c

Code: Select all  Expand view  RUN

//---------------------------------------------------------------------------//

#include "generic.h"
#include "mijerarquia.h"
#include "hbapigt.h"

//-----------------------------------------------------------------------------

HB_FUNC( ANOTHER )
{
    static HB_USHORT usClassH = 0;

    if( usClassH == 0 )
    {
        usClassH = CreateClass( "ANOTHER", 5 );
        InheritAnother( usClassH );
    }

    hb_clsAssociate( usClassH );
}

//-----------------------------------------------------------------------------
// DATAS

//-------------------------------------------------------
// Data4 tipo setget

HB_FUNC_STATIC( ANOTHERDATA4 ) { SetGet( 4 ); }

//-------------------------------------------------------
// Data5 con una funcion para get y otra para el set

HB_FUNC_STATIC( ANOTHERGETDATA5 )
{
   PHB_ITEM pSelf = hb_stackSelfItem();

   hb_arrayGet( pSelf, 5, hb_stackReturnItem() );
}

//-------------------------------------------------------

HB_FUNC_STATIC( ANOTHERSETDATA5 )
{
   PHB_ITEM pSelf = hb_stackSelfItem();

   hb_arraySet( pSelf, 5, hb_stackItemFromBase( 1 ) );
}

//-----------------------------------------------------------------------------
// Metodos

HB_FUNC_STATIC( ANOTHERHOLA )
{
   PHB_ITEM pSelf = hb_stackSelfItem();

   hb_arraySetC( pSelf, 4, "Hola desde la data4" );

   hb_retc( "Este es el metodo Hola de Another" );
}

//-----------------------------------------------------------------------------

HB_FUNC_STATIC( ANOTHERNUMDATAS )
{
   PHB_ITEM pSelf = hb_stackSelfItem();

   hb_retni( hb_arrayLen( pSelf ) );
}

//-----------------------------------------------------------------------------
// Copia de metodos y datas para el objeto

void InheritAnother( HB_USHORT usClassH )
{
   InheritTest( usClassH );

   SETGETVAR( "DATA4", HB_FUNCNAME( ANOTHERDATA4 ) );
   IVAR( "DATA5", HB_FUNCNAME( ANOTHERGETDATA5 ), HB_FUNCNAME( ANOTHERSETDATA5 ) );

   METHOD( "HOLA", HB_FUNCNAME( ANOTHERHOLA ) );
   METHOD( "NUMDATAS", HB_FUNCNAME( ANOTHERNUMDATAS ) );
}

//-----------------------------------------------------------------------------


 

mijerarquia.h

Code: Select all  Expand view  RUN

//---------------------------------------------------------------------------//

//-----------------------------------------------------------------------------
// Prototipos de funcciones

void InheritTest( HB_USHORT usClassH );
void InheritAnother( HB_USHORT usClassH );

//-----------------------------------------------------------------------------


 

y el ejemplito PRG

Code: Select all  Expand view  RUN

REQUEST HB_GT_WIN

function Main()

    local kk := Test():new()
    local o := Another():New()

    Alert( "Tipo de la o:data3: " + ValType( o:Data3 ) )
    Alert( "Tipo de la kk:data3: " + ValType( kk:Data3 ) )
    Alert( "o:ClassName() -> " + o:ClassName() )
    Alert( "o:Data1 -> " + Transform( o:Data1, "@" ) )
    o:Data1 = 345
    Alert( "Despues de 345 o:Data1 -> " + Transform( o:Data1, "@!" ) )
    Alert( "o:Data2 -> " + Transform( o:Data2, "@" ) )
    Alert( "o:Hola() -> " + Transform( o:Hola(), "@" ) )
    Alert( "data4: " + o:Data4 + "  Tipo: " + ValType( o:Data4 ) )
    o:Data4 := 4
    Alert( "data4 modificado: " + Transform( o:Data4, "@" ) + "  Tipo: " + ValType( o:Data4 ) )
    Alert( "NumDatas: " + StrZero( o:NumDatas(), 2 ) )

   o:Data5 := "Prueba de data 5 ..."
   Alert( o:Data5 )

   Alert( "Este es hb_objGetClass: " + /*Str( hb_objGetClass( o ) )  +*/ Str( o:ClassH ) )
    inKey( 5 )

return nil

 

Más o menos hay herencia en bruto pero la hay

Antonio necesito tu opinión