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

{
    *********************************************************************
    $Id$
    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 IID: TGUID; out Intf): Boolean;
begin
  Result:=(Instance<>nil) and
          (Instance.QueryInterface(IID,Intf)=0);
end;

function Supports(const Instance: TObject; const IID: TGUID; out Intf): Boolean;
var
  LUnknown: IUnknown;
begin
  Result:=(Instance<>nil) and
          ((Instance.GetInterface(IUnknown,LUnknown) and
            Supports(LUnknown,IID,Intf)) or
           Instance.GetInterface(IID,Intf));
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 AClass: TClass; const IID: TGUID): Boolean;
begin
  Result:=AClass.GetInterfaceEntry(IID)<>nil;
end;


function StringToGUID(const S: string): TGUID;

  function HexChar(c: Char): Byte;
  begin
    case c of
      '0'..'9':
        Result:=Byte(c) - Byte('0');
      'a'..'f':
        Result:=(Byte(c) - Byte('a')) + 10;
      'A'..'F':
        Result:=(Byte(c) - Byte('A')) + 10;
      else
        raise EConvertError.CreateFmt(SInvalidGUID, [s]);
        Result:=0;
    end;
  end;

  function HexByte(p: PChar): Char;
  begin
    Result:=Char((HexChar(p[0]) shl 4) + HexChar(p[1]));
  end;

var
  i: integer;
  src, dest: PChar;
begin
  if ((Length(S)<>38) or
      (s[1]<>'{')) then
    raise EConvertError.CreateFmt(SInvalidGUID, [s]);
  dest:=@Result;
  src:=PChar(s);
  inc(src);
  for i:=0 to 3 do
    dest[i]:=HexByte(src+(3-i)*2);
  inc(src, 8);
  inc(dest, 4);
  if src[0]<>'-' then
    raise EConvertError.CreateFmt(SInvalidGUID, [s]);
  inc(src);
  for i:=0 to 1 do
   begin
     dest^:=HexByte(src+2);
     inc(dest);
     dest^:=HexByte(src);
     inc(dest);
     inc(src, 4);
     if src[0]<>'-' then
       raise EConvertError.CreateFmt(SInvalidGUID, [s]);
     inc(src);
   end;
  dest^:=HexByte(src);
  inc(dest);
  inc(src, 2);
  dest^:=HexByte(src);
  inc(dest);
  inc(src, 2);
  if src[0]<>'-' then
    raise EConvertError.CreateFmt(SInvalidGUID, [s]);
  inc(src);
  for i:=0 to 5 do
   begin
     dest^:=HexByte(src);
     inc(dest);
     inc(src, 2);
   end;
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 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;

{
  $Log$
  Revision 1.1  2003-10-06 21:01:06  peter
    * moved classes unit to rtl

  Revision 1.1  2002/01/25 17:42:03  peter
    * interface helpers

}