home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 September / Chip_2001-09_cd1.bin / zkuste / delphi / kompon / d23456 / CAJSCRPT.ZIP / ifpasscript / libraries / call / ifpsdll.pas < prev    next >
Pascal/Delphi Source File  |  2001-06-08  |  5KB  |  185 lines
  1. unit ifpsdll;
  2. {
  3.   Innerfuse Pascal Script DLL Library
  4.   For license see Innerfuse Pascal Script license file
  5.  
  6.   This unit and all parts of it may only be used with Innerfuse Pascal
  7.   Script.
  8.  
  9.   Does not work in attached units.
  10. }
  11. {$I ifs_def.inc}
  12. interface
  13. uses
  14.   ifpscall, ifspas, ifs_var, ifs_utl, {$IFDEF LINUX}libc{$ELSE}Windows{$ENDIF};
  15.  
  16. procedure RegisterDllCallLibrary(Sender: TIFPasScript);
  17. {
  18. Adds:
  19.  
  20.   function LoadLibrary(Name: string; var Res: ResourcePointer): Boolean;
  21.   procedure CloseLibrary(Res: ResourcePointer);
  22.   function MapLibraryProc(RealProcName, Declaration: string): Boolean;
  23.  
  24. Valid types for in Declaration:
  25. Byte
  26. Shortint
  27. Word
  28. Smallint
  29. Longint
  30. Integer
  31. Cardinal
  32. PChar (string with EXT param of TypeRec to 1) (*)
  33. String
  34.  
  35. Valid calling conventions:
  36. register (default)
  37. stdcall
  38. cdecl
  39. pascal
  40.  
  41. Pchar type does not support Var parameter.
  42. }
  43.  
  44. implementation
  45. type
  46.   PCreatedDll = ^TCreatedDll;
  47.   TCreatedDll = record
  48.     AlreadyFreed: Boolean;
  49.     {$IFDEF LINUX}
  50.     Dll: Pointer;
  51.     {$ELSE}
  52.     Dll: THandle;
  53.     {$ENDIF}
  54.     Calls: TIFList;  { Contains PProcedure pointers. PProcedure()^.Ext contains a pointer to the procedure. }
  55.   end;
  56.  
  57. procedure FreeProc(id: Pointer; Data: PCreatedDll);
  58. begin
  59.   if not data.AlreadyFreed then
  60.   begin
  61.     Data^.Calls.Free;
  62.     {$IFDEF LINUX}
  63.     dlclose(Data^.Dll);
  64.     {$ELSE}
  65.     FreeLibrary(Data^.Dll);
  66.     {$ENDIF}
  67.   end;
  68.   Dispose(Data);
  69. end;
  70.  
  71. function DProc(Sender: TIFPasScript; ScriptID: Pointer; Proc: PProcedure; Params: PVariableManager; res: PIfVariant): TIfPasScriptError;
  72. begin
  73.   if not InnerfuseCall(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.  
  83. function MProc(Sender: TIFPasScript; ScriptID: Pointer; Proc: PProcedure; Params: PVariableManager; res: PIfVariant): TIfPasScriptError;
  84. var
  85.   n: PCreatedDll;
  86.   p: PProcedure;
  87.   I: Longint;
  88.   procedure F1;
  89.   var
  90.     FuncName, FuncParam: String;
  91.     CC: TCallingConvention;
  92.     u: Pointer;
  93.   begin
  94.     if ReadHeader(Sender, GetString(VM_Get(Params, 2)), FuncName, FuncParam, CC) then
  95.     begin
  96.       {$IFDEF LINUX}
  97.       u := dlsym(n^.Dll, PChar(GetString(VM_Get(Params, 1))));
  98.       {$ELSE}
  99.       u := GetProcAddress(n^.Dll, PChar(GetString(VM_Get(Params, 1))));
  100.       {$ENDIF}
  101.       if u <> nil then
  102.       begin
  103.         u := Sender.AddFunction(@DProc, 'procedure '+FuncName+';', U);
  104.         n^.calls.Add(U);
  105.         PProcedure(U)^.Decl := FuncParam;
  106.         PProcedure(U)^._Ext2 := Pointer(Byte(CC));
  107.         SetBoolean(Res, True);
  108.       end else
  109.         SetBoolean(Res, False);
  110.     end else
  111.       SetBoolean(Res, False);
  112.   end;
  113. begin
  114.   MProc := ENoError;
  115.   if Proc^.Name = 'LOADLIBRARY' then
  116.   begin
  117.     New(N);
  118.     {$IFDEF LINUX}
  119.     N^.Dll := dlopen(PChar(GetString(VM_Get(Params, 0))), RTLD_LAZY);
  120.     {$ELSE}
  121.     N^.Dll := LoadLibrary(PChar(GetString(VM_Get(Params, 0))));
  122.     {$ENDIF}
  123.     if N^.Dll = {$IFDEF LINUX}nil{$ELSE}0{$ENDIF} then
  124.     begin
  125.       Dispose(N);
  126.       SetBoolean(Res, False);
  127.     end else begin
  128.       N^.AlreadyFreed := False;
  129.       N^.Calls := TIFList.Create;
  130.       GetVarLink(VM_Get(Params, 1))^.Cv_Int1 := N;
  131.       GetVarLink(VM_Get(Params, 1))^.CV_Int2 := @MProc;
  132.       SetBoolean(Res, True);
  133.       Sender.AddResource(@FreeProc, N);
  134.     end;
  135.   end else if Proc^.Name = 'CLOSELIBRARY' then
  136.   begin
  137.     if GetVarLink(VM_Get(Params, 0))^.CV_Int2 <> @MProc then
  138.     begin
  139.       MPRoc := ETypeMismatch;
  140.       exit;
  141.     end;
  142.     n := GetVarLink(VM_Get(Params, 0))^.CV_Int1;
  143.     if n^.AlreadyFreed then
  144.     begin
  145.       MProc := ETypeMismatch;
  146.       exit;
  147.     end;
  148.     for i := 0 to n^.Calls.Count -1 do
  149.     begin
  150.       Sender.RemoveFunction(n^.Calls.GetItem(I));
  151.       p := N^.Calls.GetItem(I);
  152.       Dispose(P);
  153.     end;
  154.     {$IFDEF LINUX}
  155.     dlclose(N^.Dll);
  156.     {$ELSE}
  157.     FreeLibrary(N^.DLL);
  158.     {$ENDIF}
  159.     N^.AlreadyFreed := True;
  160.   end else if Proc^.Name = 'MAPLIBRARYPROC' then
  161.   begin
  162.     if GetVarLink(VM_Get(Params, 0))^.CV_Int2 <> @MProc then
  163.     begin
  164.       MPRoc := ETypeMismatch;
  165.       exit;
  166.     end;
  167.     n := GetVarLink(VM_Get(Params, 0))^.CV_Int1;
  168.     if n^.AlreadyFreed then
  169.     begin
  170.       MProc := ETypeMismatch;
  171.       exit;
  172.     end;
  173.     F1;
  174.   end;
  175. end;
  176.  
  177. procedure RegisterDllCallLibrary(Sender: TIFPasScript);
  178. begin
  179.   Sender.AddFunction(@MProc, 'function LoadLibrary(Name: string; var Res: ResourcePointer): Boolean;', nil);
  180.   Sender.AddFunction(@MProc, 'procedure CloseLibrary(Res: ResourcePointer);', nil);
  181.   Sender.AddFunction(@MProc, 'function MapLibraryProc(Res: ResourcePointer; DllProcName, Declaration: string): Boolean;', nil);
  182. end;
  183.  
  184. end.
  185.