1
0
mirror of https://github.com/moparisthebest/Simba synced 2024-11-17 23:05:00 -05:00
Simba/Units/PascalScript/uPSR_dll.pas
2010-04-07 21:43:34 +02:00

284 lines
6.6 KiB
ObjectPascal

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