freepascal.compiler/rtl/objpas/sysutils/sysuintf.inc

{
    *********************************************************************
    Copyright (C) 2002 Peter Vreman,
    member of the Free Pascal Development Team

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    *********************************************************************
}

function Supports(const Instance: IInterface; const AClass: TClass; out Obj): Boolean;
begin
  Result := (Instance<>nil) and (Instance.QueryInterface(IObjectInstance,Obj)=S_OK) and (TObject(Obj).InheritsFrom(AClass));
end;

function Supports(const Instance: IInterface; const IID: TGUID; out Intf): Boolean;
begin
  Result:=(Instance<>nil) and (Instance.QueryInterface(IID,Intf)=S_OK);
end;

function Supports(const Instance: TObject; const IID: TGUID; out Intf): Boolean;
var
  Temp: Pointer; // weak
begin
  Result:=(Instance<>nil) and ((Instance.GetInterfaceWeak(IInterface,Temp) and (IInterface(Temp).QueryInterface(IID,Intf)=S_OK))
    or Instance.GetInterface(IID,Intf));
  { Some applications expect that the QueryInterface method is invoked as first priority
    to query for an interface and GetInterface as 2nd priority }
end;

function Supports(const Instance: TObject; const IID: Shortstring; out Intf): Boolean;
begin
  Result:=(Instance<>nil) and Instance.GetInterface(IID,Intf);
end;



function Supports(const Instance: IInterface; const AClass: TClass): Boolean;
var
  Temp: TObject;
begin
  Result:=Supports(Instance,AClass,Temp);
end;

function Supports(const Instance: IInterface; const IID: TGUID): Boolean;
var
  Temp: IInterface;
begin
  Result:=Supports(Instance,IID,Temp);
end;

function Supports(const Instance: TObject; const IID: TGUID): Boolean;
var
  Temp: IInterface;
begin
  Result:=Supports(Instance,IID,Temp);
end;

function Supports(const Instance: TObject; const IID: Shortstring): Boolean;
begin
  Result:=(Instance<>nil) and (Instance.GetInterfaceEntryByStr(IID)<>nil);
end;



function Supports(const AClass: TClass; const IID: TGUID): Boolean;
begin
  Result:=(AClass<>nil) and (AClass.GetInterfaceEntry(IID)<>nil);
end;

function Supports(const AClass: TClass; const IID: Shortstring): Boolean;
begin
  Result:=(AClass<>nil) and (AClass.GetInterfaceEntryByStr(IID)<>nil);
end;



function StringToGUID(const S: string): TGUID;
begin
  if not TryStringToGUID(S, Result) then
    raise EConvertError.CreateFmt(SInvalidGUID, [S]);
end;

function TryStringToGUID(const S: string; out Guid: TGUID): Boolean;
var
  e: Boolean;
  p: PChar;

  function rb: Byte;
  begin
    case p^ of
      '0'..'9': Result := Byte(p^) - Byte('0');
      'a'..'f': Result := Byte(p^) - Byte('a') + 10;
      'A'..'F': Result := Byte(p^) - Byte('A') + 10;
      else e := False;
    end;
    Inc(p);
  end;

  procedure nextChar(c: Char); inline;
  begin
    if p^ <> c then
      e := False;
    Inc(p);
  end;

begin
  if Length(S)<>38 then Exit(False);
  e := True;
  p := PChar(S);
  nextChar('{');
  Guid.D1 := rb shl 28 or rb shl 24 or rb shl 20 or rb shl 16 or rb shl 12 or rb shl 8 or rb shl 4 or rb;
  nextChar('-');
  Guid.D2 := rb shl 12 or rb shl 8 or rb shl 4 or rb;
  nextChar('-');
  Guid.D3 := rb shl 12 or rb shl 8 or rb shl 4 or rb;
  nextChar('-');
  Guid.D4[0] := rb shl 4 or rb;
  Guid.D4[1] := rb shl 4 or rb;
  nextChar('-');
  Guid.D4[2] := rb shl 4 or rb;
  Guid.D4[3] := rb shl 4 or rb;
  Guid.D4[4] := rb shl 4 or rb;
  Guid.D4[5] := rb shl 4 or rb;
  Guid.D4[6] := rb shl 4 or rb;
  Guid.D4[7] := rb shl 4 or rb;
  nextChar('}');
  Result := e;
end;

function IsEqualGUID(const guid1, guid2: TGUID): Boolean;
var
  a1,a2: PIntegerArray;
begin
  a1:=PIntegerArray(@guid1);
  a2:=PIntegerArray(@guid2);
  Result:=(a1^[0]=a2^[0]) and
          (a1^[1]=a2^[1]) and
          (a1^[2]=a2^[2]) and
          (a1^[3]=a2^[3]);
end;

function GuidCase(const GUID: TGUID; const List: array of TGuid): Integer;
begin
  for Result := High(List) downto 0 do
    if IsEqualGUID(GUID, List[Result]) then
      Exit;
  Result := -1;
end;

function GUIDToString(const GUID: TGUID): string;
begin
  SetLength(Result, 38);
  StrLFmt(PChar(Result), 38,'{%.8x-%.4x-%.4x-%.2x%.2x-%.2x%.2x%.2x%.2x%.2x%.2x}',
    [
     Longint(GUID.D1), GUID.D2, GUID.D3,
     GUID.D4[0], GUID.D4[1], GUID.D4[2], GUID.D4[3],
     GUID.D4[4], GUID.D4[5], GUID.D4[6], GUID.D4[7]
    ]);
end;