Delphi/pascalscript
Delphi/pascalscript
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Tweaks for d5 support from Eric Jansen eric.thuisremovethis@planet.nl

Browse Source 
git-svn-id: http://code.remobjects.com/svn/pascalscript@230 5c9d2617-0215-0410-a2ee-e80e04d1c6d8
This commit is contained in:
ck 2010-07-08 09:28:01 +00:00
parent f107c60821
commit 9675b8b9de
6 changed files with 962 additions and 959 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
Source/PascalScript_Core_D5.dpk
View File

@ -1,7 +1,7 @@
package PascalScript_Core_D5; package PascalScript_Core_D5;
{$R *.res} {$R *.res}
{$ALIGN 8} {$ALIGN ON}
{$ASSERTIONS ON} {$ASSERTIONS ON}
{$BOOLEVAL OFF} {$BOOLEVAL OFF}
{$DEBUGINFO ON} {$DEBUGINFO ON}
@ -27,9 +27,8 @@ package PascalScript_Core_D5;
{$IMPLICITBUILD OFF} {$IMPLICITBUILD OFF}
requires requires
rtl, vcl50,
vcl, vcldb50;
dbrtl;
contains contains
uPSC_extctrls in 'uPSC_extctrls.pas', uPSC_extctrls in 'uPSC_extctrls.pas',

4
Source/eDefines.inc
View File

@ -147,7 +147,9 @@
{$DEFINE WIN16} {$DEFINE WIN16}
{$ENDIF} {$ENDIF}
{$ENDIF} {$ENDIF}
{$IFDEF WIN32}
{$DEFINE MSWINDOWS}
{$ENDIF}
{ defines for Delphi 1.0 thru 7.0 } { defines for Delphi 1.0 thru 7.0 }
{$IFDEF MSWINDOWS} {$IFDEF MSWINDOWS}

2
Source/uPSCompiler.pas
View File

@ -1720,7 +1720,7 @@ procedure DisposeVariant(p: PIfRVariant);
implementation implementation
uses Classes, typInfo; uses {$IFDEF DELPHI5}ComObj, {$ENDIF}Classes, typInfo;
{$IFDEF DELPHI3UP} {$IFDEF DELPHI3UP}
resourceString resourceString

566
Source/uPSR_dll.pas
View File

