home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 September / Chip_2001-09_cd1.bin / zkuste / delphi / kompon / d23456 / CAJSCRPT.ZIP / ifpasscript / libraries / call / ifpsdll2.pas < prev   
Pascal/Delphi Source File  |  2001-06-08  |  4KB  |  148 lines
  1. unit ifpsdll2;
  2.  
  3. interface
  4. uses
  5.   ifpscall, ifspas, ifs_var, ifs_utl, {$IFDEF LINUX}libc{$ELSE}Windows{$ENDIF};
  6.  
  7. function DllExternalProc(id: Pointer; Sender: TIFPasScript; const Param, FuncName: string; Func: PProcedure): Boolean;
  8. {
  9.   Use this as the OnExternal Handler to make 'External' work.
  10.   
  11.   syntax:
  12.     procedure MyCall; external 'mydll.dll' name 'MyCall StdCall';
  13. }
  14.  
  15. procedure RegisterDll2library(Sender: TIfPasScript);
  16. {
  17.   Register PChar type.
  18.  
  19. }
  20. implementation
  21.  
  22. type
  23.   PMyDllHandle = ^TMyDllHandle;
  24.   TMyDllHandle = record
  25.     DllName: string;
  26.     {$IFDEF LINUX}
  27.     Dll: Pointer;
  28.     {$ELSE}
  29.     Dll: THandle;
  30.     {$ENDIF}
  31.   end;
  32.   PMYDll = TIFList;
  33. procedure FreeProc(id: Pointer; Data: PMyDll);
  34.   procedure FreeDll(p: PMyDllHandle);
  35.   begin
  36.     {$IFDEF LINUX}
  37.     dlclose(p^.Dll);
  38.     {$ELSE}
  39.     FreeLibrary(p^.Dll);
  40.     {$ENDIF}
  41.     Dispose(P);
  42.   end;
  43. var
  44.   i: Longint;  
  45. begin
  46.   for i := 0 to Data.Count-1 do
  47.   begin
  48.     FreeDll(Data.GetItem(I));
  49.   end;
  50. end;
  51.  
  52. function DProc(Sender: TIFPasScript; ScriptID: Pointer; Proc: PProcedure; Params: PVariableManager; res: PIfVariant): TIfPasScriptError;
  53. begin
  54.   if not InnerfuseCall(Nil, PProcedure(Proc)^._Ext, TCallingConvention(PProcedure(Proc)^._Ext2), Params, Res) then
  55.   begin
  56.     Sender.RunError2(Sender, ECustomError, 'Could not call function');
  57.     DProc := ECustomError;
  58.   end else
  59.     DPRoc := ENoError;
  60. end;
  61.  
  62.  
  63. function DllExternalProc(id: Pointer; Sender: TIFPasScript; const Param, FuncName: string; Func: PProcedure): Boolean;
  64.   function GetDllProcPtr(const FuncName: string): Pointer;
  65.   var
  66.     n: PMyDllHandle;
  67.     X: PMydll;
  68.     L: Longint;
  69.   begin
  70.     x := Sender.FindResource(@FreeProc);
  71.     if x = nil then
  72.     begin
  73.       x := TIFList.Create;
  74.       Sender.AddResource(@FreeProc, x);
  75.     end;
  76.     for L := 0 to x.Count-1 do
  77.     begin
  78.       n := x.GetItem(L);
  79.       if n^.DllName = FastUppercase(Param) then
  80.       begin
  81.         {$IFDEF LINUX}
  82.         GetDllProcPtr := dlsym(n^.Dll, Pchar(FuncName));
  83.         {$ELSE}
  84.         GetDllProcPtr:= GetProcAddress(n^.Dll, Pchar(FuncName));
  85.         {$ENDIF}
  86.         Exit;
  87.       end;
  88.     end;
  89.     New(n);
  90.     n^.DllName := FastUppercase(Param);
  91.     {$IFDEF LINUX}
  92.     n^.Dll := dlopen(PChar(Param), RTLD_LAZY);
  93.     {$ELSE}
  94.     n^.Dll := LoadLibrary(PChar(Param));
  95.     {$ENDIF}
  96.     if n^.Dll = {$IFDEF LINUX}nil{$ELSE}0{$ENDIF} then
  97.     begin
  98.       Dispose(N);
  99.       GetDllProcPtr := nil;
  100.       exit;
  101.     end;
  102.     x.Add(N);
  103.     {$IFDEF LINUX}
  104.     GetDllProcPtr := dlsym(n^.Dll, Pchar(FuncName));
  105.     {$ELSE}
  106.     GetDllProcPtr:= GetProcAddress(n^.Dll, Pchar(FuncName));
  107.     {$ENDIF}
  108.   end;
  109. var
  110.   s1, s2: string;
  111.   CC: TCallingConvention;
  112.   p: Pointer;
  113. begin
  114.   cc := ccRegister;
  115.   if pos(' ', FuncName)<>0 then
  116.   begin
  117.     s2 := FuncName;
  118.     s1 := Copy(s2, 1, pos(' ',s2)-1);
  119.     Delete(s2, 1, pos(' ', s2));
  120.     s2 := FastUpperCase(s2);
  121.     if s2 = 'STDCALL' then cc := ccStdcall else
  122.     if s2 = 'CDECL' then cc := ccCdecl else
  123.     if s2 = 'PASCAL' then cc := ccPascal;
  124.   end else s1 := FuncName;
  125.   P := GetDllProcPtr(s1);
  126.   if p = nil then
  127.   begin
  128.     DllExternalProc := False;
  129.     exit;
  130.   end;
  131.   Func^.Mode := 1;
  132.   Func^.Proc1 := @DProc;
  133.   Func^._Ext :=p;
  134.   Func^._Ext2 := Pointer(Byte(CC));
  135.   DllExternalProc := True;
  136. end;
  137.  
  138. procedure RegisterDll2library(Sender: TIfPasScript);
  139. begin
  140.   with Sender.AddTypeEx('PChar')^ do
  141.   begin
  142.     atypeid := CSV_String;
  143.     ext := pchar(1);
  144.   end;
  145. end;
  146.  
  147. end.
  148.