fivedev/harbour-core
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

2007-10-03 17:04 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl)

Browse Source 
+ 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 <nLevel> | <sFuncSym> | <cFuncName> 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.
This commit is contained in:
Przemyslaw Czerpak
2007-10-03 15:05:12 +00:00
parent 2df15f7e13
commit 0efe049e5d
12 changed files with 499 additions and 98 deletions
Download Patch File Download Diff File Expand all files Collapse all files

87
harbour/ChangeLog
View File

@@ -8,6 +8,93 @@
2002-12-01 13:30 UTC+0100 Foo Bar <foo.bar@foobar.org>
*/
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 <nLevel> | <sFuncSym> | <cFuncName> 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

12
harbour/contrib/Makefile
View File

@@ -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

250
harbour/contrib/ole2/w32ole.c
View File

@@ -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 );
}
}

20
harbour/contrib/ole2/win32ole.prg
View File

@@ -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"

5
harbour/source/rtl/gttrm/gttrm.c
View File

@@ -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 ) );

80
harbour/source/vm/dynsym.c
View File

@@ -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 )
{

7
harbour/source/vm/proc.c
View File

@@ -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 );

55
harbour/tests/multifnc/Makefile Normal file
View File

@@ -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

23
harbour/tests/multifnc/t0.prg Normal file
View File

@@ -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"

20
harbour/tests/multifnc/t1.prg Normal file
View File

@@ -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]"

14
harbour/tests/multifnc/t2.prg Normal file
View File

@@ -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"

24
harbour/tests/oleenum.prg Normal file
View File

@@ -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