@ -1,283 +1,283 @@
unit uPSR_dll; unit uPSR_dll;
{$I PascalScript.inc} {$I PascalScript.inc}
interface interface
uses uses
uPSRuntime, uPSUtils; uPSRuntime, uPSUtils;
procedure RegisterDLLRuntime(Caller: TPSExec); procedure RegisterDLLRuntime(Caller: TPSExec);
procedure RegisterDLLRuntimeEx(Caller: TPSExec; AddDllProcImport: Boolean); procedure RegisterDLLRuntimeEx(Caller: TPSExec; AddDllProcImport: Boolean);
function ProcessDllImport(Caller: TPSExec; P: TPSExternalProcRec): Boolean; function ProcessDllImport(Caller: TPSExec; P: TPSExternalProcRec): Boolean;
function ProcessDllImportEx(Caller: TPSExec; P: TPSExternalProcRec; ForceDelayLoad: Boolean): Boolean; function ProcessDllImportEx(Caller: TPSExec; P: TPSExternalProcRec; ForceDelayLoad: Boolean): Boolean;
function UnloadProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; function UnloadProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
implementation implementation
uses uses
{$IFDEF UNIX} {$IFDEF UNIX}
Unix, baseunix, dynlibs, termio, sockets; Unix, baseunix, dynlibs, termio, sockets;
{$ELSE} {$ELSE}
Windows; Windows;
{$ENDIF} {$ENDIF}
{ {
p^.Ext1 contains the pointer to the Proc function p^.Ext1 contains the pointer to the Proc function
p^.ExportDecl: p^.ExportDecl:
'dll:'+DllName+#0+FunctionName+#0+chr(Cc)+Chr(DelayLoad)+Chr(AlternateSearchPath)+VarParams 'dll:'+DllName+#0+FunctionName+#0+chr(Cc)+Chr(DelayLoad)+Chr(AlternateSearchPath)+VarParams
} }
type type
PLoadedDll = ^TLoadedDll; PLoadedDll = ^TLoadedDll;
TLoadedDll = record TLoadedDll = record
dllnamehash: Longint; dllnamehash: Longint;
dllname: tbtstring; dllname: tbtstring;
dllhandle: THandle; dllhandle: THandle;
end; end;
TMyExec = class(TPSExec); TMyExec = class(TPSExec);
PInteger = ^Integer; PInteger = ^Integer;
procedure LAstErrorFree(Sender: TPSExec; P: PInteger); procedure LAstErrorFree(Sender: TPSExec; P: PInteger);
begin begin
dispose(p); dispose(p);
end; end;
procedure DLLSetLastError(Sender: TPSExec; P: Integer); procedure DLLSetLastError(Sender: TPSExec; P: Integer);
var var
pz: PInteger; pz: PInteger;
begin begin
pz := Sender.FindProcResource(@LastErrorFree); pz := Sender.FindProcResource(@LastErrorFree);
if pz = nil then if pz = nil then
begin begin
new(pz); new(pz);
Sender.AddResource(@LastErrorFree, PZ); Sender.AddResource(@LastErrorFree, PZ);
end; end;
pz^ := p; pz^ := p;
end; end;
function DLLGetLastError(Sender: TPSExec): Integer; function DLLGetLastError(Sender: TPSExec): Integer;
var var
pz: PInteger; pz: PInteger;
begin begin
pz := Sender.FindProcResource(@LastErrorFree); pz := Sender.FindProcResource(@LastErrorFree);
if pz = nil then if pz = nil then
result := 0 result := 0
else else
result := pz^; result := pz^;
end; end;
procedure DllFree(Sender: TPSExec; P: PLoadedDll); procedure DllFree(Sender: TPSExec; P: PLoadedDll);
begin begin
FreeLibrary(p^.dllhandle); FreeLibrary(p^.dllhandle);
Dispose(p); Dispose(p);
end; end;
function LoadDll(Caller: TPSExec; P: TPSExternalProcRec): Boolean; function LoadDll(Caller: TPSExec; P: TPSExternalProcRec): Boolean;
var var
s, s2, s3: tbtstring; s, s2, s3: tbtstring;
h, i: Longint; h, i: Longint;
ph: PLoadedDll; ph: PLoadedDll;
dllhandle: THandle; dllhandle: THandle;
loadwithalteredsearchpath: Boolean; loadwithalteredsearchpath: Boolean;
begin begin
s := p.Decl; s := p.Decl;
Delete(s, 1, 4); Delete(s, 1, 4);
s2 := copy(s, 1, pos(tbtchar(#0), s)-1); s2 := copy(s, 1, pos(tbtchar(#0), s)-1);
delete(s, 1, length(s2)+1); delete(s, 1, length(s2)+1);
h := makehash(s2); h := makehash(s2);
s3 := copy(s, 1, pos(tbtchar(#0), s)-1); s3 := copy(s, 1, pos(tbtchar(#0), s)-1);
delete(s, 1, length(s3)+1); delete(s, 1, length(s3)+1);
loadwithalteredsearchpath := bytebool(s[3]); loadwithalteredsearchpath := bytebool(s[3]);
i := 2147483647; // maxint i := 2147483647; // maxint
dllhandle := 0; dllhandle := 0;
repeat repeat
ph := Caller.FindProcResource2(@dllFree, i); ph := Caller.FindProcResource2(@dllFree, i);
if (ph = nil) then if (ph = nil) then
begin begin
if s2 = '' then if s2 = '' then
begin begin
// don't pass an empty filename to LoadLibrary, just treat it as uncallable // don't pass an empty filename to LoadLibrary, just treat it as uncallable
p.Ext2 := Pointer(1); p.Ext2 := Pointer(1);
Result := False; Result := False;
exit; exit;
end; end;
{$IFDEF UNIX} {$IFDEF UNIX}
dllhandle := LoadLibrary(PChar(s2)); dllhandle := LoadLibrary(PChar(s2));
{$ELSE} {$ELSE}
if loadwithalteredsearchpath then if loadwithalteredsearchpath then
dllhandle := LoadLibraryExA(PAnsiChar(AnsiString(s2)), 0, LOAD_WITH_ALTERED_SEARCH_PATH) dllhandle := LoadLibraryExA(PAnsiChar(AnsiString(s2)), 0, LOAD_WITH_ALTERED_SEARCH_PATH)
else else
dllhandle := LoadLibraryA(PAnsiChar(AnsiString(s2))); dllhandle := LoadLibraryA(PAnsiChar(AnsiString(s2)));
{$ENDIF} {$ENDIF}
if dllhandle = 0 then if dllhandle = 0 then
begin begin
p.Ext2 := Pointer(1); p.Ext2 := Pointer(1);
Result := False; Result := False;
exit; exit;
end; end;
new(ph); new(ph);
ph^.dllnamehash := h; ph^.dllnamehash := h;
ph^.dllname := s2; ph^.dllname := s2;
ph^.dllhandle := dllhandle; ph^.dllhandle := dllhandle;
Caller.AddResource(@DllFree, ph); Caller.AddResource(@DllFree, ph);
end; end;
if (ph^.dllnamehash = h) and (ph^.dllname = s2) then if (ph^.dllnamehash = h) and (ph^.dllname = s2) then
begin begin
dllhandle := ph^.dllhandle; dllhandle := ph^.dllhandle;
end; end;
until dllhandle <> 0; until dllhandle <> 0;
p.Ext1 := GetProcAddress(dllhandle, pansichar(s3)); p.Ext1 := GetProcAddress(dllhandle, pansichar(s3));
if p.Ext1 = nil then if p.Ext1 = nil then
begin begin
p.Ext2 := Pointer(1); p.Ext2 := Pointer(1);
Result := false; Result := false;
exit; exit;
end; end;
Result := True; Result := True;
end; end;
function DllProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; function DllProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
var var
i: Longint; i: Longint;
MyList: TIfList; MyList: TIfList;
n: PPSVariantIFC; n: PPSVariantIFC;
CurrStack: Cardinal; CurrStack: Cardinal;
cc: TPSCallingConvention; cc: TPSCallingConvention;
s: tbtstring; s: tbtstring;
begin begin
if p.Ext2 <> nil then // error if p.Ext2 <> nil then // error
begin begin
Result := false; Result := false;
exit; exit;
end; end;
if p.Ext1 = nil then if p.Ext1 = nil then
begin begin
if not LoadDll(Caller, P) then if not LoadDll(Caller, P) then
begin begin
Result := false; Result := false;
exit; exit;
end; end;
end; end;
s := p.Decl; s := p.Decl;
delete(S, 1, pos(tbtchar(#0), s)); delete(S, 1, pos(tbtchar(#0), s));
delete(S, 1, pos(tbtchar(#0), s)); delete(S, 1, pos(tbtchar(#0), s));
if length(S) < 2 then if length(S) < 2 then
begin begin
Result := False; Result := False;
exit; exit;
end; end;
cc := TPSCallingConvention(s[1]); cc := TPSCallingConvention(s[1]);
delete(s, 1, 3); // cc + delayload + alternatesearchpath (delayload might also be forced!) delete(s, 1, 3); // cc + delayload + alternatesearchpath (delayload might also be forced!)
CurrStack := Cardinal(Stack.Count) - Cardinal(length(s)); CurrStack := Cardinal(Stack.Count) - Cardinal(length(s));
if s[1] = #0 then inc(CurrStack); if s[1] = #0 then inc(CurrStack);
MyList := tIfList.Create; MyList := tIfList.Create;
for i := 2 to length(s) do for i := 2 to length(s) do
begin begin
MyList.Add(nil); MyList.Add(nil);
end; end;
for i := length(s) downto 2 do for i := length(s) downto 2 do
begin begin
MyList[i - 2] := NewPPSVariantIFC(Stack[CurrStack], s[i] <> #0); MyList[i - 2] := NewPPSVariantIFC(Stack[CurrStack], s[i] <> #0);
inc(CurrStack); inc(CurrStack);
end; end;
if s[1] <> #0 then if s[1] <> #0 then
begin begin
n := NewPPSVariantIFC(Stack[CurrStack], true); n := NewPPSVariantIFC(Stack[CurrStack], true);
end else n := nil; end else n := nil;
try try
TMYExec(Caller).InnerfuseCall(nil, p.Ext1, cc, MyList, n); TMYExec(Caller).InnerfuseCall(nil, p.Ext1, cc, MyList, n);
{$IFNDEF UNIX} {$IFNDEF UNIX}
DLLSetLastError(Caller, GetLastError); DLLSetLastError(Caller, GetLastError);
{$ENDIF} {$ENDIF}
finally finally
DisposePPSvariantIFC(n); DisposePPSvariantIFC(n);
DisposePPSVariantIFCList(MyList); DisposePPSVariantIFCList(MyList);
end; end;
result := true; result := true;
end; end;
function ProcessDllImport(Caller: TPSExec; P: TPSExternalProcRec): Boolean; function ProcessDllImport(Caller: TPSExec; P: TPSExternalProcRec): Boolean;
begin begin
Result := ProcessDllImportEx(Caller, P, False); Result := ProcessDllImportEx(Caller, P, False);
end; end;
function ProcessDllImportEx(Caller: TPSExec; P: TPSExternalProcRec; ForceDelayLoad: Boolean): Boolean; function ProcessDllImportEx(Caller: TPSExec; P: TPSExternalProcRec; ForceDelayLoad: Boolean): Boolean;
var var
DelayLoad: Boolean; DelayLoad: Boolean;
s: tbtstring; s: tbtstring;
begin begin
if not ForceDelayLoad then begin if not ForceDelayLoad then begin
s := p.Decl; s := p.Decl;
Delete(s,1,pos(tbtchar(#0), s)); Delete(s,1,pos(tbtchar(#0), s));
Delete(s,1,pos(tbtchar(#0), s)); Delete(s,1,pos(tbtchar(#0), s));
DelayLoad := bytebool(s[2]); DelayLoad := bytebool(s[2]);
end else end else
DelayLoad := True; DelayLoad := True;
if DelayLoad then begin if DelayLoad then begin
p.ProcPtr := DllProc; p.ProcPtr := DllProc;
Result := True; Result := True;
end else begin end else begin
p.ProcPtr := DllProc; p.ProcPtr := DllProc;
Result := LoadDll(Caller, p); Result := LoadDll(Caller, p);
end; end;
end; end;
function GetLastErrorProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; function GetLastErrorProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
begin begin
Stack.SetInt(-1, DLLGetLastError(Caller)); Stack.SetInt(-1, DLLGetLastError(Caller));
Result := true; Result := true;
end; end;
function UnloadProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; function UnloadProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
var var
h, i: Longint; h, i: Longint;
pv: TPSProcRec; pv: TPSProcRec;
ph: PLoadedDll; ph: PLoadedDll;
sname, s: tbtstring; sname, s: tbtstring;
begin begin
sname := Stack.GetAnsiString(-1); sname := Stack.GetAnsiString(-1);
for i := Caller.GetProcCount -1 downto 0 do for i := Caller.GetProcCount -1 downto 0 do
begin begin
pv := Caller.GetProcNo(i); pv := Caller.GetProcNo(i);
if not (pv is TPSExternalProcRec) then continue; if not (pv is TPSExternalProcRec) then continue;
if @TPSExternalProcRec(pv).ProcPtr <> @DllProc then continue; if @TPSExternalProcRec(pv).ProcPtr <> @DllProc then continue;
s := (TPSExternalProcRec(pv).Decl); s := (TPSExternalProcRec(pv).Decl);
delete(s,1,4); delete(s,1,4);
if copy(s,1,pos(tbtchar(#0),s)-1) = sname then if copy(s,1,pos(tbtchar(#0),s)-1) = sname then
begin begin
TPSExternalProcRec(pv).Ext1 := nil; TPSExternalProcRec(pv).Ext1 := nil;
end; end;
end; end;
h := MakeHash(sname); h := MakeHash(sname);
i := 2147483647; // maxint i := 2147483647; // maxint
repeat repeat
ph := Caller.FindProcResource2(@dllFree, i); ph := Caller.FindProcResource2(@dllFree, i);
if (ph = nil) then break; if (ph = nil) then break;
if (ph.dllnamehash = h) and (ph.dllname = sname) then if (ph.dllnamehash = h) and (ph.dllname = sname) then
begin begin
FreeLibrary(ph^.dllhandle); FreeLibrary(ph^.dllhandle);
Caller.DeleteResource(ph); Caller.DeleteResource(ph);
dispose(ph); dispose(ph);
end; end;
until false; until false;
result := true; result := true;
end; end;
procedure RegisterDLLRuntime(Caller: TPSExec); procedure RegisterDLLRuntime(Caller: TPSExec);
begin begin
RegisterDLLRuntimeEx(Caller, True); RegisterDLLRuntimeEx(Caller, True);
end; end;
procedure RegisterDLLRuntimeEx(Caller: TPSExec; AddDllProcImport: Boolean); procedure RegisterDLLRuntimeEx(Caller: TPSExec; AddDllProcImport: Boolean);
begin begin
if AddDllProcImport then if AddDllProcImport then
Caller.AddSpecialProcImport('dll', @ProcessDllImport, nil); Caller.AddSpecialProcImport('dll', @ProcessDllImport, nil);
Caller.RegisterFunctionName('UNLOADDLL', UnloadProc, nil, nil); Caller.RegisterFunctionName('UNLOADDLL', UnloadProc, nil, nil);
Caller.RegisterFunctionName('DLLGETLASTERROR', GetLastErrorProc, nil, nil); Caller.RegisterFunctionName('DLLGETLASTERROR', GetLastErrorProc, nil, nil);
end; end;
end. end.

8
Source/uPSRuntime.pas
View File

@ -9195,7 +9195,7 @@ begin
else Result:=false; else Result:=false;
end; end;
end; end;
{$IFNDEF DELPHI6UP}
function _VarArrayGet(var S : Variant; I : Integer) : Variant; function _VarArrayGet(var S : Variant; I : Integer) : Variant;
begin begin
result := VarArrayGet(S, [I]); result := VarArrayGet(S, [I]);
@ -9205,7 +9205,7 @@ procedure _VarArraySet(const c : Variant; I : Integer; var s : Variant);
begin begin
VarArrayPut(s, c, [i]); VarArrayPut(s, c, [i]);
end; end;
{$ENDIF}
procedure TPSExec.RegisterStandardProcs; procedure TPSExec.RegisterStandardProcs;
begin begin
@ -9282,10 +9282,12 @@ begin
{$IFNDEF PS_NOWIDESTRING} {$IFNDEF PS_NOWIDESTRING}
RegisterFunctionName('WSTRGET', DefProc, Pointer(42), nil); RegisterFunctionName('WSTRGET', DefProc, Pointer(42), nil);
RegisterFunctionName('WSTRSET', DefProc, Pointer(43), nil); RegisterFunctionName('WSTRSET', DefProc, Pointer(43), nil);
{$ENDIF} {$ENDIF}
{$IFNDEF DELPHI6UP}
RegisterDelphiFunction(@_VarArrayGet, 'VARARRAYGET', cdRegister); RegisterDelphiFunction(@_VarArrayGet, 'VARARRAYGET', cdRegister);
RegisterDelphiFunction(@_VarArraySet, 'VARARRAYSET', cdRegister); RegisterDelphiFunction(@_VarArraySet, 'VARARRAYSET', cdRegister);
{$ENDIF}
RegisterInterfaceLibraryRuntime(Self); RegisterInterfaceLibraryRuntime(Self);
end; end;

1334
Source/x64.inc
View File

File diff suppressed because it is too large Load Diff