fpc/rtl/objpas/sysutils/sysuintf.inc

{
    *********************************************************************
    Copyright (C) 2002 Free Pascal Development Team

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    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.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
    *********************************************************************

    System Utilities For Free Pascal
}

function Supports(const Instance: IInterface; const AClass: TClass; out Obj): Boolean;
var
  Getter: IImplementorGetter;
begin
  if (Instance<>nil) and (Instance.QueryInterface(IImplementorGetter,Getter)=S_OK) then
  begin
    TObject(Obj) := Getter.GetObject;
    Result := Assigned(TObject(Obj)) and (TObject(Obj).InheritsFrom(AClass));
  end else
    Result := False;
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}',
    [
     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;