From 3bdac9ab543e8d9f003cbdc2235c11d249fa4f16 Mon Sep 17 00:00:00 2001 From: Jorge Alberto Giraldo Salazar Date: Sun, 17 Feb 2002 01:24:41 +0000 Subject: [PATCH] CHANGELOG: 2002-02-16 17:00 UTC+0500 Jorge A. Giraldo --- harbour/contrib/delphi/hbdll/bld_sdll.bat | 84 +++++++++ harbour/contrib/delphi/hbdll/easypath.dpr | 17 ++ harbour/contrib/delphi/hbdll/errorsys.prg | 204 ++++++++++++++++++++++ harbour/contrib/delphi/hbdll/macrcall.c | 128 ++++++++++++++ harbour/contrib/delphi/hbdll/main.pas | 150 ++++++++++++++++ harbour/contrib/delphi/hbdll/myprog.prg | 113 ++++++++++++ harbour/contrib/delphi/hbdll/start.bat | 5 + 7 files changed, 701 insertions(+) create mode 100644 harbour/contrib/delphi/hbdll/bld_sdll.bat create mode 100644 harbour/contrib/delphi/hbdll/easypath.dpr create mode 100644 harbour/contrib/delphi/hbdll/errorsys.prg create mode 100644 harbour/contrib/delphi/hbdll/macrcall.c create mode 100644 harbour/contrib/delphi/hbdll/main.pas create mode 100644 harbour/contrib/delphi/hbdll/myprog.prg create mode 100644 harbour/contrib/delphi/hbdll/start.bat diff --git a/harbour/contrib/delphi/hbdll/bld_sdll.bat b/harbour/contrib/delphi/hbdll/bld_sdll.bat new file mode 100644 index 0000000000..4d63f7b4e6 --- /dev/null +++ b/harbour/contrib/delphi/hbdll/bld_sdll.bat @@ -0,0 +1,84 @@ +rem Self contained Harbour DLL, original idea and research Antonio Linares +rem +rem $Id$ +rem +@ECHO OFF +CLS + +if A%1 == A GOTO :SINTAX +if NOT EXIST %1.prg GOTO :NOEXIST + +ECHO Compiling... + +set hdir=c:\hb-dev\harbour +set bcdir=c:\borland\bcc55\bin + +%bcdir%\bcc32 -c -D__EXPORT__ -I..\..\..\include -L..\lib ..\..\..\source\vm\maindll.c + +rem Files to integrate harbour DLL to Delphi +%bcdir%\bcc32 -c -D__EXPORT__ -I..\..\..\include -L..\lib macrcall.c +%hdir%\bin\harbour -n -w errorsys +%bcdir%\bcc32 -c -D__EXPORT__ -I..\..\..\include -L..\lib errorsys.c + +%hdir%\bin\harbour %1 /b /n /i..\include;%hdir%\include /w /p %2 %3 > clip.log +@type clip.log +IF ERRORLEVEL 1 PAUSE +IF ERRORLEVEL 1 GOTO EXIT + +echo -O2 -I%hdir%\include %1.c > b32.bc +%bcdir%\bcc32 -M -c @b32.bc +:ENDCOMPILE + +IF EXIST %1.rc %bcdir%\brc32 -r %1 + +echo c0d32.obj + > b32.bc +echo %1.obj+errorsys.obj+maindll.obj+macrcall.obj, + >> b32.bc +echo %1.dll, + >> b32.bc +echo %1.map, + >> b32.bc +rem echo ..\lib\FiveH.lib ..\lib\FiveHC.lib + >> b32.bc +echo %hdir%\lib\rtl.lib + >> b32.bc +echo %hdir%\lib\vm.lib + >> b32.bc +echo %hdir%\lib\gtwin.lib + >> b32.bc +echo %hdir%\lib\lang.lib + >> b32.bc +echo %hdir%\lib\macro.lib + >> b32.bc +echo %hdir%\lib\rdd.lib + >> b32.bc +echo %hdir%\lib\dbfntx.lib + >> b32.bc +echo %hdir%\lib\dbfcdx.lib + >> b32.bc +echo %hdir%\lib\debug.lib + >> b32.bc +echo %hdir%\lib\common.lib + >> b32.bc +echo %hdir%\lib\pp.lib + >> b32.bc + +rem Uncomment these two lines to use Advantage RDD +rem echo %hdir%\lib\rddads.lib + >> b32.bc +rem echo ..\lib\Ace32.lib + >> b32.bc + +echo %bcdir%\lib\import32.lib + >> b32.bc +echo %bcdir%\lib\cw32.lib + >> b32.bc +echo %bcdir%\lib\psdk\odbc32.lib, >> b32.bc +IF EXIST %1.res echo %1.res >> b32.bc +%bcdir%\ilink32 -Tpd -aa -L\borland\bcc55\lib -L\borland\bcc55\lib\PSDK @b32.bc + +rem delete temporary files +@del %1.c +@del %1.il? + +IF ERRORLEVEL 1 GOTO LINKERROR +ECHO * self contained DLL successfully built +GOTO EXIT +ECHO + +:LINKERROR +rem if exist meminfo.txt notepad meminfo.txt +rem PAUSE * Linking errors * +GOTO EXIT + +:SINTAX +ECHO SYNTAX: Build [Program] {-- No especifiques la extensi˝n PRG +ECHO {-- Don't specify .PRG extension +GOTO EXIT + +:NOEXIST +ECHO The specified PRG %1 does not exist + +:EXIT + diff --git a/harbour/contrib/delphi/hbdll/easypath.dpr b/harbour/contrib/delphi/hbdll/easypath.dpr new file mode 100644 index 0000000000..7a7ec411fb --- /dev/null +++ b/harbour/contrib/delphi/hbdll/easypath.dpr @@ -0,0 +1,17 @@ +{* + * $id$ + *} + +program EasyPath; + +uses + Forms, + Main in 'Main.pas' {Main_FRM}; + +{$R *.RES} + +begin + Application.Initialize; + Application.CreateForm(TMain_FRM, Main_FRM); + Application.Run; +end. diff --git a/harbour/contrib/delphi/hbdll/errorsys.prg b/harbour/contrib/delphi/hbdll/errorsys.prg new file mode 100644 index 0000000000..361a2961d8 --- /dev/null +++ b/harbour/contrib/delphi/hbdll/errorsys.prg @@ -0,0 +1,204 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * The default error handler + * + * Copyright 1999 Antonio Linares + * 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 "common.ch" +#include "error.ch" + +PROCEDURE ErrorSys + + ErrorBlock( { | oError | DefError( oError ) } ) + + RETURN + +STATIC FUNCTION DefError( oError ) + LOCAL cMessage + LOCAL cDOSError + + LOCAL aOptions + LOCAL nChoice + + LOCAL n + + // By default, division by zero results in zero + IF oError:genCode == EG_ZERODIV + RETURN 0 + ENDIF + + // Set NetErr() of there was a database open error + IF oError:genCode == EG_OPEN .AND. ; + oError:osCode == 32 .AND. ; + oError:canDefault + NetErr( .T. ) + RETURN .F. + ENDIF + + // Set NetErr() if there was a lock error on dbAppend() + IF oError:genCode == EG_APPENDLOCK .AND. ; + oError:canDefault + NetErr( .T. ) + RETURN .F. + ENDIF + + cMessage := ErrorMessage( oError )+Chr(13) + IF ! Empty( oError:osCode ) + cDOSError := "(DOS Error " + LTrim( Str( oError:osCode ) ) + ")" + ENDIF + + /* RETRY OPTIONS NOT AVAILABLE RIGHT NOW + COMMENTED OUT ONLY FOR DELPHI INTEGRATION + + // Build buttons + + aOptions := {} + +// AAdd( aOptions, "Break" ) + AAdd( aOptions, "Quit" ) + + IF oError:canRetry + AAdd( aOptions, "Retry" ) + ENDIF + + IF oError:canDefault + AAdd( aOptions, "Default" ) + ENDIF + + // Show alert box + + nChoice := 0 + WHILE nChoice == 0 + + IF Empty( oError:osCode ) + + nChoice := Alert( cMessage, aOptions ) + ELSE + nChoice := Alert( cMessage + ";" + cDOSError, aOptions) + ENDIF + + ENDDO + + IF ! Empty( nChoice ) + DO CASE + CASE aOptions[ nChoice ] == "Break" + Break( oError ) + CASE aOptions[ nChoice ] == "Retry" + RETURN .T. + CASE aOptions[ nChoice ] == "Default" + RETURN .F. + ENDCASE + ENDIF + + */ + + // "Quit" selected + + IF ! Empty( oError:osCode ) + cMessage += " " + cDOSError+Chr(13) + ENDIF + + // QOut() /// dgh - Temporary to keep DOS prompt from overwriting message. + // QOut( cMessage ) + + n := 2 + WHILE ! Empty( ProcName( n ) ) + /* CHANGED */ + cMessage += "Called from " + ProcName( n ) + ; + "(" + AllTrim( Str( ProcLine( n++ ) ) ) + ")"+Chr(13) + + // QOut("Called from " + ProcName( n ) + ; + // "(" + AllTrim( Str( ProcLine( n++ ) ) ) + ")") + ENDDO + + MSGBOX( cMessage ) // Windows MessageBox + +/// For some strange reason, the DOS prompt gets written on the first line +/// *of* the message instead of on the first line *after* the message after +/// the program quits, unless the screen has scrolled. - dgh + QUIT + + RETURN .F. + +// [vszakats] + +STATIC FUNCTION ErrorMessage( oError ) + LOCAL cMessage + + // start error message + cMessage := iif( oError:severity > ES_WARNING, "Error", "Warning" ) + " " + + // add subsystem name if available + IF ISCHARACTER( oError:subsystem ) + cMessage += oError:subsystem() + ELSE + cMessage += "???" + ENDIF + + // add subsystem's error code if available + IF ISNUMBER( oError:subCode ) + cMessage += "/" + LTrim( Str( oError:subCode ) ) + ELSE + cMessage += "/???" + ENDIF + + // add error description if available + IF ISCHARACTER( oError:description ) + cMessage += " " + oError:description + ENDIF + + // add either filename or operation + DO CASE + CASE !Empty( oError:filename ) + cMessage += ": " + oError:filename + CASE !Empty( oError:operation ) + cMessage += ": " + oError:operation + ENDCASE + + RETURN cMessage diff --git a/harbour/contrib/delphi/hbdll/macrcall.c b/harbour/contrib/delphi/hbdll/macrcall.c new file mode 100644 index 0000000000..4bd744ac1b --- /dev/null +++ b/harbour/contrib/delphi/hbdll/macrcall.c @@ -0,0 +1,128 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * + * Macro processing requested from Delphi and setting callbacks + * to interact with Delphi + * + * Copyright 2002 Jorge A. Giraldo S. + * + * 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. + * + */ + +#define HB_OS_WIN_32_USED + +#include "hbvm.h" +#include "hbapiitm.h" +#include "hbstack.h" + +#if defined(HB_OS_WIN_32) + +// Function pointer type +typedef long (__stdcall *CallBackFuncType)(const char* message); + +// Setter function +HB_EXPORT __stdcall void SetCallBack(CallBackFuncType fun); + +char * HB_EXPORT __stdcall MacroCall( char * sParam ) +{ + char *szFunc = "MacroCall"; + + PHB_DYNS pDynSym = hb_dynsymFindName( szFunc ); /* The PRG function to use */ + + if( pDynSym ) + { + + hb_vmPushSymbol( pDynSym->pSymbol ); + hb_vmPushNil(); + hb_vmPushString( sParam, strlen( sParam ) ); + + hb_vmFunction( 1 ); /* as we receive one parameter */ + + return hb_stack.Return.item.asString.value; + + } + else + return "error ..."; + +} + +static CallBackFuncType cbfun = 0; +void __stdcall SetCallBack(CallBackFuncType fun) +{ + CallBackFuncType oldfun = cbfun; + cbfun = fun; + return oldfun; +} + +HB_FUNC( CALLBACK ) +{ + long result = 0; + + if (cbfun != 0) + { + + result = cbfun( hb_parc( 1 ) ); + } + else + { + MessageBox( NULL, //HWINDOW of the window that owns the message box + "CallBack failed under MacrCall.c" , //Text + "Warning" ,//Title + MB_OK | MB_ICONINFORMATION );//Bit mask flags + } + + hb_retl( result ); // QUESTION: If you can make this to return a char pointer + // being interpreted correctly by Delphi, + // please inform me, I'm all ears, thank you. +} + +HB_FUNC( MSGBOX ) + { + MessageBox( 0, hb_parc( 1 ), "Warning", 0 ); + } + +#endif diff --git a/harbour/contrib/delphi/hbdll/main.pas b/harbour/contrib/delphi/hbdll/main.pas new file mode 100644 index 0000000000..483ccc1f22 --- /dev/null +++ b/harbour/contrib/delphi/hbdll/main.pas @@ -0,0 +1,150 @@ +{* + * $id$ + *} + +{* + * Harbour Project source code: + * + * Copyright 2002 Jorge A. Giraldo S. + * + * 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. + * + *} + +unit Main; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, Buttons, ComCtrls; + +type + TMain_FRM = class(TForm) + BitBtn1: TBitBtn; + ProgressBar1: TProgressBar; + procedure BitBtn1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + + +var + Main_FRM: TMain_FRM; + oApplication : TApplication; + +type + CallBackFuncType = function (mesg: PChar): integer; stdcall; + +procedure SetCallBack(cbfunc: CallBackFuncType); stdcall; + external 'MyProg' name 'SetCallBack'; + +function MacroCall( pParam : pchar ) : pchar; stdcall; + external 'MyProg' name 'MacroCall'; + +function h( sParam : String ) : variant; + +implementation + +{$R *.DFM} + +procedure TMain_FRM.BitBtn1Click(Sender: TObject); +begin + ProgressBar1.Position := 0; + ShowMessage( h(' MakeIndex("..\..\..\TESTS\TEST", "ZIP") ') ); + +end; + +function h( sParam : String ) : variant; +Var + sRtnVal, + sType, + sResult : String; +begin + sRtnVal := MacroCall( PChar(sParam) ); + sType := Copy(sRtnVal,1,1); + sResult := Copy(sRtnVal,2,Length(sRtnVal)-1); + + // Changes string result to the expected type + if sType = 'C' then // is character or string + result := sResult + else + if sType = 'I' then // integer + result := StrToInt(sResult) + else + if sType = 'F' then // float + result := StrToFloat(sResult) + else + if sType = 'D' then // date + result := StrToDate(sResult) + else + if sType = 'L' then // boolean + if sResult = 'True' then + result := true + else + result := false; + +end; + +function ReceiveCallBack(mesg: PChar): integer; stdcall; +const + nCallsMade : integer = 0; +begin + Main_FRM.ProgressBar1.Position := StrToInt(String(mesg)); + oApplication.ProcessMessages; + Inc(nCallsMade); + // The answer our Harbour program expects. + // Callbackresult is a Harbour Public variable + // that is requested when expecting some answer. + // h(' CallBackResult := "NOANSWER" '); + result := 0; +end; + +Initialization +begin + SetCallBack(ReceiveCallBack); + oApplication := Application; +end; + +end. diff --git a/harbour/contrib/delphi/hbdll/myprog.prg b/harbour/contrib/delphi/hbdll/myprog.prg new file mode 100644 index 0000000000..8825bb16b7 --- /dev/null +++ b/harbour/contrib/delphi/hbdll/myprog.prg @@ -0,0 +1,113 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * + * Macro processing requested from Delphi and setting callbacks + * to interact with Delphi + * + * Copyright 2002 Jorge A. Giraldo S. + * + * 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 'HbClass.ch' + +MEMVAR CallBackResult + +FUNCTION MakeIndex( cFileName, cField ) +PUBLIC CallBackResult := '' + +Use (cFileName) Alias FIL +Index on &(cField) to (cFileName) EVAL IndexStatus() EVERY LastRec()/10 +Close FIL +RETURN 'The file '+cFileName+' has been indexed' + +FUNCTION IndexStatus +LOCAL cCompleted := LTrim( Str(Int((RecNo()/LastRec()) * 100)) ), nSeconds +D(cCompleted) + +nSeconds := Seconds() // Let's make this thing to go slowly +WHILE nSeconds+1 >= Seconds() +END + +RETURN .T. + +//---------------------------------------// +// Library functions // +//---------------------------------------// + +FUNCTION D( cString ) +CallBack( cString ) +RETURN CallBackResult + +FUNCTION MacroCall( cString ) +LOCAL xMacroResult, cRtnType, cRtnVal + +cRtnType := ValType( xMacroResult := &(cString) ) + +// Well, if memory is like a string, why not to use strings +// for any type of vars?... ok, ok, I know. :-) + +Do Case +Case cRtnType = 'C' + cRtnVal := 'C'+xMacroResult +Case cRtnType = 'N' + If Int(xMacroResult) = xMacroResult + cRtnVal := 'I'+AllTrim(Str(xMacroResult,,0)) + Else + cRtnVal := 'F'+AllTrim(Str(xMacroResult)) + EndIf +Case cRtnType = 'L' + cRtnVal := 'L'+If(xMacroResult,'True','False') +Case cRtnType = 'D' + cRtnVal := 'D'+DtoC(xMacroResult) +OtherWise + cRtnVal := NIL // NOTE: If Delphi doesn't expect a result, returning any result + // will corrupt Delphi's memory. So this is set to NIL. +EndCase + +RETURN cRtnVal + diff --git a/harbour/contrib/delphi/hbdll/start.bat b/harbour/contrib/delphi/hbdll/start.bat new file mode 100644 index 0000000000..cde81fc3de --- /dev/null +++ b/harbour/contrib/delphi/hbdll/start.bat @@ -0,0 +1,5 @@ +rem Makes our PRG to be a DLL, from an Antonio's idea an research +rem +rem $Id$ +rem +Call bld_sdll myprog