{
@abstract(Runtime Interface support)
@author(Carlo Kok <ck@carlo-kok.com>)
}
unit ifpiinterfacer;

interface
uses
  ifps3, ifps3utl, SysUtils{$IFNDEF D6PLUS}, ComObj{$ENDIF};
{Register the interface library to the script engine} 
procedure RegisterInterfaceLibrary(SE: TIFPSExec);
{Set a variant to an interface}
procedure SetVariantToInterface(fVar: PIFVariant; const Intf: IUnknown);

implementation

{

  intf:-   <- set nil
  intf:*   <- compare
  intf:+guidtostring(...)  <- cast
  intf:.+Longint(ProcOffset)+chr(ord(callingconv))+callinfo_like_delphi_call_library
}

type
  TMyExec = class(TIFPSExec);

function IntfFreeProc(FMode: TVRFMode; P, IntoP: PIFVariant): Boolean;
begin
  case FMode of
    vrfFree:
      begin
        IUnknown(p.tResourceP1) := nil;
        Result := True;
      end;
    vrfDuplicate:
      begin
        if @intop^.FType.ResFree <> nil then
          intop^.FType.ResFree(vrfFree, IntoP, nil);
        if @intop^.FType.ResFree = @IntfFreeProc then
        begin
          IUnknown(intop.tResourceP1) := IUnknown(P.tresourceP1);
          Result := True;
        end else Result := False;
      end;
  else
    Result := False;
  end;
end;

function IntfCastProc(Caller: TIFPSExec; p: PIFProcRec; Global, Stack: TIfList): Boolean;
var
  TypeNo, InVar, ResVar: PIFVariant;
  GUID: TGUID;
  temp: IUnknown;
begin
  TypeNo := rp(Stack[Stack.Count-3]);
  InVar := rp(Stack[Stack.Count-2]);
  ResVar := rp(Stack[Stack.Count-1]);
  if (TypeNo = nil) or (InVar = nil) or (ResVar = nil) or (InVar^.FType^.BaseType <> btResourcePointer) or (ResVar^.FType^.BaseType <> btResourcePointer) or (TypeNo^.FType^.BaseType <> btu32) or (@invar^.FType.ResFree <> @intffreeproc) then
  begin
    Result := False;
    Exit;
  end;
  if InVar^.tResourceP1 = nil then
  begin
    if @ResVar^.FType.ResFree <> nil then
      resvar^.FType.ResFree(vrfFree, Resvar, nil);
    ResVar^.tResourceP1 := nil;
    result := True;
    exit;
  end;
  try
    guid := StringToGUID(p.ExportDecl);
  except
    Result := False;
    exit;
  end;
  if IUnknown(invar.tResourceP1).QueryInterface(GUID, Temp) <> 0 then
  begin
    Caller.CMD_Err2(erCustomError, 'Cannot cast interface');
    Result := False;
    exit;
  end;
  resvar.tResourceP1 := pointer(temp);
  result := True;
end;

function IntfCompareProc(Caller: TIFPSExec; p: PIFProcRec; Global, Stack: TIfList): Boolean;
var
  p1, p2, pres: PIFVariant;
begin
  p1 := rp(Stack[Stack.Count -3]);
  p2 := rp(Stack[Stack.Count -2]);
  pres := rp(Stack[Stack.Count -1]);
  if (p1=nil) or (p2=nil) or (pres = nil) or (p1^.FType^.BaseType <> btResourcePointer) or (p2^.FType^.BaseType <> btResourcePointer) or (pres^.FType^.BaseType <> btu8) then
  begin
    Result := False;
    exit;
  end;
  if (p1^.tResourceP1 = p2^.tResourceP1) and (@p1^.FType.ResFree = @p2^.FType.ResFree) then
    pres^.tu32 := 1
  else
    pres^.tu32 := 0;
  Result := True;
end;

function IntfNilProc(Caller: TIFPSExec; p: PIFProcRec; Global, Stack: TIfList): Boolean;
var
  n: PIFVariant;
begin
  n := rp(Stack[Stack.Count-1]);
  if (n = nil) or (n^.FType^.BaseType <> btResourcePointer) then
  begin
    Result := False;
    Exit;
  end;
  if @N^.FType.ResFree <> nil then
    n^.FType.ResFree(vrfFree, n, nil);
  n^.tResourceP1 := nil;
  result := True;
end;


function IntfCallProc(Caller: TIFPSExec; p: PIFProcRec; Global, Stack: TIfList): Boolean;
var
  i: Integer;
  MyList: TIfList;
  n: PIFVariant;
  FSelf: Pointer;
  CurrStack: Cardinal;
  cc: TIFPSCallingConvention;
  s: string;
