mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-21 18:09:30 +02:00
* interface helpers
This commit is contained in:
peter
parent
77bb50032c
commit
4f98a06c73
157
rtl/objpas/intf.inc
Normal file
157
rtl/objpas/intf.inc
Normal file
@ -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
|
||||
|
||||
}
|
||||
40
rtl/objpas/intfh.inc
Normal file
40
rtl/objpas/intfh.inc
Normal file
@ -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
|
||||
|
||||
}
|
||||
@ -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.
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user