home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 December / Chip_2001-12_cd1.bin / zkuste / delphi / kompon / d23456 / CAJSCRTP.ZIP / libraries / com / ifpscom.~pas next >
Text File  |  2001-08-08  |  8KB  |  262 lines
  1. unit ifpscom;
  2. {
  3.   Innerfuse Pascal Script Com Object Library
  4.   For license see Innerfuse Pascal Script license file
  5.  
  6.   Version: 0.1 beta.
  7.  
  8. }
  9. interface
  10. uses
  11.   ifspas, ifs_utl, ifs_var, ifs_obj;
  12.  
  13.  
  14. procedure RegisterComLibrary(p: TIfPasScript);
  15. {
  16.  
  17. Type
  18.   IDispatch = (TIfComObject)
  19.  
  20. function CreateOleObject(Name: string): IDispatch;
  21.  
  22. }
  23.  
  24. implementation
  25. uses
  26.   ActiveX, ComObj, Sysutils;
  27.  
  28. type
  29.   TIfComObject = class(TIfsCustomObject)
  30.   private
  31.     FObject: IDispatch;
  32.     FObjects: TIfStringList;
  33.     procedure EnumProcs;
  34.   public
  35.     constructor Create(SE: TIfPasScript; Obj: IDispatch);
  36.     destructor Destroy; override;
  37.  
  38.     function FindProc(const Name: string): Longint; override;
  39.     function GetProcHeader(I: Longint): string; override;
  40.     function CallProc(I: Longint; Params: PVariableManager): PIFVariant; override;
  41.     function GetProcCount: Longint; override;
  42.   end;
  43.   
  44.  
  45. function ComProc(Sender: TIfPasScript; ScriptID: Pointer; Proc: PProcedure; Params: PVariableManager; res: PIfVariant): TIfPasScriptError;
  46. var
  47.   p: TIfComObject;
  48. begin
  49.   if Proc^.Name = 'CREATEOLEOBJECT' then
  50.   begin
  51.     try
  52.       p := TIfComObject.Create(Sender, CreateOleObject(GetString(VM_Get(Params, 0))));
  53.       Res.CV_ExternalObject := CreateResource(p);
  54.       ComProc := ENoError;
  55.     except
  56.       on e: Exception do
  57.       begin
  58.         Sender.RunError2(Sender, ECustomError, 'could not create ole object:'+ E.Message);
  59.         ComProc := ECustomError;
  60.       end else ComProc := ECustomError;
  61.     end;
  62.   end else
  63.     ComProc := EUnknownIdentifier;
  64. end;
  65.  
  66. function D1(ScriptEngine: TIFPasScript; Res: PIfVariant; I: IDispatch): Boolean;
  67. begin
  68.   if ChangeType(Res, ScriptEngine.GetType('IDISPATCH')) = nil then
  69.   begin
  70.     Result := False;
  71.     exit;
  72.   end;
  73.   res^.CV_ExternalObject := CreateResource(TIfComObject.Create(ScriptEngine, I));
  74.   Result := True;
  75. end;
  76.  
  77. function D2(ScriptEngine: TIFPasScript; var Res: IDispatch; I: PIfVariant): Boolean;
  78. begin
  79.   if not assigned(I^.CV_ExternalObject) or (PCreatedCustomObject(I^.CV_ExternalObject).AlreadyFreed) or (TIFsCustomObjectType(I^.VType^.Ext) <> TIfComObject) then
  80.   begin
  81.     D2 := False;
  82.     exit;
  83.   end;
  84.   Res := TIFComobject(PCreatedCustomObject(I^.CV_ExternalObject)^.P).FObject;
  85.   D2 := True;
  86. end;
  87.  
  88. procedure RegisterComLibrary(p: TIfPasScript);
  89. begin
  90.   with p.AddTypeEx('IDispatch')^ do
  91.   begin
  92.     atypeid := CSV_ExternalObject;
  93.     TIFsCustomObjectType(ext) := TIfComObject;
  94.   end;
  95.   p.AddFunction(@ComProc, 'function CreateOleObject(Name: string): IDispatch', nil);
  96.   {$IFDEF USEIDISPATCH}
  97.   IDispatchToIFVariantProc := D1;
  98.   IFVariantToIDispatchProc := D2;
  99.   {$ENDIF}
  100. end;
  101.  
  102. function TIfComObject.FindProc(const Name: string): Longint;
  103. var
  104.   s, n: string;
  105.   i: Longint;
  106. begin
  107.   s := FastUppercase(name);
  108.   for i := 0 to Longint(FObjects.Count)-1 do
  109.   begin
  110.     n := FObjects.GetItem(I);
  111.     n := copy(N, 1, pos(' ', n)-1);
  112.     if n = s then
  113.     begin
  114.       FindProc := I;
  115.       exit;
  116.     end;
  117.   end;
  118.   FindProc := -1;
  119. end;
  120.  
  121. function TIfComObject.GetProcHeader(I: Longint): string;
  122. begin
  123.   Result := FObjects.GetItem(I);
  124.   Delete(Result, 1, pos(' ', Result)); // delete the name
  125. end;
  126.  
  127. function TIfComObject.CallProc(I: Longint; Params: PVariableManager): PIFVariant;
  128. var
  129.   Name: string;
  130.   FTemp: WideString;
  131.   IL: Longint;
  132.   DispParams: TDispParams;
  133.   adispid: TDispID;
  134.   Ex: TExcepInfo;
  135.   Res: OleVariant;
  136.   r: Variant;
  137. begin
  138.   Name := FObjects.GetItem(I);
  139.   Name := Copy(Name, 1, pos(' ',Name)-1);
  140.   FTemp := Name;
  141.   if succeeded(FObject.GetIDsOfNames(GUID_NULL, @FTemp, 1, 0, @adispid)) then
  142.   begin
  143.     try
  144.       DispParams.cNamedArgs := 0;
  145.       DispParams.cArgs := VM_Count(Params);
  146.       DispParams.rgdispidNamedArgs := nil;
  147.       GetMem(DispParams.rgvarg, sizeof(TVariantArg) * DispParams.cArgs);
  148.       for il := 0 to DispParams.cArgs-1 do
  149.       begin
  150.         if not TIfPasScript(ScriptEngine).IfVariantToVariant(VM_Get(Params, DispParams.cArgs - il - 1), r) then
  151.         begin
  152.           FreeMem(DispParams.rgvarg, sizeof(TVariantArg) * DispParams.cArgs);
  153.           TIFPasScript(ScriptEngine).RunError2(ScriptEngine, ECustomError, 'could not convert parameter');
  154.           CallProc := nil;
  155.           exit;
  156.         end;
  157.         OleVariant(DispParams.rgvarg^[il]) := R;
  158.       end;
  159.       if Succeeded(FObject.Invoke(adispid, GUID_NULL, 0, DISPATCH_METHOD or DISPATCH_PROPERTYGET, DispParams, @Res, @ex, nil)) then
  160.       begin
  161.         r := Res;
  162.         Result := TIFPasScript(ScriptEngine).CreateVarType(nil);
  163.         if not TIFPasScript(ScriptEngine).VariantToIFVariant(r, result) then
  164.         begin
  165.           TIFPasScript(ScriptEngine).RunError2(ScriptEngine, ECustomError, 'could convert result');
  166.           FreeMem(DispParams.rgvarg, sizeof(TVariantArg) * DispParams.cArgs);
  167.           DestroyCajVariant(Result);
  168.           CallProc := nil;
  169.           exit;
  170.         end;
  171.       end else
  172.       begin
  173.         TIFPasScript(ScriptEngine).RunError2(ScriptEngine, ECustomError, 'failled calling ole method');
  174.         CallProc := nil;
  175.         FreeMem(DispParams.rgvarg, sizeof(TVariantArg) * DispParams.cArgs);
  176.         exit;
  177.       end;
  178.     except
  179.       TIFPasScript(ScriptEngine).RunError2(ScriptEngine, ECustomError, 'error calling ole method');
  180.       CallProc := nil;
  181.       FreeMem(DispParams.rgvarg, sizeof(TVariantArg) * DispParams.cArgs);
  182.       exit;
  183.     end;
  184.     FreeMem(DispParams.rgvarg, sizeof(TVariantArg) * DispParams.cArgs);
  185.   end else
  186.   begin
  187.     TIFPasScript(ScriptEngine).RunError2(ScriptEngine, ECustomError, 'could not find ole method');
  188.     CallProc := nil;
  189.     exit;
  190.   end;
  191. end;
  192.  
  193. function TIfComObject.GetProcCount: Longint;
  194. begin
  195.   Result := FObjects.Count;
  196. end;
  197.  
  198. constructor TIfComObject. Create(SE: TIfPasScript; Obj: IDispatch);
  199. begin
  200.   inherited Create(Se);
  201.   fObject := Obj;
  202.   FObjects := TIfStringList.Create;
  203.   EnumProcs;
  204. end;
  205.  
  206. destructor TIfComObject.Destroy;
  207. begin
  208.   FObject := nil;
  209.   FObjects.Free;
  210.   inherited Destroy;
  211. end;
  212.  
  213. procedure TIfComObject.EnumProcs;
  214. var
  215.   Count, I, I2, I3, ParamCount: Longint;
  216.   TI: ITypeInfo;
  217.   TA: PTypeAttr;
  218.   FD: PFuncDesc;
  219.   Names: PBStrList;
  220.   FF: string;
  221.   N: PTypeRec;
  222. begin
  223.   n := TIfPasScript(ScriptEngine).AddTypeEx('');
  224.   n^.atypeid := CSV_Variant;
  225.   if Succeeded(FObject.GetTypeInfoCount(Count)) then
  226.   begin
  227.     for i := 0 to Count-1 do
  228.     begin
  229.       if Succeeded(FObject.GetTypeInfo(I, 0, TI)) and Succeeded(TI.GetTypeAttr(TA)) and (TA^.typekind = TKIND_DISPATCH) then
  230.       begin
  231.         for I2 := 0 to TA^.cFuncs-1 do
  232.         begin
  233.           if succeeded(TI.GetFuncDesc(I2,FD)) then
  234.           begin
  235.             if FD.cParamsOpt = -1 then
  236.               ParamCount := Fd.cParams
  237.             else
  238.               ParamCount := fd.cParams - Fd.cParamsOpt;
  239.             GetMem(Names, Sizeof(TBStr));
  240.             if Succeeded(TI.GetNames(fd.memid, Names, 1, I3)) then
  241.             begin
  242.               FF := FastUppercase(Names^[0])+' 0';
  243.               while ParamCount > 0 do
  244.               begin
  245.                 FF := FF + ' PARAM '+ IntToStr(Longint(n));
  246.                 Dec(ParamCount);
  247.               end;
  248.             end;
  249.             FreeMem(Names, Sizeof(TBStr));
  250.             FObjects.Add(FF);
  251.             TI.ReleaseFuncDesc(FD);
  252.           end;
  253.         end;
  254.         TI.ReleaseTypeAttr(TA);
  255.       end;
  256.     end;
  257.   end;
  258. end;
  259.  
  260. end.
  261.  
  262.