From 77ae9b90ecdf63becc7c2e8ca407cf5454b3e59c Mon Sep 17 00:00:00 2001 From: Przemyslaw Czerpak Date: Tue, 25 May 2010 22:04:04 +0000 Subject: [PATCH] 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' --- harbour/ChangeLog | 196 +++++ harbour/contrib/hbwin/Makefile | 1 + harbour/contrib/hbwin/hbolesrv-mgw.def | 6 + harbour/contrib/hbwin/hbolesrv-ow.def | 5 + harbour/contrib/hbwin/hbolesrv.c | 904 ++++++++++++++++++++++++ harbour/contrib/hbwin/hbolesrv.def | 6 + harbour/contrib/hbwin/tests/olesrv1.hbp | 16 + harbour/contrib/hbwin/tests/olesrv1.prg | 148 ++++ harbour/contrib/hbwin/tests/olesrv2.hbp | 15 + harbour/contrib/hbwin/tests/olesrv2.prg | 49 ++ harbour/contrib/hbwin/tests/olesrv3.hbp | 15 + harbour/contrib/hbwin/tests/olesrv3.prg | 39 + harbour/contrib/hbwin/tests/oletst1.hbp | 9 + harbour/contrib/hbwin/tests/oletst1.prg | 41 ++ harbour/contrib/hbwin/tests/oletst2.hbp | 9 + harbour/contrib/hbwin/tests/oletst2.prg | 34 + harbour/contrib/hbwin/tests/oletst3.bas | 21 + harbour/contrib/hbwin/tests/oletst3.hbp | 9 + harbour/contrib/hbwin/tests/oletst3.prg | 29 + 19 files changed, 1552 insertions(+) create mode 100644 harbour/contrib/hbwin/hbolesrv-mgw.def create mode 100644 harbour/contrib/hbwin/hbolesrv-ow.def create mode 100644 harbour/contrib/hbwin/hbolesrv.c create mode 100644 harbour/contrib/hbwin/hbolesrv.def create mode 100644 harbour/contrib/hbwin/tests/olesrv1.hbp create mode 100644 harbour/contrib/hbwin/tests/olesrv1.prg create mode 100644 harbour/contrib/hbwin/tests/olesrv2.hbp create mode 100644 harbour/contrib/hbwin/tests/olesrv2.prg create mode 100644 harbour/contrib/hbwin/tests/olesrv3.hbp create mode 100644 harbour/contrib/hbwin/tests/olesrv3.prg create mode 100644 harbour/contrib/hbwin/tests/oletst1.hbp create mode 100644 harbour/contrib/hbwin/tests/oletst1.prg create mode 100644 harbour/contrib/hbwin/tests/oletst2.hbp create mode 100644 harbour/contrib/hbwin/tests/oletst2.prg create mode 100644 harbour/contrib/hbwin/tests/oletst3.bas create mode 100644 harbour/contrib/hbwin/tests/oletst3.hbp create mode 100644 harbour/contrib/hbwin/tests/oletst3.prg 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