diff --git a/harbour/ChangeLog b/harbour/ChangeLog index f67f3aed63..f34d03804a 100644 --- a/harbour/ChangeLog +++ b/harbour/ChangeLog @@ -17,6 +17,202 @@ past entries belonging to author(s): Viktor Szakats. */ +2010-05-26 00:03 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl) + * harbour/contrib/hbwin/Makefile + + harbour/contrib/hbwin/hbolesrv.c + + added inproc OLE server implementation. It allows to create OLE/ACTIVEX + COM server in Harbour. Such OLE server allows can be used by programs + written in any languages supporting OLE automation (also in other + Harbour applications) + User ole server code should be linked as DLL which later can be + register in MS-Windows by regsvr32.exe program, i.e.: + regsvr32 myolesrv.dll + The OLE server code should contain DLLMAIN() PRG function which + is executed just after loading OLE inproc DLL server as server from + other application and also by regsrv32.exe during registration and + unregistration procedure. It has to initialize at least OLE server + ID and name usinf WIN_OleServerInit(). + + added new PRG function which intitialize OLE server: + WIN_OleServerInit( , , ; + [ | | | ], ; + [ | ] ) -> + is registered OLE server class GUID + + is OLE server class name + + is optional parameter with hash array containing messages + and instance variables used by OLE server. The keys in hash array + are strings with message names and values are actions. Codeblock + and symbol items means that given message is a method call and + any other value means that it's variable. + By default the same hash array is shared between all objects + created by registered server. It's important when hash array + contains values which are neither codeblock nor symbol items + so they are not used as method but rather as instance variables + because such instance variables are shared between OLE objects. + Setting 4-th parameter to .T. causes that each + objects receives it's own copy of item so instance + variables inside hash array are also local to OLE object. + Alternatively programmer can use or to create + seprate copy of hash array for each object, i.e.: + bAction := {|| hb_hClone( hValue ) } + When hash array contains symbol item (@funcName()) then when it's + executed by OLE object message it's possible to access the hash + array bound with given OLE object using QSelf() function. It maybe + useful if hash array contains instance variables and programmer + wants to access them. + Please remember that using hash array which was initialized to keep + original assign order by HB_HKEEPORDER( , .T. ) before + adding its items you can define strict message numbers (DISPIDs), i.e.: + hAction := {=>} + HB_HKEEPORDER( hAction, .T. ) + hAction[ "OPEN" ] := @myole_open() // DISPID=1 + hAction[ "CLOSE" ] := @myole_close() // DISPID=2 + hAction[ "SAVE" ] := @myole_save() // DISPID=3 + hAction[ "LOAD" ] := @myole_load() // DISPID=4 + hAction[ "PRINT" ] := @myole_print() // DISPID=5 + (see example in olesrv2.prg) + + is optional parameter with Harbour object which is used + as base for all newly created OLE objects. All messages (method and + instance variables) supported explicitly by object (except + ONERROR message redirecting) are inherited by OLE objects. Each + newly created OLE object uses the same object so its + instance variables are shared between all of them. If programmer + wants to create separate Harbour object for each OLE object then + he should use or , i.e.: + bAction := {|| myClass():new() } + + is optional parameter with codeblock executed when new + OLE object is created. It should return hash array or Harbour object + which will be used as base for newly created OLE object. + + is optional parameter with function symbol. This function + is executed when new OLE object is created and should return hash + array or Harbour object which is used as base for newly created + OLE object. + + If the 3-rd parameter is , or then + it's possible to also set 4-th parameter to .T. and + in such case parameter is used in different way. Newly + created OLE object accepts any massage names invoking for each + of them EVAL() message which is sent to with OLE message + name inserted as the 1-st item to OLE object parameters. + It allows to create OLE server which will accept unknown messages + redirecting them to some other code, i.e.: + if netio_connect( cServer,,, cPasswd ) + WIN_OleServerInit( cClassID, cServerName, @netio_funcExec(), .T. ) + endif + initialize OLE server which redirects all messages to default netio + connection establish by netio_connect(). + + If 3-rd parameter is not given then all HVM functions becomes + OLE methods and HVM memvars (public and private variables) are + OLE object instance variables so they are shared with all OLE + objects created by this interface. It works just like xHarbour.com + OLE server described at + http://xharbour.com/index.asp?page=add_on_oleserver&show_sub=7&show_i=1 + + ; TODO: add support for MT RPC servers. Current implementation cannot + be safely used in MT programs creating OLE objects and executing + their methods simultaneously in different threads without + additional user code which will serialize these operations. + ; TODO: replace message handler API in WIN_AxGetControl()/ + __AxRegisterHandler() which uses only fixed method IDs + and do not support method names with above one so user + can easy create activex controls which support message + names. This modificaiton will force updating user and 3-rd + party code but IMO should be done. Current interface is + simply too much limited to keep it. + ; Possible TODO: add support for user defined fixed message numbers + (DISPIDs) which are not continuous small numbers so + users cannot easy use hash arrays with strict order. + Is such functionality necessary? Can someone with + ActiveX experience say sth about it? + Above implementation has undocumented feature: + it supports hash arrays with keys using numbers only + which can be used like in __AxRegisterHandler() but + I haven't decided yet I should keep, extend or remove + such functionality. + + Please make real life test. + I do not have any practice with MS-Windows and OLE and most of above + code I wrote using only documentation so I'm very interesting in real + test results and user opinions about it. If some important functionality + is missing then please inform me about it. + BTW There are some 3-rd party activex implementation for [x]Harbour, i.e. + xharbour.com or FiveWin ones. Maybe someone familiar with them can create + PRG compatibility layer for Harbour. I cannot do that myself because I + do not know that products and their PRG API used in OLE/COM/ActiveX + implementations but if someone can describe it then I can help in such + implementation. + + + harbour/contrib/hbwin/hbolesrv.def + + harbour/contrib/hbwin/hbolesrv-mgw.def + + harbour/contrib/hbwin/hbolesrv-ow.def + + added .DEF link files which are necessary to correctly export + inproc OLE server DLL functions. It's possible that other compilers + or even different versions of the same compilers may use different + a little bit different .DEF files. I tested above with BCC5.5, + MinGW 3.4.5 and OpenWatcom 1.8. + + + harbour/contrib/hbwin/test/olesrv1.prg + + harbour/contrib/hbwin/test/olesrv1.hbp + + harbour/contrib/hbwin/test/oletst1.prg + + harbour/contrib/hbwin/test/oletst1.hbp + + added example of NETIO-RPC OLE server code with Harbour (PRG) client. + This server redirects all messages sent to its OLE objects to remote + HBNETIO server as function calls. It understands the following + messages: + CONNECT() - creates connection to the server, parameters like in + NETIO_CONNECT() and NETIO_GETCONNECTION() functions + DISCONNECT() - closes current connection + PROCEXISTS() - works like NETIO_PROCEXISTS() + PROCEXEC() - works like NETIO_PROCEXEC() + PROCEXECW() - works like NETIO_PROCEXECW() + FUNCEXEC() - works like NETIO_FUNCEXEC() + All other messages are redirected directly to RPS server as function + calls. + CONNECT() message should be executed by client to create + connection to the server. Each NETIO-RPC OLE object uses its own + connection which should be initialized. If CONNECT() is executed + more then once the current connection is closed. + DISCONNECT() is executed automatically when OLE object is destroyed + so it's not necessary to call it explicitly. + Please use hbmk2 and olesrv1.hbp to compile OLE server. OLE inproc + servers have to export some DLL entry functions which are defined + in .def files which have to be passed to linker. + Before client code can be tested the server has to be registered. + The server can be registered in given MS-Windows system using + regsvr32.exe command. To register the server use: + regsvr32 olesrv1.dll + and to unregister: + regsvr32 /u olesrv1.dll + + + harbour/contrib/hbwin/test/olesrv2.prg + + harbour/contrib/hbwin/test/olesrv2.hbp + + harbour/contrib/hbwin/test/oletst2.prg + + harbour/contrib/hbwin/test/oletst2.hbp + + added very simple example of OLE server using hash array with + strict item order (associative hash array) to define OLE objects + with fixed message numbers (DISPIDs) + Remember about registering the server by 'regsvr32 olesrv2.dll' + + + harbour/contrib/hbwin/test/olesrv3.prg + + harbour/contrib/hbwin/test/olesrv3.hbp + + harbour/contrib/hbwin/test/oletst3.prg + + harbour/contrib/hbwin/test/oletst3.hbp + + harbour/contrib/hbwin/test/oletst3.bas + + added example of OLE server code with Harbour (PRG) + and Visual Basic (BAS) clients. + This server redirects all messages sent to its OLE objects to HVM + functions and messages to HVM memver (public and private) variables + This server should work as xHarbour.com OLE servers described at: + http://xharbour.com/index.asp?page=add_on_oleserver&show_sub=7&show_i=1 + The server and clients code are nearly the same so users can easy + compare them. + Remember about registering the server by 'regsvr32 olesrv2.dll' + 2010-05-26 00:00 UTC+0200 Viktor Szakats (harbour.01 syenar.hu) * INSTALL - Deleted one no more true restriction regarding HB_BUILD_PKG. diff --git a/harbour/contrib/hbwin/Makefile b/harbour/contrib/hbwin/Makefile index e92766e115..1908fe1398 100644 --- a/harbour/contrib/hbwin/Makefile +++ b/harbour/contrib/hbwin/Makefile @@ -16,6 +16,7 @@ C_SOURCES := \ mapi.c \ olecore.c \ oleinit.c \ + hbolesrv.c \ wapi_alloc.c \ wapi_commctrl.c \ wapi_err.c \ diff --git a/harbour/contrib/hbwin/hbolesrv-mgw.def b/harbour/contrib/hbwin/hbolesrv-mgw.def new file mode 100644 index 0000000000..921beed4a6 --- /dev/null +++ b/harbour/contrib/hbwin/hbolesrv-mgw.def @@ -0,0 +1,6 @@ +EXPORTS +DllGetClassObject = DllGetClassObject@12 PRIVATE +DllCanUnloadNow = DllCanUnloadNow@0 PRIVATE +DllRegisterServer = DllRegisterServer@0 +DllUnregisterServer = DllUnregisterServer@0 +DllMain = DllMain@12 diff --git a/harbour/contrib/hbwin/hbolesrv-ow.def b/harbour/contrib/hbwin/hbolesrv-ow.def new file mode 100644 index 0000000000..02c7c6e0b0 --- /dev/null +++ b/harbour/contrib/hbwin/hbolesrv-ow.def @@ -0,0 +1,5 @@ +EXPORT DllGetClassObject = '_DllGetClassObject@12' PRIVATE +EXPORT DllCanUnloadNow = '_DllCanUnloadNow@0' PRIVATE +EXPORT DllRegisterServer = '_DllRegisterServer@0' +EXPORT DllUnregisterServer = '_DllUnregisterServer@0' +EXPORT DllMain = '_DllMain@12' diff --git a/harbour/contrib/hbwin/hbolesrv.c b/harbour/contrib/hbwin/hbolesrv.c new file mode 100644 index 0000000000..693acd3198 --- /dev/null +++ b/harbour/contrib/hbwin/hbolesrv.c @@ -0,0 +1,904 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * OLE server + * + * Copyright 2010 Przemyslaw Czerpak + * www - http://www.harbour-project.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). + * + * As a special exception, the Harbour Project gives permission for + * additional uses of the text contained in its release of Harbour. + * + * The exception is that, if you link the Harbour libraries with other + * files to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the Harbour library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the Harbour + * Project under the name Harbour. If you copy code from other + * Harbour Project or Free Software Foundation releases into a copy of + * Harbour, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for Harbour, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + * + */ + +#include "hbapi.h" + +#include "hbwinole.h" +#include + +#define MAX_CLSID_SIZE 64 +#define MAX_CLSNAME_SIZE 256 +#define MAX_REGSTR_SIZE ( MAX_CLSNAME_SIZE + 64 ) +#define REGTABLE_SIZE ( sizeof( s_regTable ) / sizeof( *s_regTable ) ) + +static const char *s_regTable[][ 3 ] = +{ + { "CLSID\\@", 0, "$" }, + { "CLSID\\@\\InprocServer32", 0, ( const char* ) -1 }, + { "CLSID\\@\\InprocServer32", "ThreadingModel", "Apartment" }, + { "CLSID\\@\\ProgId", 0, "$" }, + { "$", 0, "$" }, + { "$\\CLSID", 0, "@" } +}; + +static LONG s_lLockCount; +static LONG s_lObjectCount; + +static GUID s_IID_IHbOleServer; + +static char s_szClsId[ MAX_CLSID_SIZE ] = ""; +static char s_szClsName[ MAX_CLSNAME_SIZE ] = ""; + +static HB_BOOL s_fServerReady = HB_FALSE; +static HB_BOOL s_fHashClone = HB_FALSE; +static PHB_ITEM s_pAction = NULL; +static PHB_ITEM s_pMsgHash = NULL; +static PHB_ITEM s_pMsgArray = NULL; + +static HINSTANCE s_hInstDll; + +/* helper functions + */ +static DISPID hb_dynsymToDispId( PHB_DYNS pDynSym ) +{ + return ( DISPID ) hb_dynsymToNum( pDynSym ); +} + +static PHB_DYNS hb_dispIdToDynsym( DISPID dispid ) +{ + if( ( LONG ) dispid > 0 ) + return hb_dynsymFromNum( ( int ) dispid ); + else + return NULL; +} + +static void hb_errRT_OLESRV( HB_ERRCODE errGenCode, HB_ERRCODE errSubCode, HB_ERRCODE errOsCode, + const char * szDescription, const char * szOperation ) +{ + PHB_ITEM pError; + + pError = hb_errRT_New( ES_ERROR, "OLESERVER", errGenCode, errSubCode, + szDescription, szOperation, errOsCode, EF_NONE ); + if( hb_pcount() != 0 ) + { + /* HB_ERR_ARGS_BASEPARAMS */ + PHB_ITEM pArray = hb_arrayBaseParams(); + hb_errPutArgsArray( pError, pArray ); + hb_itemRelease( pArray ); + } + hb_errLaunch( pError ); + hb_errRelease( pError ); +} + +static HB_BOOL s_hashWithNumKeys( PHB_ITEM pHash ) +{ + HB_SIZE nLen = hb_hashLen( pHash ), n; + + for( n = 1; n <= nLen; ++n ) + { + PHB_ITEM pKey = hb_hashGetKeyAt( pHash, n ); + if( !pKey || !HB_IS_NUMERIC( pKey ) ) + return HB_FALSE; + } + + return HB_TRUE; +} + +static wchar_t* s_AnsiToWideBuffer( const char* szString, wchar_t* szWide, int iLen ) +{ + MultiByteToWideChar( CP_ACP, MB_PRECOMPOSED, szString, -1, szWide, iLen ); + szWide[ iLen - 1 ] = '0'; + return szWide; +} + +static int s_WideToAnsiBuffer( const wchar_t* wszString, char* szBuffer, int iLen ) +{ + int iResult = WideCharToMultiByte( CP_ACP, 0, wszString, -1, szBuffer, iLen, NULL, NULL ); + szBuffer[ iLen - 1 ] = '0'; + return iResult; +} + +static HB_BOOL s_getKeyValue( const char * pszKey, LPTSTR lpBuffer, int iLen ) +{ + char pszBuffer[ MAX_REGSTR_SIZE ], * pszPtr; + int iSize, iPos, iCount; + + if( pszKey == ( const char* ) -1 ) + return GetModuleFileName( s_hInstDll, lpBuffer, iLen ); + + pszPtr = pszBuffer; + iSize = HB_SIZEOFARRAY( pszBuffer ) - 1; + iPos = 0; + for( ;; ) + { + char c = pszKey[ iPos++ ]; + if( c == '$' || c == '@' || c == '\0' ) + { + if( --iPos ) + { + iCount = HB_MIN( iPos, iSize ); + memcpy( pszPtr, pszKey, iCount ); + pszKey += iPos; + pszPtr += iCount; + iSize -= iCount; + if( iSize == 0 ) + break; + iPos = 0; + } + if( c == '\0' ) + break; + else + { + const char * pszVal = c == '$' ? s_szClsName : s_szClsId; + iCount = ( int ) hb_strnlen( pszVal, iSize ); + memcpy( pszPtr, pszVal, iCount ); + pszKey++; + pszPtr += iCount; + iSize -= iCount; + if( iSize == 0 ) + break; + } + } + } + pszPtr[ 0 ] = '\0'; + +#ifdef UNICODE + s_AnsiToWideBuffer( pszBuffer, lpBuffer, iLen ); +#else + hb_strncpy( lpBuffer, pszBuffer, iLen - 1 ); +#endif + + return iSize != 0; +} + + +/* IHbOleServer + */ +#if !defined( HB_OLE_C_API ) +typedef struct +{ + HRESULT ( STDMETHODCALLTYPE * QueryInterface ) ( IDispatch*, REFIID, void** ); + ULONG ( STDMETHODCALLTYPE * AddRef ) ( IDispatch* ); + ULONG ( STDMETHODCALLTYPE * Release ) ( IDispatch* ); + HRESULT ( STDMETHODCALLTYPE * GetTypeInfoCount ) ( IDispatch*, UINT* ); + HRESULT ( STDMETHODCALLTYPE * GetTypeInfo ) ( IDispatch*, UINT, LCID, ITypeInfo** ); + HRESULT ( STDMETHODCALLTYPE * GetIDsOfNames ) ( IDispatch*, REFIID, LPOLESTR*, UINT, LCID, DISPID* ); + HRESULT ( STDMETHODCALLTYPE * Invoke ) ( IDispatch*, DISPID, REFIID, LCID, WORD, DISPPARAMS*, VARIANT*, EXCEPINFO*, UINT* ); +} IDispatchVtbl; +#endif + +typedef struct { + const IDispatchVtbl* lpVtbl; + DWORD count; + PHB_ITEM pAction; + HB_BOOL fGuids; +} IHbOleServer; + + +static HRESULT STDMETHODCALLTYPE QueryInterface( IDispatch* lpThis, + REFIID riid, void** ppRet ) +{ + if( IsEqualIID( riid, HB_ID_REF( IID_IUnknown ) ) || + IsEqualIID( riid, HB_ID_REF( IID_IDispatch ) ) ) + { + *ppRet = ( void* ) lpThis; + HB_VTBL( lpThis )->AddRef( HB_THIS( lpThis ) ); + return S_OK; + } + *ppRet = NULL; + return E_NOINTERFACE; +} + +static ULONG STDMETHODCALLTYPE AddRef( IDispatch* lpThis ) +{ + return ++( ( IHbOleServer * ) lpThis )->count; +} + +static ULONG STDMETHODCALLTYPE Release( IDispatch* lpThis ) +{ + IHbOleServer * pHbOleServer = ( IHbOleServer * ) lpThis; + + if( --pHbOleServer->count == 0 ) + { + if( pHbOleServer->pAction ) + { + hb_itemRelease( pHbOleServer->pAction ); + pHbOleServer->pAction = NULL; + } + hb_xfree( pHbOleServer ); + return 0; + } + return pHbOleServer->count; +} + +static HRESULT STDMETHODCALLTYPE GetTypeInfoCount( IDispatch* lpThis, + UINT* pInfoCount ) +{ + HB_SYMBOL_UNUSED( lpThis ); + HB_SYMBOL_UNUSED( pInfoCount ); + return E_NOTIMPL; +} + +static HRESULT STDMETHODCALLTYPE GetTypeInfo( IDispatch* lpThis, UINT iTInfo, + LCID lcid, ITypeInfo** ppTypeInfo ) +{ + HB_SYMBOL_UNUSED( lpThis ); + HB_SYMBOL_UNUSED( iTInfo ); + HB_SYMBOL_UNUSED( lcid ); + HB_SYMBOL_UNUSED( ppTypeInfo ); + return E_NOTIMPL; +} + +static HRESULT STDMETHODCALLTYPE GetIDsOfNames( IDispatch* lpThis, REFIID riid, + LPOLESTR* rgszNames, + UINT cNames, LCID lcid, + DISPID* rgDispId ) +{ + HRESULT hr = S_OK; + + HB_SYMBOL_UNUSED( lcid ); + + if( ! IsEqualIID( riid, HB_ID_REF( IID_NULL ) ) ) + hr = DISP_E_UNKNOWNINTERFACE; + else if( ( ( IHbOleServer * ) lpThis )->fGuids ) + return E_NOTIMPL; + else if( cNames > 0 ) + { + char szName[ HB_SYMBOL_NAME_LEN + 1 ]; + DISPID dispid = 0; + UINT ui; + + if( s_WideToAnsiBuffer( rgszNames[ 0 ], szName, + ( int ) sizeof( szName ) ) != 0 ) + { + PHB_ITEM pAction; + + pAction = ( ( IHbOleServer * ) lpThis )->pAction; + if( !pAction ) + pAction = s_pAction; + if( pAction ) + { + if( s_pMsgHash ) + { + HB_SIZE nPos = hb_hashGetCItemPos( s_pMsgHash, szName ); + + if( nPos ) + nPos = hb_itemGetNL( hb_hashGetValueAt( s_pMsgHash, nPos ) ); + else + { + PHB_ITEM pKey, pValue; + + pKey = hb_itemPutC( hb_stackAllocItem(), szName ); + hb_arrayAdd( s_pMsgArray, pKey ); + nPos = hb_arrayLen( s_pMsgArray ); + pValue = hb_itemPutNL( hb_stackAllocItem(), ( long ) nPos ); + hb_hashAdd( s_pMsgHash, pKey, pValue ); + hb_stackPop(); + hb_stackPop(); + } + dispid = ( DISPID ) nPos; + } + else if( HB_IS_HASH( pAction ) ) + { + HB_SIZE nPos = hb_hashGetCItemPos( pAction, szName ); + + if( nPos ) + dispid = ( DISPID ) nPos; + } + else if( HB_IS_OBJECT( pAction ) ) + { + PHB_DYNS pDynSym = hb_dynsymFindName( szName ); + + if( pDynSym && hb_objHasMessage( pAction, pDynSym ) ) + dispid = hb_dynsymToDispId( pDynSym ); + } + } + else + { + PHB_DYNS pDynSym = hb_dynsymFindName( szName ); + + if( pDynSym && ( hb_dynsymIsFunction( pDynSym ) || + hb_dynsymIsMemvar( pDynSym ) ) ) + dispid = hb_dynsymToDispId( pDynSym ); + } + } + + for( ui = 0; ui < cNames; ++ui ) + rgDispId[ ui ] = DISPID_UNKNOWN; + + hr = DISP_E_UNKNOWNNAME; + if( dispid ) + { + rgDispId[ 0 ] = dispid; + if( cNames == 1 ) + hr = S_OK; + } + } + + return hr; +} + +static HRESULT STDMETHODCALLTYPE Invoke( IDispatch* lpThis, DISPID dispid, REFIID riid, + LCID lcid, WORD wFlags, DISPPARAMS* pParams, + VARIANT* pVarResult, EXCEPINFO* pExcepInfo, + UINT* puArgErr ) +{ + PHB_DYNS pDynSym; + PHB_ITEM pAction; + + HB_SYMBOL_UNUSED( lcid ); + HB_SYMBOL_UNUSED( pExcepInfo ); + HB_SYMBOL_UNUSED( puArgErr ); + + if( ! IsEqualIID( riid, HB_ID_REF( IID_NULL ) ) ) + return DISP_E_UNKNOWNINTERFACE; + + pAction = ( ( IHbOleServer * ) lpThis )->pAction; + if( !pAction ) + pAction = s_pAction; + + if( pAction ) + { + HB_BOOL fResult = HB_FALSE; + + if( s_pMsgHash ) + { + if( ( wFlags & DISPATCH_METHOD ) != 0 || + ( ( wFlags & DISPATCH_PROPERTYGET ) != 0 && pParams->cArgs == 0 ) || + ( ( wFlags & DISPATCH_PROPERTYPUT ) != 0 && pParams->cArgs == 1 ) ) + { + fResult = hb_oleDispInvoke( NULL, pAction, + hb_arrayGetItemPtr( s_pMsgArray, ( HB_SIZE ) dispid ), + pParams, pVarResult ); + } + } + else if( HB_IS_HASH( pAction ) ) + { + PHB_ITEM pKey, pItem; + + if( ( ( IHbOleServer * ) lpThis )->fGuids ) + { + pKey = hb_itemPutNL( hb_stackAllocItem(), ( long ) dispid ); + pItem = hb_hashGetItemPtr( pAction, pKey, 0 ); + } + else + { + pKey = NULL; + pItem = hb_hashGetValueAt( pAction, ( HB_SIZE ) dispid ); + } + + if( pItem ) + { + if( HB_IS_EVALITEM( pItem ) ) + { + if( ( wFlags & DISPATCH_METHOD ) != 0 ) + { + PHB_SYMB pSym = hb_itemGetSymbol( pItem ); + fResult = hb_oleDispInvoke( pSym, pSym ? pAction : pItem, pKey, + pParams, pVarResult ); + } + } + else if( ( wFlags & DISPATCH_PROPERTYGET ) != 0 && + pParams->cArgs == 0 ) + { + if( pVarResult ) + hb_oleItemToVariant( pVarResult, pItem ); + fResult = HB_TRUE; + } + else if( ( wFlags & DISPATCH_PROPERTYPUT ) != 0 && + pParams->cArgs == 1 ) + { + hb_oleVariantToItem( pItem, &pParams->rgvarg[ 0 ] ); + fResult = HB_TRUE; + } + } + if( pKey ) + hb_stackPop(); + } + else if( HB_IS_OBJECT( pAction ) ) + { + pDynSym = hb_dispIdToDynsym( dispid ); + if( pDynSym && ( wFlags & DISPATCH_PROPERTYPUT ) != 0 ) + { + if( pParams->cArgs == 1 ) + { + char szName[ HB_SYMBOL_NAME_LEN + 1 ]; + szName[ 0 ] = '_'; + hb_strncpy( szName + 1, hb_dynsymName( pDynSym ), sizeof( szName ) - 2 ); + pDynSym = hb_dynsymFindName( szName ); + } + else + pDynSym = NULL; + } + if( pDynSym && hb_objHasMessage( pAction, pDynSym ) ) + { + fResult = hb_oleDispInvoke( hb_dynsymSymbol( pDynSym ), pAction, NULL, + pParams, pVarResult ); + } + } + if( !fResult ) + return DISP_E_MEMBERNOTFOUND; + } + else + { + pDynSym = hb_dispIdToDynsym( dispid ); + if( !pDynSym ) + return DISP_E_MEMBERNOTFOUND; + + if( wFlags & DISPATCH_PROPERTYPUT ) + { + if( pParams->cArgs == 1 && hb_dynsymIsMemvar( pDynSym ) ) + { + PHB_ITEM pItem = hb_stackAllocItem(); + + hb_oleVariantToItem( pItem, &pParams->rgvarg[ 0 ] ); + hb_memvarSetValue( hb_dynsymSymbol( pDynSym ), pItem ); + hb_stackPop(); + return S_OK; + } + else + return DISP_E_MEMBERNOTFOUND; + } + else if( ( wFlags & DISPATCH_PROPERTYGET ) && + pParams->cArgs == 0 && hb_dynsymIsMemvar( pDynSym ) ) + { + if( pVarResult ) + { + PHB_ITEM pItem = hb_stackAllocItem(); + hb_memvarGet( pItem, hb_dynsymSymbol( pDynSym ) ); + hb_oleItemToVariant( pVarResult, pItem ); + hb_stackPop(); + } + return S_OK; + } + else if( ( wFlags & DISPATCH_METHOD ) == 0 || + !hb_dynsymIsFunction( pDynSym ) ) + return DISP_E_MEMBERNOTFOUND; + else if( !hb_oleDispInvoke( hb_dynsymSymbol( pDynSym ), NULL, NULL, + pParams, pVarResult ) ) + return DISP_E_MEMBERNOTFOUND; + } + + return S_OK; +} + +static const IDispatchVtbl IHbOleServer_Vtbl = { + QueryInterface, + AddRef, + Release, + GetTypeInfoCount, + GetTypeInfo, + GetIDsOfNames, + Invoke +}; + + +/* IClassFactory object + */ +#if !defined( HB_OLE_C_API ) +typedef struct +{ + HRESULT ( STDMETHODCALLTYPE * QueryInterface ) ( IClassFactory*, REFIID, void** ); + ULONG ( STDMETHODCALLTYPE * AddRef ) ( IClassFactory* ); + ULONG ( STDMETHODCALLTYPE * Release ) ( IClassFactory* ); + HRESULT ( STDMETHODCALLTYPE * CreateInstance ) ( IClassFactory*, IUnknown*, REFIID, void** ); + HRESULT ( STDMETHODCALLTYPE * LockServer) ( IClassFactory*, BOOL ); +} IClassFactoryVtbl; +#endif + +typedef struct { + const IClassFactoryVtbl* lpVtbl; +} IHbClassFactory; + +static IHbClassFactory s_IClassFactoryObj; + + +static HRESULT STDMETHODCALLTYPE classQueryInterface( IClassFactory* lpThis, + REFIID riid, + void** ppRet ) +{ + if( IsEqualIID( riid, HB_ID_REF( IID_IUnknown ) ) || + IsEqualIID( riid, HB_ID_REF( IID_IClassFactory ) ) ) + { + *ppRet = ( void* ) lpThis; + HB_VTBL( lpThis )->AddRef( HB_THIS( lpThis ) ); + return S_OK; + } + *ppRet = NULL; + return E_NOINTERFACE; +} + +static ULONG STDMETHODCALLTYPE classAddRef( IClassFactory* lpThis ) +{ + HB_SYMBOL_UNUSED( lpThis ); + + InterlockedIncrement( &s_lObjectCount ); + return 1; +} + +static ULONG STDMETHODCALLTYPE classRelease( IClassFactory* lpThis ) +{ + HB_SYMBOL_UNUSED( lpThis ); + + return InterlockedDecrement( &s_lObjectCount ); +} + +static HRESULT STDMETHODCALLTYPE classCreateInstance( IClassFactory* lpThis, + IUnknown* punkOuter, + REFIID riid, + void** ppvObj ) +{ + HRESULT hr; + + HB_SYMBOL_UNUSED( lpThis ); + + *ppvObj = NULL; + + if( punkOuter ) + hr = CLASS_E_NOAGGREGATION; + else + { + IHbOleServer * thisobj = ( IHbOleServer * ) hb_xalloc( sizeof( IHbOleServer ) ); + + if( !thisobj ) + hr = E_OUTOFMEMORY; + else + { + thisobj->lpVtbl = &IHbOleServer_Vtbl; + thisobj->count = 1; + thisobj->pAction = NULL; + thisobj->fGuids = HB_FALSE; + if( s_pAction ) + { + if( HB_IS_EVALITEM( s_pAction ) ) + { + if( hb_vmRequestReenter() ) + { + hb_vmPushEvalSym(); + hb_vmPush( s_pAction ); + hb_vmProc( 0 ); + thisobj->pAction = hb_itemNew( hb_stackReturnItem() ); + hb_vmRequestRestore(); + } + } + else if( HB_IS_HASH( s_pAction ) ) + { + if( s_fHashClone ) + thisobj->pAction = hb_itemClone( s_pAction ); + else if( !s_pMsgHash && s_hashWithNumKeys( s_pAction ) ) + thisobj->fGuids = HB_TRUE; + } + } + hr = IHbOleServer_Vtbl.QueryInterface( ( IDispatch* ) thisobj, riid, ppvObj ); + IHbOleServer_Vtbl.Release( ( IDispatch* ) thisobj ); + if( hr == S_OK ) + InterlockedIncrement( &s_lObjectCount ); + } + } + return hr; +} + +static HRESULT STDMETHODCALLTYPE classLockServer( IClassFactory* lpThis, + BOOL fLock ) +{ + HB_SYMBOL_UNUSED( lpThis ); + + if( fLock ) + InterlockedIncrement( &s_lLockCount ); + else + InterlockedDecrement( &s_lLockCount ); + + return S_OK; +} + +static const IClassFactoryVtbl IClassFactory_Vtbl = { + classQueryInterface, + classAddRef, + classRelease, + classCreateInstance, + classLockServer +}; + + +/* OLE InProc DLL server API + */ +STDAPI DllGetClassObject( REFCLSID rclsid, REFIID riid, void** ppv ) +{ + HRESULT hr; + + if( IsEqualCLSID( rclsid, HB_ID_REF( s_IID_IHbOleServer ) ) ) + { + hr = classQueryInterface( ( IClassFactory* ) ( void * ) &s_IClassFactoryObj, riid, ppv ); + } + else + { + *ppv = NULL; + hr = CLASS_E_CLASSNOTAVAILABLE; + } + + return hr; +} + +STDAPI DllCanUnloadNow( void ) +{ + return ( s_lObjectCount | s_lLockCount ) ? S_FALSE : S_OK; +} + + +/* server register/unregister code + */ + +STDAPI DllUnregisterServer( void ) +{ + TCHAR lpKeyName[ MAX_REGSTR_SIZE ]; + int i; + + for( i = ( int ) REGTABLE_SIZE - 1; i >= 0; --i ) + { + if( s_getKeyValue( s_regTable[ i ][ 0 ], lpKeyName, MAX_REGSTR_SIZE ) ) + RegDeleteKey( HKEY_CLASSES_ROOT, lpKeyName ); + } + + return S_OK; +} + +#ifndef SELFREG_E_CLASS +# ifndef SELFREG_E_FIRST +# define SELFREG_E_FIRST MAKE_SCODE( SEVERITY_ERROR, FACILITY_ITF, 0x0200 ) +# endif +# define SELFREG_E_CLASS ( SELFREG_E_FIRST + 1 ) +#endif + +STDAPI DllRegisterServer( void ) +{ + TCHAR lpKeyName[ MAX_REGSTR_SIZE ]; + TCHAR lpNameBuf[ MAX_REGSTR_SIZE ]; + TCHAR lpValue [ MAX_REGSTR_SIZE ]; + LPCTSTR lpValName; + HRESULT hr = S_OK; + HKEY hKey; + long err; + int i; + + for( i = 0; i < ( int ) REGTABLE_SIZE; ++i ) + { + s_getKeyValue( s_regTable[ i ][ 0 ], lpKeyName, MAX_REGSTR_SIZE ); + if( s_regTable[ i ][ 1 ] ) + { + s_getKeyValue( s_regTable[ i ][ 1 ], lpNameBuf, MAX_REGSTR_SIZE ); + lpValName = lpNameBuf; + } + else + lpValName = NULL; + s_getKeyValue( s_regTable[ i ][ 2 ], lpValue, MAX_REGSTR_SIZE ); + + err = RegCreateKeyEx( HKEY_CLASSES_ROOT, lpKeyName, + 0, NULL, REG_OPTION_NON_VOLATILE, + KEY_SET_VALUE | KEY_CREATE_SUB_KEY, + NULL, &hKey, NULL ); + + if( err == ERROR_SUCCESS ) + { + err = RegSetValueEx( hKey, lpValName, 0, REG_SZ, + ( const BYTE * ) lpValue, + ( lstrlen( lpValue ) + 1 ) * sizeof( TCHAR ) ); + RegCloseKey( hKey ); + } + if( err != ERROR_SUCCESS ) + { + DllUnregisterServer(); + hr = SELFREG_E_CLASS; + break; + } + } + + return hr; +} + +#if defined( HB_OS_WIN_CE ) && ( defined( _MSC_VER ) || defined( __POCC__ ) ) +BOOL WINAPI DllMain( HANDLE hInstance, DWORD dwReason, PVOID pvReserved ) +#else +BOOL WINAPI DllMain( HINSTANCE hInstance, DWORD dwReason, PVOID pvReserved ) +#endif +{ + static HB_BOOL s_fInit = HB_FALSE; + BOOL fResult = TRUE; + + HB_SYMBOL_UNUSED( pvReserved ); + + switch( dwReason ) + { + case DLL_PROCESS_ATTACH: + s_hInstDll = hInstance; + s_lLockCount = s_lObjectCount = 0; + s_IClassFactoryObj.lpVtbl = ( IClassFactoryVtbl * ) + &IClassFactory_Vtbl; + + DisableThreadLibraryCalls( hInstance ); + + s_fInit = !hb_vmIsActive(); + if( s_fInit ) + hb_vmInit( HB_FALSE ); + + if( !s_fServerReady ) + { + PHB_DYNS pDynSym = hb_dynsymFind( "DLLMAIN" ); + + if( pDynSym && hb_dynsymIsFunction( pDynSym ) && + hb_vmRequestReenter() ) + { + hb_vmPushDynSym( pDynSym ); + hb_vmPushNil(); + hb_vmProc( 0 ); + hb_vmRequestRestore(); + } + } + fResult = s_fServerReady ? TRUE : FALSE; + break; + + case DLL_PROCESS_DETACH: + s_fServerReady = HB_FALSE; + if( s_pAction ) + { + hb_itemRelease( s_pAction ); + s_pAction = NULL; + } + if( s_pMsgHash ) + { + hb_itemRelease( s_pMsgHash ); + s_pMsgHash = NULL; + } + if( s_pMsgArray ) + { + hb_itemRelease( s_pMsgArray ); + s_pMsgArray = NULL; + } + if( s_fInit ) + { + hb_vmQuit(); + s_fInit = HB_FALSE; + } + break; + } + + return fResult; +} + +/* WIN_OleServerInit( , , ; + * [ | | | ], ; + * [ | ] ) + */ +HB_FUNC( WIN_OLESERVERINIT ) +{ + HB_ERRCODE errCode = 0; + + if( !s_fServerReady ) + { + const char * pszClsId, * pszClsName; + + pszClsId = hb_parc( 1 ); + pszClsName = hb_parc( 2 ); + + if( pszClsId && pszClsName ) + { + WCHAR wcCLSID[ MAX_CLSID_SIZE ]; + + s_AnsiToWideBuffer( pszClsId, wcCLSID, HB_SIZEOFARRAY( wcCLSID ) ); + if( CLSIDFromString( wcCLSID, &s_IID_IHbOleServer ) == S_OK ) + { + PHB_ITEM pAction; + + s_fHashClone = HB_FALSE; + if( s_pMsgHash ) + { + hb_itemRelease( s_pMsgHash ); + s_pMsgHash = NULL; + } + if( s_pMsgArray ) + { + hb_itemRelease( s_pMsgArray ); + s_pMsgArray = NULL; + } + + pAction = hb_param( 3, HB_IT_HASH | HB_IT_BLOCK | HB_IT_SYMBOL ); + if( !pAction && HB_ISOBJECT( 3 ) ) + pAction = hb_param( 3, HB_IT_OBJECT ); + if( pAction ) + { + if( s_pAction ) + hb_itemRelease( s_pAction ); + s_pAction = hb_itemNew( pAction ); + + if( HB_ISLOG( 4 ) ) + { + if( hb_parl( 4 ) ) + { + if( HB_IS_HASH( s_pAction ) ) + s_fHashClone = HB_TRUE; + else + { + s_pMsgHash = hb_hashNew( hb_itemNew( NULL ) ); + s_pMsgArray = hb_itemArrayNew( 0 ); + } + } + } + else if( !HB_ISNIL( 4 ) ) + errCode = 1001; + } + else if( !HB_ISNIL( 3 ) ) + errCode = 1001; + + hb_strncpy( s_szClsId, pszClsId, sizeof( s_szClsId ) - 1 ); + hb_strncpy( s_szClsName, pszClsName, sizeof( s_szClsName ) - 1 ); + + s_fServerReady = HB_TRUE; + } + else + errCode = 1002; + } + else + errCode = 1001; + } + + if( errCode ) + hb_errRT_OLESRV( EG_ARG, errCode, 0, NULL, HB_ERR_FUNCNAME ); + else + hb_retl( s_fServerReady ); +} + +/* WIN_OleServerMsg( ) -> ) + */ +HB_FUNC( WIN_OLESERVERMSG ) +{ + if( s_pMsgArray ) + hb_itemReturn( hb_arrayGetItemPtr( s_pMsgArray, hb_parnl( 1 ) ) ); +} diff --git a/harbour/contrib/hbwin/hbolesrv.def b/harbour/contrib/hbwin/hbolesrv.def new file mode 100644 index 0000000000..d49b2e436d --- /dev/null +++ b/harbour/contrib/hbwin/hbolesrv.def @@ -0,0 +1,6 @@ +EXPORTS +DllGetClassObject PRIVATE +DllCanUnloadNow PRIVATE +DllRegisterServer +DllUnregisterServer +DllMain diff --git a/harbour/contrib/hbwin/tests/olesrv1.hbp b/harbour/contrib/hbwin/tests/olesrv1.hbp new file mode 100644 index 0000000000..a9d97371c3 --- /dev/null +++ b/harbour/contrib/hbwin/tests/olesrv1.hbp @@ -0,0 +1,16 @@ +# +# $Id$ +# + +olesrv1.prg +-w3 +-es2 +-lhbwin +-lhbnetio +-gtgui +-hbdynvm +-static +-cflag={watcom}-6r +{mingw}../hbolesrv-mgw.def +{watcom}../hbolesrv-ow.def +{!mingw&!watcom}../hbolesrv.def diff --git a/harbour/contrib/hbwin/tests/olesrv1.prg b/harbour/contrib/hbwin/tests/olesrv1.prg new file mode 100644 index 0000000000..a5d3e05ee4 --- /dev/null +++ b/harbour/contrib/hbwin/tests/olesrv1.prg @@ -0,0 +1,148 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * demonstration/test code for NETIO-RPC OLE server + * + * Copyright 2010 Przemyslaw Czerpak + * www - http://www.harbour-project.org + * + */ + + +#define CLS_Name "MyOleRPCServer" +#define CLS_ID "{23245C3F-4487-404B-985F-E33886698D23}" + +#include "hbclass.ch" + +/* DllMain() is OLE server entry point + * It's executed just after loading OLE inproc server + * as server from other application and also by regsrv32.exe + * during registration and unregistration procedure. + * It should initialize OLE server ID and name. + */ +PROCEDURE DllMain() + + /* Initialize OLE server ID and name. + * WIN_OleServerInit() should be executed from DllMain() + * + * WIN_OleServerInit( , , ; + * [ | | | ], ; + * [ | ] ) -> + * + * is registered OLE server class GUID + * + * is OLE server class name + * + * is optional parameter with hash array containing messages + * and instance variables used by OLE server. The keys in hash array + * are strings with message names and values are actions. Codeblock + * and symbol items means that given message is a method call and + * any other value means that it's variable. + * By default the same hash array is shared between all objects + * created by registered server. It's important when hash array + * contains values which are neither codeblock nor symbol items + * so they are not used as method but rather as instance variables + * because such instance variables are shared between OLE objects. + * Setting 4-th parameter to .T. causes that each + * objects receives it's own copy of item so instance + * variables inside hash array are also local to OLE object. + * Alternatively programmer can use or to create + * seprate copy of hash array for each object, i.e.: + * bAction := {|| hb_hClone( hValue ) } + * When hash array contains symbol item (@funcName()) then when it's + * executed by OLE object message it's possible to access the hash + * array bound with given OLE object using QSelf() function. It maybe + * useful if hash array contains instance variables and programmer + * wants to access them. + * Please remember that using hash array which was initialized to keep + * original assign order by HB_HKEEPORDER( , .T. ) before + * adding its items you can define strict message numbers (DISPIDs), i.e.: + * hAction := {=>} + * HB_HKEEPORDER( hAction, .T. ) + * hAction[ "OPEN" ] := @myole_open() // DISPID=1 + * hAction[ "CLOSE" ] := @myole_close() // DISPID=2 + * hAction[ "SAVE" ] := @myole_save() // DISPID=3 + * hAction[ "LOAD" ] := @myole_load() // DISPID=4 + * hAction[ "PRINT" ] := @myole_print() // DISPID=5 + * (see example in olesrv2.prg) + * + * is optional parameter with Harbour object which is used + * as base for all newly created OLE objects. All messages (method and + * instance variables) supported explicitly by object (except + * ONERROR message redirecting) are inherited by OLE objects. Each + * newly created OLE object uses the same object so its + * instance variables are shared between all of them. If programmer + * wants to create separate Harbour object for each OLE object then + * he should use or , i.e.: + * bAction := {|| myClass():new() } + * + * is optional parameter with codeblock executed when new + * OLE object is created. It should return hash array or Harbour object + * which will be used as base for newly created OLE object. + * + * is optional parameter with function symbol. This function + * is executed when new OLE object is created and should return hash + * array or Harbour object which is used as base for newly created + * OLE object. + * + * If the 3-rd parameter is , or then + * it's possible to also set 4-th parameter to .T. and + * in such case parameter is used in different way. Newly + * created OLE object accepts any massage names invoking for each + * of them EVAL() message which is sent to with OLE message + * name inserted as the 1-st item to OLE object parameters. + * It allows to create OLE server which will accept unknown messages + * redirecting them to some other code, i.e.: + * if netio_connect( cServer,,, cPasswd ) + * WIN_OleServerInit( cClassID, cServerName, @netio_funcExec(), .T. ) + * endif + * initialize OLE server which redirects all messages to default netio + * connection establish by netio_connect(). + * + * If 3-rd parameter is not given then all HVM functions becomes + * OLE methods and HVM memvars (public and private variables) are + * OLE object instance variables so they are shared with all OLE + * objects created by this interface. It works just like xHarbour.com + * OLE server described at + * http://xharbour.com/index.asp?page=add_on_oleserver&show_sub=7&show_i=1 + */ + + WIN_OleServerInit( CLS_ID, CLS_Name, {|| OleNetioSrv():new() }, .T. ) + +RETURN + + +CREATE CLASS OleNetioSrv +HIDDEN: + VAR pConn +EXPORTED: + METHOD Eval( cMethodName, ... ) +ENDCLASS + +METHOD Eval( cMethodName, ... ) CLASS OleNetioSrv + + SWITCH cMethodName + CASE "CONNECT" + RETURN !Empty( ::pConn := NETIO_GETCONNECTION( ... ) ) + CASE "DISCONNECT" + ::pConn := NIL + RETURN .T. + CASE "PROCEXISTS" + RETURN NETIO_PROCEXISTS( ::pConn, ... ) + CASE "PROCEXEC" + RETURN NETIO_PROCEXEC( ::pConn, ... ) + CASE "PROCEXECW" + RETURN NETIO_PROCEXECW( ::pConn, ... ) + CASE "FUNCEXEC" + RETURN NETIO_FUNCEXEC( ::pConn, ... ) + ENDSWITCH + +/* redirect all other messages to RPC server as function calls */ +RETURN NETIO_FUNCEXEC( ::pConn, cMethodName, ... ) + + +ANNOUNCE GT_SYS +REQUEST HB_GT_GUI_DEFAULT diff --git a/harbour/contrib/hbwin/tests/olesrv2.hbp b/harbour/contrib/hbwin/tests/olesrv2.hbp new file mode 100644 index 0000000000..82f16136e5 --- /dev/null +++ b/harbour/contrib/hbwin/tests/olesrv2.hbp @@ -0,0 +1,15 @@ +# +# $Id$ +# + +olesrv2.prg +-w3 +-es2 +-lhbwin +-gtgui +-hbdynvm +-static +-cflag={watcom}-6r +{mingw}../hbolesrv-mgw.def +{watcom}../hbolesrv-ow.def +{!mingw&!watcom}../hbolesrv.def diff --git a/harbour/contrib/hbwin/tests/olesrv2.prg b/harbour/contrib/hbwin/tests/olesrv2.prg new file mode 100644 index 0000000000..b23d103fad --- /dev/null +++ b/harbour/contrib/hbwin/tests/olesrv2.prg @@ -0,0 +1,49 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * demonstration/test code for OLE server using hash array with + * strict item order (associative hash array) to define OLE objects + * with fixed message numbers (DISPIDs) + * + * Copyright 2010 Przemyslaw Czerpak + * www - http://www.harbour-project.org + */ + +#define CLS_Name "MyOleTimeServer" +#define CLS_ID "{5552013F-2990-4D6C-9C96-55A4BDDCE376}" + +PROCEDURE DllMain() + + LOCAL hAction + + hAction := { => } + hb_HKeepOrder( hAction, .T. ) + hAction[ "DATE" ] := @date() // DISPID=1 + hAction[ "TIME" ] := @time() // DISPID=2 + hAction[ "DATETIME" ] := @hb_datetime() // DISPID=3 + hAction[ "VALUE" ] := NIL // DISPID=4 + hAction[ "GETDATA" ] := @get_data() // DISPID=5 + + /* Initialize OLE server ID and name. + * WIN_OleServerInit() should be executed from DllMain() + */ + WIN_OleServerInit( CLS_ID, CLS_Name, hAction, .T. ) + +RETURN + + +STATIC FUNCTION get_data( ... ) + LOCAL hAction := QSelf() + + IF hAction[ "VALUE" ] == NIL + RETURN "(:VALUE IS NOT SET)" + ENDIF + +RETURN ":VALUE='" + hAction[ "VALUE" ] + "'" + + +ANNOUNCE GT_SYS +REQUEST HB_GT_GUI_DEFAULT diff --git a/harbour/contrib/hbwin/tests/olesrv3.hbp b/harbour/contrib/hbwin/tests/olesrv3.hbp new file mode 100644 index 0000000000..1a64af5c3c --- /dev/null +++ b/harbour/contrib/hbwin/tests/olesrv3.hbp @@ -0,0 +1,15 @@ +# +# $Id$ +# + +olesrv3.prg +-w3 +-es2 +-lhbwin +-gtgui +-hbdynvm +-static +-cflag={watcom}-6r +{mingw}../hbolesrv-mgw.def +{watcom}../hbolesrv-ow.def +{!mingw&!watcom}../hbolesrv.def diff --git a/harbour/contrib/hbwin/tests/olesrv3.prg b/harbour/contrib/hbwin/tests/olesrv3.prg new file mode 100644 index 0000000000..d873669c70 --- /dev/null +++ b/harbour/contrib/hbwin/tests/olesrv3.prg @@ -0,0 +1,39 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * demonstration/test code for OLE server which works like + * xHarbour.com OLE servers described at + * http://xharbour.com/index.asp?page=add_on_oleserver&show_sub=7&show_i=1 + * + * Copyright 2010 Przemyslaw Czerpak + * www - http://www.harbour-project.org + * + */ + +#define CLS_Name "MyOleServer" +#define CLS_ID "{466AC7B2-35D7-4509-B909-C3C2F8FDBD3C}" + +PROCEDURE DllMain() + + PUBLIC Property1 + + M->Property1 := "MyProperty" + + /* Initialize OLE server ID and name. + * WIN_OleServerInit() should be executed from DllMain() + */ + WIN_OleServerInit( CLS_ID, CLS_Name ) + +RETURN + + +FUNCTION MyMethod( ... ) + +RETURN "Hello from MyOleServer [" + hb_valToExp( { ... } ) + "]" + + +ANNOUNCE GT_SYS +REQUEST HB_GT_GUI_DEFAULT diff --git a/harbour/contrib/hbwin/tests/oletst1.hbp b/harbour/contrib/hbwin/tests/oletst1.hbp new file mode 100644 index 0000000000..ad6f908a75 --- /dev/null +++ b/harbour/contrib/hbwin/tests/oletst1.hbp @@ -0,0 +1,9 @@ +# +# $Id$ +# + +oletst1.prg +-w3 +-es2 +-lhbwin +-cflag={watcom}-6r diff --git a/harbour/contrib/hbwin/tests/oletst1.prg b/harbour/contrib/hbwin/tests/oletst1.prg new file mode 100644 index 0000000000..f44b24f66f --- /dev/null +++ b/harbour/contrib/hbwin/tests/oletst1.prg @@ -0,0 +1,41 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * demonstration/test code for NETIO-RPC OLE server client + * + * Copyright 2010 Przemyslaw Czerpak + * www - http://www.harbour-project.org + * + */ + +#define NETSERVER "127.0.0.1" +#define NETPORT 2941 +#define NETPASSWD "topsecret" + +PROCEDURE Main() + LOCAL oObject + + oObject := win_OleCreateObject( "MyOleRPCServer" ) + + IF !Empty( oObject ) + IF oObject:connect( NETSERVER, NETPORT,, NETPASSWD ) + ? "Connected to the server:", NETSERVER + /* execute some functions on the server side and display + * the results. + */ + ? oObject:upper( "hello world !!!" ) + ? "SERVER DATE:", oObject:DATE() + ? "SERVER TIME:", oObject:TIME() + ? "SERVER DATETIME:", oObject:HB_DATETIME() + ELSE + ? "Cannot connect to the server:", NETSERVER + ENDIF + ELSE + ? "Can not access 'MyOleRPCServer' OLE server." + ENDIF + + WAIT +RETURN diff --git a/harbour/contrib/hbwin/tests/oletst2.hbp b/harbour/contrib/hbwin/tests/oletst2.hbp new file mode 100644 index 0000000000..73cf1c3656 --- /dev/null +++ b/harbour/contrib/hbwin/tests/oletst2.hbp @@ -0,0 +1,9 @@ +# +# $Id$ +# + +oletst2.prg +-w3 +-es2 +-lhbwin +-cflag={watcom}-6r diff --git a/harbour/contrib/hbwin/tests/oletst2.prg b/harbour/contrib/hbwin/tests/oletst2.prg new file mode 100644 index 0000000000..33a8b75b82 --- /dev/null +++ b/harbour/contrib/hbwin/tests/oletst2.prg @@ -0,0 +1,34 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * demonstration/test client code for OLE server using hash array with + * strict item order (associative hash array) to define OLE objects + * with fixed message numbers (DISPIDs) + * + * Copyright 2010 Przemyslaw Czerpak + * www - http://www.harbour-project.org + */ + +PROCEDURE Main() + LOCAL oObject + + oObject := win_OleCreateObject( "MyOleTimeServer" ) + + IF !Empty( oObject ) + ? "DATE:", oObject:date() + ? "TIME:", oObject:time() + ? "DATTIME:", oObject:datetime() + ? "VALUE:", oObject:value + ? "GETVALUE:", oObject:getvalue() + oObject:value := "hello" + ? "VALUE:", oObject:value + ? "GETVALUE:", oObject:getvalue() + ELSE + ? "Can not access 'MyOleTimeServer' OLE server." + ENDIF + + WAIT +RETURN diff --git a/harbour/contrib/hbwin/tests/oletst3.bas b/harbour/contrib/hbwin/tests/oletst3.bas new file mode 100644 index 0000000000..265ad6670e --- /dev/null +++ b/harbour/contrib/hbwin/tests/oletst3.bas @@ -0,0 +1,21 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * demonstration/test code for OLE server client which connects to + * Harbour OLE server working like xHarbour.com OLE servers described at + * http://xharbour.com/index.asp?page=add_on_oleserver&show_sub=7&show_i=1 + * This client code is based on xHarbour.com client example published on + * above WWW page. + */ + + +DIM oObject + +SET oObject = CreateObject( "MyOleServer" ) + +MsgBox oObject.MyFunc( "Hello", 123 ) + +MsgBox oObject.Property1 diff --git a/harbour/contrib/hbwin/tests/oletst3.hbp b/harbour/contrib/hbwin/tests/oletst3.hbp new file mode 100644 index 0000000000..718737ebae --- /dev/null +++ b/harbour/contrib/hbwin/tests/oletst3.hbp @@ -0,0 +1,9 @@ +# +# $Id$ +# + +oletst3.prg +-w3 +-es2 +-lhbwin +-cflag={watcom}-6r diff --git a/harbour/contrib/hbwin/tests/oletst3.prg b/harbour/contrib/hbwin/tests/oletst3.prg new file mode 100644 index 0000000000..7e7c6165cd --- /dev/null +++ b/harbour/contrib/hbwin/tests/oletst3.prg @@ -0,0 +1,29 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * demonstration/test code for OLE server client which connects to + * Harbour OLE server working like xHarbour.com OLE servers described at + * http://xharbour.com/index.asp?page=add_on_oleserver&show_sub=7&show_i=1 + * This client code is based on xHarbour.com client example published on + * above WWW page. + */ + +PROCEDURE Main() + LOCAL oObject + + BEGIN SEQUENCE WITH {|| break() } + oObject := CreateObject( "MyOleServer" ) + ? oObject:MyMethod( "Hello", 123, .t., ; + { hb_datetime(), 123.45, { date(), 2, 3 } } ) + ? oObject:Property1 + oObject:Property1 := "!!! >>>" + upper( oObject:Property1 ) + "<<< !!!" + ? oObject:Property1 + RECOVER + ? "Can not access 'MyOleServer' OLE server." + END SEQUENCE + + WAIT +RETURN