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