* interface helpers

rtl/objpas/intf.inc

@@ -0,0 +1,157 @@
+{
+    *********************************************************************
+    $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  2002-01-25 17:42:03  peter
+    * interface helpers
+
+}

rtl/objpas/intfh.inc

@@ -0,0 +1,40 @@
+{
+    *********************************************************************
+    $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; overload;
+function Supports(const Instance: TObject; const IID: TGUID; out Intf): Boolean; overload;
+function Supports(const Instance: IInterface; const IID: TGUID): Boolean; overload;
+function Supports(const Instance: TObject; const IID: TGUID): Boolean; overload;
+function Supports(const AClass: TClass; const IID: TGUID): Boolean; overload;
+
+//function CreateGUID(out Guid: TGUID): HResult;
+function StringToGUID(const S: string): TGUID;
+function GUIDToString(const GUID: TGUID): string;
+function IsEqualGUID(const guid1, guid2: TGUID): Boolean;
+
+{
+  $Log$
+  Revision 1.1  2002-01-25 17:42:03  peter
+    * interface helpers
+
+}

rtl/objpas/stre.inc

@@ -5,7 +5,7 @@
     Copyright (c) 1999-2000 by the Free Pascal development team
 
     This file implements english error message strings
-    
+
     See the file COPYING.FPC, included in this distribution,
     for details about the copyright.
 
@@ -23,7 +23,7 @@
 Const
 
    { Error messages for exceptions }
-   
+
    SAbortError = 'Operation aborted';
    SAbstractError = 'Abstract method called';
    SAccessDenied = 'Access denied';
@@ -46,11 +46,12 @@ Const
    SInvalidArgIndex = 'Invalid argument index in format "%s"';
    SInvalidBoolean = '"%s" is not a valid boolean.';
    SInvalidCast = 'Invalid type cast';
-   SInvalidDateTime = '%f is not a valid datee/time value.';
+   SInvalidDateTime = '%f is not a valid date/time value.';
    SInvalidDrive = 'Invalid drive specified';
    SInvalidFileHandle = 'Invalid file handle';
    SInvalidFloat = '"%s" is an invalid float';
    SInvalidFormat = 'Invalid format specifier : "%s"';
+   SInvalidGUID = '"%s" is not a valid GUID value';
    SInvalidInput = 'Invalid input';
    SInvalidInteger = '"%s" is an invalid integer';
    SInvalidOp = 'Invalid floating point operation';
@@ -67,10 +68,13 @@ Const
    SVarArrayBounds = 'Variant array bounds error';
    SVarArrayCreate = 'Variant array cannot be created';
    SVarNotArray = 'Variant doesn''t contain an array';
-   
+
 {
   $Log$
-  Revision 1.5  2001-08-19 21:02:02  florian
+  Revision 1.6  2002-01-25 17:42:03  peter
+    * interface helpers
+
+  Revision 1.5  2001/08/19 21:02:02  florian
     * fixed and added a lot of stuff to get the Jedi DX( headers
       compiled
 
@@ -82,7 +86,7 @@ Const
 
   Revision 1.2  2000/07/13 11:33:51  michael
   + removed logs
- 
+
   Revision 1.1.2.1  2000/08/22 19:21:48  michael
   + Implemented syserrormessage. Made dummies for go32v2 and OS/2
   * Changed linux/errors.pp so it uses pchars for storage.

rtl/objpas/sysutilh.inc

@@ -149,7 +149,7 @@ const
   PathDelim=System.DirectorySeparator;
   DriveDelim=System.DriveSeparator;
   PathSep=System.PathSeparator;
-   
+
 
 Type
    TFileRec=FileRec;
@@ -175,9 +175,17 @@ Type
 
   procedure FreeAndNil(var obj);
 
+{$ifdef HASINTF}
+  { interface handling }
+  {$i intfh.inc}
+{$endif HASINTF}
+
 {
   $Log$
-  Revision 1.15  2001-11-07 14:58:24  michael
+  Revision 1.16  2002-01-25 17:42:03  peter
+    * interface helpers
+
+  Revision 1.15  2001/11/07 14:58:24  michael
   + Added PathDelim,DriveDelim,PathSep; Removed PathSeparator
 
   Revision 1.14  2001/10/23 21:51:03  peter

rtl/objpas/sysutils.inc

@@ -78,6 +78,10 @@
         temp.free;
       end;
 
+{$ifdef HASINTF}
+  { Interfaces support }
+  {$i intf.inc}
+{$endif HASINTF}
 
     constructor Exception.Create(const msg : string);
 
@@ -359,7 +363,10 @@ end;
 
 {
   $Log$
-  Revision 1.8  2002-01-25 16:23:03  peter
+  Revision 1.9  2002-01-25 17:42:03  peter
+    * interface helpers
+
+  Revision 1.8  2002/01/25 16:23:03  peter
     * merged filesearch() fix
 
   Revision 1.7  2001/10/22 21:40:55  peter