begin
  s := p^.ExportDecl;
  if length(S) < 2 then
  begin
    Result := False;
    exit;
  end;
  cc := TIFPSCallingConvention(s[1]);
  delete(s, 1, 1);
  if s[1] = #0 then
    n := rp(Stack[Stack.Count -1])
  else
    n := rp(Stack[Stack.Count -2]);
  if (n = nil) or (n^.Ftype^.BaseType <> btResourcePointer) or (@n^.FType.ResFree <> @IntfFreeProc) or (n^.tresourcep1 = nil) then
  begin
    result := false;
    exit;
  end;
  FSelf := n^.tResourceP1;
  CurrStack := Stack.Count - Cardinal(length(s)) -1;
  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
    n :=rp(Stack[CurrStack]);
    if s[i] <> #0 then
    begin
      n^.RefCount := n^.RefCount or IFPSAddrStackStart;
    end;
    MyList[i - 2] := n;
    inc(CurrStack);
  end;
  try
    if s[1] <> #0 then
    begin
      n := rp(Stack[CurrStack + 1]);
    end else n := nil;
    TMyExec(Caller).InnerfuseCall(FSelf, Pointer(Pointer(Cardinal(FSelf^) + (Cardinal(p^.Ext1) * Sizeof(Pointer)))^), cc, MyList, n);
    result := true;
  except
    result := false;
  end;
  MyList.Free;
end;


function InterfaceProc(Sender: TIFPSExec; p: PIFProcRec; Tag: Pointer): Boolean;
var
  s: string;
begin
  s := p.ExportDecl;
  delete(s,1,5); // delete 'intf:'
  if s = '' then
  begin
    Result := False;
    exit;
  end;
  if s[1] = '-' then
  begin
    P.ProcPtr := IntfNilProc;
    Result := True;
  end else
  if s[1] = '*' then
  begin
    P.ProcPtr := IntfCompareProc;
    Result := True;
  end else
  if s[1] = '+' then
  begin
    P.ProcPtr := IntfCastProc;
    Result := True;
  end else if s[1] = '.'then
  begin
    Delete(s,1,1);
    if length(S) < 6 then
    begin
      Result := False;
      exit;
    end;
    p.ProcPtr := IntfCallProc;
    p.Ext1 := Pointer((@s[1])^); // Proc Offset
    Delete(s,1,4);
    P.ExportDecl := s;
    Result := True;
  end else Result := False;
end;

function ResourcePtrToStr(PSelf: PResourcePtrSupportFuncs; Sender: TIFPSExec; P: PIFVariant): string;
begin
  SetLength(Result, 4);
  Pointer((@Result[1])^) := P^.tResourceP1;
end;

function VarResourcePtrToStr(PSelf: PResourcePtrSupportFuncs; Sender: TIFPSExec; P: PIFVariant): string;
begin
  SetLength(Result, 4);
  Pointer((@Result[1])^) := @P^.tResourceP1;
end;

procedure ResultToResourcePtr(PSelf: PResourcePtrSupportFuncs; Sender: TIFPSExec; Data: Longint; P: PIFVariant);
begin
  if Data = 0 then
  begin
    p^.tResourceP1 := nil;
  end else
  begin
    p^.FType.ResFree := Pointer(Data);
    p^.FType.ResFree := IntfFreeProc;
  end;
end;


function ProcPtrToStr(PSelf: PResourcePtrSupportFuncs; Sender: TIFPSExec; P: PIFVariant): string;
begin
  Setlength(Result, 8);
  TMethod((@Result[1])^) := MKMethod(Sender, P^.tu32);
end;

function ProcSupports(PSet: PResourcePtrSupportFuncs; P: PIFVariant): Boolean;
begin
  Result := (p.FType.BaseType = btResourcePointer) and (@p^.FType.ResFree = @IntfFreeProc);
end;

const
  ResourcePtrSupport: TResourcePtrSupportFuncs = (
    ptr: nil;
    PtrToStr: ResourcePtrToStr;
    VarPtrToStr: VarResourcePtrToStr;
    ResultMethod: rmParam;
    ResToPtr: ResultToResourcePtr;
    ProcPtrToStr: ProcPtrToStr;
    PtrSupports: ProcSupports);


procedure RegisterInterfaceLibrary(SE: TIFPSExec);
begin
  SE.AddSpecialProcImport('intf', InterfaceProc, nil);
  Se.RegisterRProcSupFuncs(@ResourcePtrSupport);
  se.RegisterResourceType('Interface', IntfFreeProc);
end;

procedure SetVariantToInterface(fVar: PIFVariant; const Intf: IUnknown);
begin
  if fvar <> nil then
  begin
    if (@fvar^.FType.ResFree <> nil) then
      fvar^.FType.ResFree(vrfFree, fvar, nil);
    IUnknown(fvar^.tResourceP1) := IUnknown(Intf);
  end;
end;

end.
