From 0efe049e5d7203bf9e35336f4b5957b5ab71ac9c Mon Sep 17 00:00:00 2001 From: Przemyslaw Czerpak Date: Wed, 3 Oct 2007 15:05:12 +0000 Subject: [PATCH] 2007-10-03 17:04 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl) + harbour/tests/oleenum.prg + added Enrico example and test code for enumerators and OLE objects * harbour/contrib/Makefile * enabled hbole, ado_rdd, hybodbc in most of Windows builds * harbour/contrib/ole2/win32ole.prg * harbour/contrib/ole2/w32ole.c * synced with recent Ron's modifications in xHarbour I'd like to ask Windows users to make tests with above oleenum.prg and example sent by Luis * harbour/source/rtl/gttrm/gttrm.c * disable ACS mode before sending BEL on Linux compatibile terminals - some of them may try to display chr(7) instead of generating sound when ACSC is enabled * harbour/source/vm/proc.c + added support for character parameter in PROCFILE() - now it can accept | | as first parameter * harbour/source/vm/dynsym.c * added support for detecting not cleanly overloaded by linker .prg functions. In such case hb_dynsymNew() checks if linker updated function addresses and if yes then remove unnecessary HB_FS_LOCAL flag. In such case works GCC (but not MinGW and DJGPP), OpwenWatcom for Linux, DOS, Windows (and probably for OS2), POCC, XCC (with /FORCE:MULTIPLE linker switch) and some other linkers I haven't tested. Otherwise (two different functions with the same name linked and each accessible from different symbol, f.e. BCC32, MinGW, DJGPP) it accept multiple HB_FS_LOCAL for dynamically loaded modules (.hrb, .dll, .so, .dyn, ...) if HVM also accepted it (for future KEEP_LOCAL_FUNC HB_LIBLOAD()/__HBRLOAD() parameter). For statically linked modules it overloads one of the functions when HB_OVERLOAD_MULTIPLE_FUNC macro is set (now by default to make tests with different linkers). I left detail description in source code of hb_dynsymNew() in source/vm/dynsym.c. I hope it will also help Ron in recent xHarbour modifications - AFAIK it's sth what he tires to do. Anyhow please remember that that dirty overloading any symbols by linker is very bad idea and in such case you have big chance that wrong binaries will be created so the most preferable choice is eliminating such situations and not using linker switches like -Wl,--allow-multiple-definition or /FORCE:MULTIPLE + harbour/tests/multifnc + harbour/tests/multifnc/t0.prg + harbour/tests/multifnc/t1.prg + harbour/tests/multifnc/t2.prg + harbour/tests/multifnc/Makefile + added test code for results of dirty overloaded functions. With recent modifications expected results are: main t0.prg t0.prg alert t1.prg t1.prg [ALERT] p0 t0.prg t0.prg P0:t0.prg P0:t0.prg OK p1 t0.prg t0.prg P1:t0.prg P1:t0.prg OK p2 t1.prg t1.prg P2:t1.prg P2:t1.prg OK p3 t0.prg t0.prg P3:t0.prg P3:t0.prg OK p4 t1.prg t1.prg P4:t1.prg P4:t1.prg OK p5 t2.prg t2.prg P5:t2.prg P5:t2.prg OK === main2 t1.prg t1.prg alert t1.prg t1.prg [ALERT] p0 t0.prg t0.prg P0:t0.prg P0:t0.prg OK p1 t0.prg t0.prg P1:t0.prg P1:t0.prg OK p2 t1.prg t1.prg P2:t1.prg P2:t1.prg OK p3 t0.prg t0.prg P3:t0.prg P3:t0.prg OK p4 t1.prg t1.prg P4:t1.prg P4:t1.prg OK p5 t2.prg t2.prg P5:t2.prg P5:t2.prg OK === main3 t2.prg t2.prg alert t1.prg t1.prg [ALERT] p0 t0.prg t0.prg P0:t0.prg P0:t0.prg OK p1 t0.prg t0.prg P1:t0.prg P1:t0.prg OK p2 t1.prg t1.prg P2:t1.prg P2:t1.prg OK p3 t0.prg t0.prg P3:t0.prg P3:t0.prg OK p4 t1.prg t1.prg P4:t1.prg P4:t1.prg OK p5 t2.prg t2.prg P5:t2.prg P5:t2.prg OK I've tested only few compilers: GCC/G++ (Linux) MinGW (WINE-W32), DJGPP (DOSEMU), OpenWatcom (Linux, WINE-W32, DOSEMU), XCC/POCC (WINE-W32) and I'm interesting in results from other compiler/ platforms, f.e. from M[V]SC. --- harbour/ChangeLog | 87 +++++++++++ harbour/contrib/Makefile | 12 +- harbour/contrib/ole2/w32ole.c | 250 +++++++++++++++++++++--------- harbour/contrib/ole2/win32ole.prg | 20 +-- harbour/source/rtl/gttrm/gttrm.c | 5 + harbour/source/vm/dynsym.c | 80 ++++++++++ harbour/source/vm/proc.c | 7 + harbour/tests/multifnc/Makefile | 55 +++++++ harbour/tests/multifnc/t0.prg | 23 +++ harbour/tests/multifnc/t1.prg | 20 +++ harbour/tests/multifnc/t2.prg | 14 ++ harbour/tests/oleenum.prg | 24 +++ 12 files changed, 499 insertions(+), 98 deletions(-) create mode 100644 harbour/tests/multifnc/Makefile create mode 100644 harbour/tests/multifnc/t0.prg create mode 100644 harbour/tests/multifnc/t1.prg create mode 100644 harbour/tests/multifnc/t2.prg create mode 100644 harbour/tests/oleenum.prg diff --git a/harbour/ChangeLog b/harbour/ChangeLog index a42e08b0bd..a11362b5ef 100644 --- a/harbour/ChangeLog +++ b/harbour/ChangeLog @@ -8,6 +8,93 @@ 2002-12-01 13:30 UTC+0100 Foo Bar */ +2007-10-03 17:04 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl) + + harbour/tests/oleenum.prg + + added Enrico example and test code for enumerators and OLE objects + + * harbour/contrib/Makefile + * enabled hbole, ado_rdd, hybodbc in most of Windows builds + + * harbour/contrib/ole2/win32ole.prg + * harbour/contrib/ole2/w32ole.c + * synced with recent Ron's modifications in xHarbour + I'd like to ask Windows users to make tests with above + oleenum.prg and example sent by Luis + + * harbour/source/rtl/gttrm/gttrm.c + * disable ACS mode before sending BEL on Linux compatibile terminals + - some of them may try to display chr(7) instead of generating + sound when ACSC is enabled + + * harbour/source/vm/proc.c + + added support for character parameter in PROCFILE() - now it can + accept | | as first parameter + + * harbour/source/vm/dynsym.c + * added support for detecting not cleanly overloaded by linker .prg + functions. + In such case hb_dynsymNew() checks if linker updated function + addresses and if yes then remove unnecessary HB_FS_LOCAL flag. + In such case works GCC (but not MinGW and DJGPP), OpwenWatcom + for Linux, DOS, Windows (and probably for OS2), POCC, XCC (with + /FORCE:MULTIPLE linker switch) and some other linkers I haven't + tested. + Otherwise (two different functions with the same name linked and + each accessible from different symbol, f.e. BCC32, MinGW, DJGPP) + it accept multiple HB_FS_LOCAL for dynamically loaded modules + (.hrb, .dll, .so, .dyn, ...) if HVM also accepted it (for future + KEEP_LOCAL_FUNC HB_LIBLOAD()/__HBRLOAD() parameter). + For statically linked modules it overloads one of the functions when + HB_OVERLOAD_MULTIPLE_FUNC macro is set (now by default to make tests + with different linkers). I left detail description in source code of + hb_dynsymNew() in source/vm/dynsym.c. + I hope it will also help Ron in recent xHarbour modifications - AFAIK + it's sth what he tires to do. + Anyhow please remember that that dirty overloading any symbols by + linker is very bad idea and in such case you have big chance that + wrong binaries will be created so the most preferable choice is + eliminating such situations and not using linker switches like + -Wl,--allow-multiple-definition or /FORCE:MULTIPLE + + + harbour/tests/multifnc + + harbour/tests/multifnc/t0.prg + + harbour/tests/multifnc/t1.prg + + harbour/tests/multifnc/t2.prg + + harbour/tests/multifnc/Makefile + + added test code for results of dirty overloaded functions. + With recent modifications expected results are: + main t0.prg t0.prg + alert t1.prg t1.prg [ALERT] + p0 t0.prg t0.prg P0:t0.prg P0:t0.prg OK + p1 t0.prg t0.prg P1:t0.prg P1:t0.prg OK + p2 t1.prg t1.prg P2:t1.prg P2:t1.prg OK + p3 t0.prg t0.prg P3:t0.prg P3:t0.prg OK + p4 t1.prg t1.prg P4:t1.prg P4:t1.prg OK + p5 t2.prg t2.prg P5:t2.prg P5:t2.prg OK + === + main2 t1.prg t1.prg + alert t1.prg t1.prg [ALERT] + p0 t0.prg t0.prg P0:t0.prg P0:t0.prg OK + p1 t0.prg t0.prg P1:t0.prg P1:t0.prg OK + p2 t1.prg t1.prg P2:t1.prg P2:t1.prg OK + p3 t0.prg t0.prg P3:t0.prg P3:t0.prg OK + p4 t1.prg t1.prg P4:t1.prg P4:t1.prg OK + p5 t2.prg t2.prg P5:t2.prg P5:t2.prg OK + === + main3 t2.prg t2.prg + alert t1.prg t1.prg [ALERT] + p0 t0.prg t0.prg P0:t0.prg P0:t0.prg OK + p1 t0.prg t0.prg P1:t0.prg P1:t0.prg OK + p2 t1.prg t1.prg P2:t1.prg P2:t1.prg OK + p3 t0.prg t0.prg P3:t0.prg P3:t0.prg OK + p4 t1.prg t1.prg P4:t1.prg P4:t1.prg OK + p5 t2.prg t2.prg P5:t2.prg P5:t2.prg OK + + I've tested only few compilers: GCC/G++ (Linux) MinGW (WINE-W32), + DJGPP (DOSEMU), OpenWatcom (Linux, WINE-W32, DOSEMU), XCC/POCC + (WINE-W32) and I'm interesting in results from other compiler/ + platforms, f.e. from M[V]SC. + 2007-10-02 14:58 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl) * harbour/contrib/ole2/win32ole.prg ! fixed typo in __enumStart() - enum parameter has to be passed diff --git a/harbour/contrib/Makefile b/harbour/contrib/Makefile index aa858ea475..41faa8591c 100644 --- a/harbour/contrib/Makefile +++ b/harbour/contrib/Makefile @@ -28,15 +28,7 @@ ifeq ($(HB_ARCHITECTURE),w32) DIRS +=\ rdd_ads \ -ifeq ($(HB_COMPILER),msvc) - -DIRS +=\ - odbc \ - -else -ifeq ($(HB_COMPILER),rsxnt) - -else +ifneq ($(HB_COMPILER),rsxnt) DIRS +=\ ole2 \ @@ -44,7 +36,6 @@ DIRS +=\ adordd \ endif -endif else ifeq ($(HB_COMPILER),icc) @@ -72,7 +63,6 @@ endif ifneq ($(HB_ARCHITECTURE),dos) DIRS += tip -#DIRS += xhb endif include $(ROOT)config/dir.cf diff --git a/harbour/contrib/ole2/w32ole.c b/harbour/contrib/ole2/w32ole.c index c4b977adc9..77a585dac2 100644 --- a/harbour/contrib/ole2/w32ole.c +++ b/harbour/contrib/ole2/w32ole.c @@ -89,6 +89,8 @@ #define HB_LONG_LONG_OFF #endif +static void RetValue( void ); + static HRESULT s_nOleError; static HB_ITEM OleAuto; @@ -185,7 +187,6 @@ static void TraceLog( const char * sFile, const char * sTraceMsg, ... ) // ----------------------------------------------------------------------- static EXCEPINFO excep; - static BSTR bstrMessage; static DISPID lPropPut = DISPID_PROPERTYPUT; static UINT uArgErr; @@ -193,7 +194,7 @@ static void TraceLog( const char * sFile, const char * sTraceMsg, ... ) static PHB_ITEM SafeArrayToArray( SAFEARRAY *parray, UINT iDim, long* rgIndices, VARTYPE vt ); //---------------------------------------------------------------------------// - HB_EXPORT BSTR hb_oleAnsiToSysString( LPSTR cString ) + HB_EXPORT BSTR hb_oleAnsiToSysString( const char * cString ) { int nConvertedLen = MultiByteToWideChar( CP_ACP, MB_PRECOMPOSED, cString, -1, NULL, 0 ); @@ -690,14 +691,14 @@ static void TraceLog( const char * sFile, const char * sTraceMsg, ... ) } //---------------------------------------------------------------------------// - static PHB_ITEM * GetParams( DISPPARAMS *pDispParams ) + static PHB_ITEM * GetParams( DISPPARAMS *pDispParams, int nOffset ) { VARIANTARG * pArgs = NULL; int n, nArgs, nArg; //BOOL bByRef; PHB_ITEM *aPrgParams = NULL; - nArgs = hb_pcount(); + nArgs = hb_pcount() - nOffset; if( nArgs > 0 ) { @@ -712,7 +713,7 @@ static void TraceLog( const char * sFile, const char * sTraceMsg, ... ) nArg = nArgs - n; VariantInit( &( pArgs[ n ] ) ); - aPrgParams[ n ] = hb_stackItemFromBase( nArg ); + aPrgParams[ n ] = hb_stackItemFromBase( nArg + nOffset ); //TraceLog( NULL, "N: %i Arg: %i Type: %i %i ByRef: %i\n", n, nArg, pParam->type, aPrgParams[ n ]->type, bByRef ); @@ -959,7 +960,7 @@ static void TraceLog( const char * sFile, const char * sTraceMsg, ... ) //printf( " Sub: %i\n", i ); pSubArray = SafeArrayToArray( parray, iDim - 1, rgIndices, vt ); - hb_arraySet( pArray, i - iFrom + 1, pSubArray ); + hb_arraySetForward( pArray, i - iFrom + 1, pSubArray ); hb_itemRelease( pSubArray ); } } @@ -1558,7 +1559,7 @@ static void TraceLog( const char * sFile, const char * sTraceMsg, ... ) SysFreeString( bstrClassID ); - // TraceLog( NULL, "Result: %p\n", s_nOleError ); + //TraceLog( NULL, "Result: %p\n", s_nOleError ); if( hb_pcount() == 2 ) { @@ -1578,9 +1579,9 @@ static void TraceLog( const char * sFile, const char * sTraceMsg, ... ) if( SUCCEEDED( s_nOleError ) ) { - // TraceLog( NULL, "Class: %i\n", ClassID ); + //TraceLog( NULL, "Class: %i\n", ClassID ); s_nOleError = CoCreateInstance( (REFCLSID) &ClassID, NULL, CLSCTX_SERVER, (REFIID) riid, &pDisp ); - // TraceLog( NULL, "Result: %p\n", s_nOleError ); + //TraceLog( NULL, "Result: %p\n", s_nOleError ); } hb_retnl( ( LONG ) pDisp ); @@ -1676,6 +1677,9 @@ static void TraceLog( const char * sFile, const char * sTraceMsg, ... ) //---------------------------------------------------------------------------// static HRESULT OleSetProperty( IDispatch *pDisp, DISPID DispID, DISPPARAMS *pDispParams ) { + pDispParams->rgdispidNamedArgs = &lPropPut; + pDispParams->cNamedArgs = 1; + // 1 Based!!! if( ( ISBYREF( 1 ) ) || ISARRAY( 1 ) ) { @@ -1709,6 +1713,9 @@ static void TraceLog( const char * sFile, const char * sTraceMsg, ... ) &excep, &uArgErr ); + pDispParams->rgdispidNamedArgs = NULL; + pDispParams->cNamedArgs = 0; + return s_nOleError; } @@ -1851,10 +1858,7 @@ static void TraceLog( const char * sFile, const char * sTraceMsg, ... ) VariantClear( &RetVal ); - aPrgParams = GetParams( &DispParams ); - - DispParams.rgdispidNamedArgs = &lPropPut; - DispParams.cNamedArgs = 1; + aPrgParams = GetParams( &DispParams, 0 ); OleSetProperty( pDisp, DISPID_VALUE, &DispParams ); //TraceLog( NULL, "SetDefault: %p\n", s_nOleError ); @@ -1930,39 +1934,34 @@ static void TraceLog( const char * sFile, const char * sTraceMsg, ... ) } //---------------------------------------------------------------------------// - HB_FUNC( TOLEAUTO_ONERROR ) + static HRESULT OleGetID( IDispatch *pDisp, const char *szName, DISPID *pDispID, BOOL *pbSetFirst ) { - IDispatch *pDisp; - DISPID DispID; - DISPPARAMS DispParams; - BOOL bSetFirst = FALSE; + BSTR bstrMessage; - //TraceLog( NULL, "Class: '%s' Message: '%s', Params: %i Arg1: %i\n", hb_objGetClsName( hb_stackSelfItem() ), hb_itemGetSymbol( hb_stackBaseItem() )->szName, hb_pcount(), hb_parinfo(1) ); - - hb_vmPushSymbol( s_pSym_hObj->pSymbol ); - hb_vmPush( hb_stackSelfItem() ); - hb_vmSend( 0 ); - - pDisp = ( IDispatch * ) hb_parnl( -1 ); - - OleGetID : + if( pbSetFirst ) + { + *pbSetFirst = FALSE; + } /* - if( strcmp( hb_itemGetSymbol( hb_stackBaseItem() )->szName, "OLEVALUE" ) == 0 || strcmp( hb_itemGetSymbol( hb_stackBaseItem() )->szName, "_OLEVALUE" ) == 0 ) + if( strcmp( szName, "OLEVALUE" ) == 0 || strcmp( szName, "_OLEVALUE" ) == 0 ) { DispID = DISPID_VALUE; s_nOleError = S_OK; } - else*/ if( hb_itemGetSymbol( hb_stackBaseItem() )->szName[0] == '_' && hb_itemGetSymbol( hb_stackBaseItem() )->szName[1] && hb_pcount() >= 1 ) + else*/ if( szName[0] == '_' && szName[1] && hb_pcount() >= 1 ) { - bstrMessage = hb_oleAnsiToSysString( ( LPSTR ) hb_itemGetSymbol( hb_stackBaseItem() )->szName + 1 ); - s_nOleError = pDisp->lpVtbl->GetIDsOfNames( pDisp, (REFIID) &IID_NULL, (wchar_t **) &bstrMessage, 1, LOCALE_SYSTEM_DEFAULT, &DispID ); + bstrMessage = hb_oleAnsiToSysString( szName + 1 ); + s_nOleError = pDisp->lpVtbl->GetIDsOfNames( pDisp, (REFIID) &IID_NULL, (wchar_t **) &bstrMessage, 1, LOCALE_SYSTEM_DEFAULT, pDispID ); SysFreeString( bstrMessage ); //TraceLog( NULL, "1. ID of: '%s' -> %i Result: %p\n", hb_itemGetSymbol( hb_stackBaseItem() )->szName + 1, DispID, s_nOleError ); if( SUCCEEDED( s_nOleError ) ) { - bSetFirst = TRUE; + if( pbSetFirst ) + { + *pbSetFirst = TRUE; + } } } else @@ -1973,75 +1972,159 @@ static void TraceLog( const char * sFile, const char * sTraceMsg, ... ) if( FAILED( s_nOleError ) ) { // Try again without removing the assign prefix (_). - bstrMessage = hb_oleAnsiToSysString( ( LPSTR ) hb_itemGetSymbol( hb_stackBaseItem() )->szName ); - s_nOleError = pDisp->lpVtbl->GetIDsOfNames( pDisp, (REFIID) &IID_NULL, (wchar_t **) &bstrMessage, 1, 0, &DispID ); + bstrMessage = hb_oleAnsiToSysString( szName ); + s_nOleError = pDisp->lpVtbl->GetIDsOfNames( pDisp, (REFIID) &IID_NULL, (wchar_t **) &bstrMessage, 1, 0, pDispID ); SysFreeString( bstrMessage ); - //TraceLog( NULL, "2. ID of: '%s' -> %i Result: %p\n", hb_itemGetSymbol( hb_stackBaseItem() )->szName, DispID, s_nOleError ); + //TraceLog( NULL, "2. ID of: '%s' -> %i Result: %p\n", szName, *pDispID, s_nOleError ); } - if( SUCCEEDED( s_nOleError ) ) - { - PHB_ITEM *aPrgParams = GetParams( &DispParams ); + return s_nOleError; + } + //---------------------------------------------------------------------------// + HB_FUNC( TOLEAUTO_INVOKE ) + { + IDispatch *pDisp; + char *szName = hb_parc(1); + DISPID DispID; + DISPPARAMS DispParams; + + hb_vmPushSymbol( s_pSym_hObj->pSymbol ); + hb_vmPush( hb_stackSelfItem() ); + hb_vmSend( 0 ); + + pDisp = ( IDispatch * ) hb_parnl( -1 ); + + if( szName && SUCCEEDED( OleGetID( pDisp, szName, &DispID, NULL ) ) ) + { + PHB_ITEM *aPrgParams = GetParams( &DispParams, 1 ); + + if( SUCCEEDED( OleInvoke( pDisp, DispID, &DispParams ) ) ) + { + RetValue(); + } + + FreeParams( &DispParams, aPrgParams ); + } + } + + //---------------------------------------------------------------------------// + HB_FUNC( TOLEAUTO_SET ) + { + IDispatch *pDisp; + char *szName = hb_parc(1); + DISPID DispID; + DISPPARAMS DispParams; + + hb_vmPushSymbol( s_pSym_hObj->pSymbol ); + hb_vmPush( hb_stackSelfItem() ); + hb_vmSend( 0 ); + pDisp = ( IDispatch * ) hb_parnl( -1 ); + + if( szName && SUCCEEDED( OleGetID( pDisp, szName, &DispID, NULL ) ) ) + { + PHB_ITEM *aPrgParams = GetParams( &DispParams, 1 ); + + if( SUCCEEDED( OleSetProperty( pDisp, DispID, &DispParams ) ) ) + { + RetValue(); + } + + FreeParams( &DispParams, aPrgParams ); + } + } + + //---------------------------------------------------------------------------// + HB_FUNC( TOLEAUTO_GET ) + { + IDispatch *pDisp; + char *szName = hb_parc(1); + DISPID DispID; + DISPPARAMS DispParams; + + hb_vmPushSymbol( s_pSym_hObj->pSymbol ); + hb_vmPush( hb_stackSelfItem() ); + hb_vmSend( 0 ); + pDisp = ( IDispatch * ) hb_parnl( -1 ); + + if( szName && SUCCEEDED( OleGetID( pDisp, szName, &DispID, NULL ) ) ) + { + PHB_ITEM *aPrgParams = GetParams( &DispParams, 1 ); + + if( SUCCEEDED( OleGetProperty( pDisp, DispID, &DispParams ) ) ) + { + RetValue(); + } + + FreeParams( &DispParams, aPrgParams ); + } + } + + //---------------------------------------------------------------------------// + HB_FUNC( TOLEAUTO_ONERROR ) + { + IDispatch *pDisp; + DISPID DispID; + DISPPARAMS DispParams; + BOOL bSetFirst = FALSE, bTryDefault = TRUE; + PHB_ITEM *aPrgParams = GetParams( &DispParams, 0 ); + + //TraceLog( NULL, "Class: '%s' Message: '%s', Params: %i Arg1: %i\n", hb_objGetClsName( hb_stackSelfItem() ), hb_itemGetSymbol( hb_stackBaseItem() )->szName, hb_pcount(), hb_parinfo(1) ); + + hb_vmPushSymbol( s_pSym_hObj->pSymbol ); + hb_vmPush( hb_stackSelfItem() ); + hb_vmSend( 0 ); + pDisp = ( IDispatch * ) hb_parnl( -1 ); + + OleGetID : + + if( SUCCEEDED( OleGetID( pDisp, hb_itemGetSymbol( hb_stackBaseItem() )->szName, &DispID, &bSetFirst ) ) ) + { VariantClear( &RetVal ); if( bSetFirst ) { - DispParams.rgdispidNamedArgs = &lPropPut; - DispParams.cNamedArgs = 1; - - OleSetProperty( pDisp, DispID, &DispParams ); - //TraceLog( NULL, "OleSetProperty %i\n", s_nOleError ); - - if( SUCCEEDED( s_nOleError ) ) + if( SUCCEEDED( OleSetProperty( pDisp, DispID, &DispParams ) ) ) { hb_itemReturn( hb_stackItemFromBase( 1 ) ); } - else - { - DispParams.rgdispidNamedArgs = NULL; - DispParams.cNamedArgs = 0; - } + + //TraceLog( NULL, "FIRST OleSetProperty %i\n", s_nOleError ); + } + else + { + s_nOleError = E_PENDING; } - if( bSetFirst == FALSE || FAILED( s_nOleError ) ) + if( FAILED( s_nOleError ) ) { - OleInvoke( pDisp, DispID, &DispParams ); + if( SUCCEEDED( OleInvoke( pDisp, DispID, &DispParams ) ) ) + { + RetValue(); + } + //TraceLog( NULL, "OleInvoke %i\n", s_nOleError ); + } - if( SUCCEEDED( s_nOleError ) ) + if( FAILED( s_nOleError ) ) + { + if( SUCCEEDED( OleGetProperty( pDisp, DispID, &DispParams ) ) ) { RetValue(); } - } - // Collections are properties that do require arguments! - if( FAILED( s_nOleError ) /* && hb_pcount() == 0 */ ) - { - OleGetProperty( pDisp, DispID, &DispParams ); //TraceLog( NULL, "OleGetProperty(%i) %i\n", DispParams.cArgs, s_nOleError ); - - if( SUCCEEDED( s_nOleError ) ) - { - RetValue(); - } } - if( FAILED( s_nOleError ) && hb_pcount() >= 1 ) + if( FAILED( s_nOleError ) && bSetFirst == FALSE && hb_pcount() >= 1 ) { - DispParams.rgdispidNamedArgs = &lPropPut; - DispParams.cNamedArgs = 1; - - OleSetProperty( pDisp, DispID, &DispParams ); - //TraceLog( NULL, "OleSetProperty %i\n", s_nOleError ); - - if( SUCCEEDED( s_nOleError ) ) + if( SUCCEEDED( OleSetProperty( pDisp, DispID, &DispParams ) ) ) { hb_itemReturn( hb_stackItemFromBase( 1 ) ); } - } - FreeParams( &DispParams, aPrgParams ); + //TraceLog( NULL, "OleSetProperty %i\n", s_nOleError ); + } } if( SUCCEEDED( s_nOleError ) ) @@ -2087,14 +2170,27 @@ static void TraceLog( const char * sFile, const char * sTraceMsg, ... ) else { // Try to apply the requested message to the DEFAULT Method of the object if any. - if( SUCCEEDED( ( s_nOleError = OleGetValue( pDisp ) ) ) ) + if( bTryDefault ) { - //TraceLog( NULL, "Try using DISPID_VALUE\n" ); - pDisp = OleVal.n1.n2.n3.pdispVal; - goto OleGetID; + if( SUCCEEDED( ( /* s_nOleError = */ OleGetValue( pDisp ) ) ) ) + { + bTryDefault = FALSE; + + //TraceLog( NULL, "Try using DISPID_VALUE\n" ); + pDisp = OleVal.n1.n2.n3.pdispVal; + goto OleGetID; + } } //TraceLog( NULL, "Invoke Failed!\n" ); OleThrowError(); } + + FreeParams( &DispParams, aPrgParams ); + + // We are responsible to release the Default Interface which we retrieved + if( bTryDefault == FALSE && pDisp ) + { + pDisp->lpVtbl->Release( pDisp ); + } } diff --git a/harbour/contrib/ole2/win32ole.prg b/harbour/contrib/ole2/win32ole.prg index 995b15bb16..dd31c87673 100644 --- a/harbour/contrib/ole2/win32ole.prg +++ b/harbour/contrib/ole2/win32ole.prg @@ -165,8 +165,13 @@ CLASS TOleAuto METHOD GetActiveObject( cClass ) CONSTRUCTOR METHOD Invoke() - MESSAGE Set METHOD Invoke() - MESSAGE Get METHOD Invoke() + MESSAGE CallMethod METHOD Invoke() + + METHOD Set() + MESSAGE SetProperty METHOD Set() + + METHOD Get() + MESSAGE GetProperty METHOD Get() METHOD OleValue() METHOD _OleValue( xSetValue ) @@ -336,11 +341,6 @@ METHOD GetActiveObject( cClass ) CLASS TOleAuto RETURN Self -//-------------------------------------------------------------------- -METHOD Invoke( cMethod, ... ) CLASS TOleAuto - -RETURN HB_ExecFromArray( Self, cMethod, { ... } ) - //-------------------------------------------------------------------- METHOD OleCollection( xIndex, xValue ) CLASS TOleAuto @@ -580,7 +580,7 @@ METHOD OleValueEqual( xArg ) CLASS TOleAuto oErr:CanSubstitute := .T. oErr:Description := "argument error" oErr:GenCode := EG_ARG - oErr:Operation := '%' + oErr:Operation := '=' oErr:Severity := ES_ERROR oErr:SubCode := 1085 oErr:SubSystem := "BASE" @@ -605,7 +605,7 @@ METHOD OleValueExactEqual( xArg ) CLASS TOleAuto oErr:CanSubstitute := .T. oErr:Description := "argument error" oErr:GenCode := EG_ARG - oErr:Operation := '%' + oErr:Operation := '==' oErr:Severity := ES_ERROR oErr:SubCode := 1085 oErr:SubSystem := "BASE" @@ -630,7 +630,7 @@ METHOD OleValueNotEqual( xArg ) CLASS TOleAuto oErr:CanSubstitute := .T. oErr:Description := "argument error" oErr:GenCode := EG_ARG - oErr:Operation := '%' + oErr:Operation := '!=' oErr:Severity := ES_ERROR oErr:SubCode := 1085 oErr:SubSystem := "BASE" diff --git a/harbour/source/rtl/gttrm/gttrm.c b/harbour/source/rtl/gttrm/gttrm.c index 5de33b83f7..e573cf1d89 100644 --- a/harbour/source/rtl/gttrm/gttrm.c +++ b/harbour/source/rtl/gttrm/gttrm.c @@ -1482,6 +1482,11 @@ static void hb_gt_trm_LinuxTone( double dFrequency, double dDuration ) HB_TRACE(HB_TR_DEBUG, ("hb_gt_trm_LinuxTone(%lf, %lf)", dFrequency, dDuration)); + if( s_termState.iACSC ) + { + hb_gt_trm_termOut( ( BYTE * ) "\033[10m", 5 ); + s_termState.iACSC = 0; + } snprintf( escseq, sizeof( escseq ), "\033[10;%d]\033[11;%d]\007", ( int ) dFrequency, ( int ) ( dDuration * 1000.0 / 18.2 ) ); hb_gt_trm_termOut( ( BYTE * ) escseq, strlen( escseq ) ); diff --git a/harbour/source/vm/dynsym.c b/harbour/source/vm/dynsym.c index 4f3186b0e8..54e5c7f5e3 100644 --- a/harbour/source/vm/dynsym.c +++ b/harbour/source/vm/dynsym.c @@ -120,6 +120,86 @@ HB_EXPORT PHB_DYNS hb_dynsymNew( PHB_SYMB pSymbol ) /* creates a new dynamic if( pDynSym ) /* If name exists */ { + if( ( pDynSym->pSymbol->scope.value & + pSymbol->scope.value & HB_FS_LOCAL ) != 0 && + pDynSym->pSymbol != pSymbol ) + { + /* Someone is using linker which allows to create binaries + * with multiple function definitions. It's a big chance that + * wrong binaries are created in such case, f.e both functions + * linked and not all references updated. Anyhow now we will + * have to guess which symbol is the real local one [druzus] + */ + /* Let's check if linker updated function address so both symbols + * refer to the same function + */ + if( pDynSym->pSymbol->value.pFunPtr == pSymbol->value.pFunPtr ) + { + /* The addresses have been updated, f.e. in such case works GCC + * in Linux (but not MinGW and DJGPP) if user will allow to create + * binaries with multiple symbols by + * -Wl,--allow-multiple-definition + * when whole module cannot be cleanly replaced. + * OpenWatcom for Linux, DOS and Windows (I haven't testes OS2 + * version), POCC and XCC (with /FORCE:MULTIPLE) also update + * addresses in such case. + * + * We are guessing that symbols are registered in reverted order + * so we remove the HB_FS_LOCAL flag from previously registered + * symbol but some linkers may use different order so it does + * not have to be true in all cases + */ + pDynSym->pSymbol->scope.value &= ~HB_FS_LOCAL; + } + else + { + /* We have multiple symbol with the same name which refer + * to different public functions inside this single binary + * Let's check if this symbol is loaded from dynamic library + * (.so, .dll, .dyn, ...) or .hrb file + */ + if( pSymbol->scope.value & HB_FS_PCODEFUNC ) + { + /* It's dynamic module so we are guessing that HVM + * intentionally not updated function address allowing + * multiple functions, f.e. programmer asked about keeping + * local references using HB_LIBLOAD()/__HBRLOAD() parameter. + * In such case update pDynSym address in the new symbol but + * do not register it as the main one + */ + pSymbol->pDynSym = pDynSym; /* place a pointer to DynSym */ + return pDynSym; /* Return pointer to DynSym */ + } + /* The multiple symbols comes from single binaries - we have to + * decide what to do with them. We can leave it as is or we can + * try to overload one symbol so both will point to the same + * function. For .prg code such overloading will work but not + * for C code which makes sth like: HB_FUNC_EXEC( funcname ) + * In such case we cannot do anything - we cannot even detect + * such situation. In some cases even linker cannot detect it + * because C compiler can make autoinlining or some bindings + * which are not visible for linker + */ + /* Let's try to overload one of the functions. Simple: + * pDynSym->pSymbol->value.pFunPtr = pSymbol->value.pFunPtr; + * is not good idea because it's possible that this symbol will + * be overloaded yet another time after preprocessing rest of + * symbols so we will use HB_FS_DEFERRED flag which is updated + * dynamically in hb_vmSend()/hb_vmDo() functions + */ +#define HB_OVERLOAD_MULTIPLE_FUNC + +#if defined( HB_OVERLOAD_MULTIPLE_FUNC ) +#if defined( __GNUC__ ) && !defined( __DJGPP__ ) + pDynSym->pSymbol->scope.value &= ~HB_FS_LOCAL; + pDynSym->pSymbol->scope.value |= HB_FS_DEFERRED; +#else + pSymbol->scope.value &= ~HB_FS_LOCAL; + pSymbol->scope.value |= HB_FS_DEFERRED; +#endif +#endif + } + } if( ( !pDynSym->pSymbol->value.pFunPtr && pSymbol->value.pFunPtr ) || ( pSymbol->scope.value & HB_FS_LOCAL ) != 0 ) { diff --git a/harbour/source/vm/proc.c b/harbour/source/vm/proc.c index 8a1f784ac2..c29c21e9e7 100644 --- a/harbour/source/vm/proc.c +++ b/harbour/source/vm/proc.c @@ -114,6 +114,13 @@ HB_FUNC( PROCFILE ) { pSym = hb_itemGetSymbol( hb_param( 1, HB_IT_SYMBOL ) ); } + else if( ISCHAR( 1 ) ) + { + PHB_DYNS pDynSym = hb_dynsymFindName( hb_parc( 1 ) ); + + if( pDynSym ) + pSym = pDynSym->pSymbol; + } else { long lOffset = hb_stackBaseProcOffset( hb_parni( 1 ) + 1 ); diff --git a/harbour/tests/multifnc/Makefile b/harbour/tests/multifnc/Makefile new file mode 100644 index 0000000000..d5c5aaab5a --- /dev/null +++ b/harbour/tests/multifnc/Makefile @@ -0,0 +1,55 @@ +# +# $Id$ +# + +ifeq ($(HB_COMPILER),gcc) +L_USR += -Wl,--allow-multiple-definition +else +ifeq ($(HB_COMPILER),gpp) +L_USR += -Wl,--allow-multiple-definition +else +ifeq ($(HB_COMPILER),djgpp) +L_USR += -Wl,--allow-multiple-definition +else +ifeq ($(HB_COMPILER),mingw32) +L_USR += -Wl,--allow-multiple-definition +else +ifeq ($(HB_COMPILER),xcc) +L_USR += /FORCE:MULTIPLE +else +ifeq ($(HB_COMPILER),pocc) +L_USR += /FORCE:MULTIPLE +endif +endif +endif +endif +endif +endif + +ifeq ($(HB_MAIN),) +HB_MAIN = std +endif + +ROOT = ../../ + +PRG_SOURCES=\ + t0.prg \ + t1.prg \ + t2.prg \ + +PRG_MAIN=t0.prg + +LIBS=\ + debug \ + vm \ + rtl \ + lang \ + codepage \ + rdd \ + rtl \ + vm \ + macro \ + pp \ + common \ + +include $(TOP)$(ROOT)config/bin.cf diff --git a/harbour/tests/multifnc/t0.prg b/harbour/tests/multifnc/t0.prg new file mode 100644 index 0000000000..c33124d614 --- /dev/null +++ b/harbour/tests/multifnc/t0.prg @@ -0,0 +1,23 @@ +proc main() +__NONOALERT() +? "main", procfile("main"), procfile(@main()) +? "alert", procfile("alert"), procfile(@alert()), alert() +? "p0", procfile("p0"), procfile(@p0()), (@p0()):exec(), p0(), t("p0",@p0(),p0(),"t0.prg") +? "p1", procfile("p1"), procfile(@p1()), (@p1()):exec(), p1(), t("p1",@p1(),p1(),"t0.prg") +? "p2", procfile("p2"), procfile(@p2()), (@p2()):exec(), p2(), t("p2",@p2(),p2(),"t1.prg") +? "p3", procfile("p3"), procfile(@p3()), (@p3()):exec(), p3(), t("p3",@p3(),p3(),"t0.prg") +? "p4", procfile("p4"), procfile(@p4()), (@p4()):exec(), p4(), t("p4",@p4(),p4(),"t1.prg") +? "p5", procfile("p5"), procfile(@p5()), (@p5()):exec(), p5(), t("p5",@p5(),p5(),"t2.prg") +? "===" +main2() + +func t(cFunc,sFunc,cResult,cModule) +if &(cFunc+"()")==cResult .and. sFunc:exec()==cResult .and. ; + upper(cModule)==upper(right(cResult,len(cModule))) + return "OK" +endif +return "ERR" + +func p0(); return "P0:t0.prg" +func p1(); return "P1:t0.prg" +func p3(); return "P3:t0.prg" diff --git a/harbour/tests/multifnc/t1.prg b/harbour/tests/multifnc/t1.prg new file mode 100644 index 0000000000..60b0956209 --- /dev/null +++ b/harbour/tests/multifnc/t1.prg @@ -0,0 +1,20 @@ +proc main2() +? "main2", procfile("main2"), procfile(@main2()) +? "alert", procfile("alert"), procfile(@alert()), alert() +? "p0", procfile("p0"), procfile(@p0()), (@p0()):exec(), p0(), t("p0",@p0(),p0(),"t0.prg") +? "p1", procfile("p1"), procfile(@p1()), (@p1()):exec(), p1(), t("p1",@p1(),p1(),"t0.prg") +? "p2", procfile("p2"), procfile(@p2()), (@p2()):exec(), p2(), t("p2",@p2(),p2(),"t1.prg") +? "p3", procfile("p3"), procfile(@p3()), (@p3()):exec(), p3(), t("p3",@p3(),p3(),"t0.prg") +? "p4", procfile("p4"), procfile(@p4()), (@p4()):exec(), p4(), t("p4",@p4(),p4(),"t1.prg") +? "p5", procfile("p5"), procfile(@p5()), (@p5()):exec(), p5(), t("p5",@p5(),p5(),"t2.prg") +? "===" +main3() +return + +func p1(); return "P1:t1.prg" +func p2(); return "P2:t1.prg" +func p3(); return "P3:t1.prg" +func p4(); return "P4:t1.prg" + +func alert() +return "[ALERT]" diff --git a/harbour/tests/multifnc/t2.prg b/harbour/tests/multifnc/t2.prg new file mode 100644 index 0000000000..0a79998fdb --- /dev/null +++ b/harbour/tests/multifnc/t2.prg @@ -0,0 +1,14 @@ +proc main3() +? "main3", procfile("main3"), procfile(@main3()) +? "alert", procfile("alert"), procfile(@alert()), alert() +? "p0", procfile("p0"), procfile(@p0()), (@p0()):exec(), p0(), t("p0",@p0(),p0(),"t0.prg") +? "p1", procfile("p1"), procfile(@p1()), (@p1()):exec(), p1(), t("p1",@p1(),p1(),"t0.prg") +? "p2", procfile("p2"), procfile(@p2()), (@p2()):exec(), p2(), t("p2",@p2(),p2(),"t1.prg") +? "p3", procfile("p3"), procfile(@p3()), (@p3()):exec(), p3(), t("p3",@p3(),p3(),"t0.prg") +? "p4", procfile("p4"), procfile(@p4()), (@p4()):exec(), p4(), t("p4",@p4(),p4(),"t1.prg") +? "p5", procfile("p5"), procfile(@p5()), (@p5()):exec(), p5(), t("p5",@p5(),p5(),"t2.prg") +return + +func p2(); return "P2:t2.prg" +func p3(); return "P3:t2.prg" +func p5(); return "P5:t2.prg" diff --git a/harbour/tests/oleenum.prg b/harbour/tests/oleenum.prg new file mode 100644 index 0000000000..3fe8776f8a --- /dev/null +++ b/harbour/tests/oleenum.prg @@ -0,0 +1,24 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * demonstration code for FOR EACH used for OLE objects + * this code needs HBOLE library + * + * Copyright 2007 Enrico Maria Giordano e.m.giordano at emagsoftware.it + * www - http://www.harbour-project.org + * + */ + +FUNCTION MAIN() + LOCAL oExcel := CREATEOBJECT( "Excel.Application" ) + LOCAL oWorkBook := oExcel:WorkBooks:Add() + LOCAL oWorkSheet + + FOR EACH oWorkSheet IN oWorkBook:WorkSheets + ? oWorkSheet:Name + NEXT + oExcel:Quit() +RETURN NIL