mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-05-16 05:22:41 +02:00
408 lines
11 KiB
ObjectPascal
408 lines
11 KiB
ObjectPascal
{
|
|
$Id$
|
|
This file is part of the Free Pascal run time library.
|
|
|
|
Copyright (c) 1998 by Florian Klaempfl
|
|
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.
|
|
|
|
**********************************************************************}
|
|
|
|
{ This unit provides the same functionality as the TypInfo Unit }
|
|
{ of Delphi }
|
|
|
|
unit typinfo;
|
|
|
|
interface
|
|
|
|
{$MODE objfpc}
|
|
|
|
{$ifndef AUTOOBJPAS}
|
|
uses
|
|
objpas;
|
|
{$endif}
|
|
|
|
// temporary types:
|
|
|
|
type
|
|
ShortString=String;
|
|
PByte =^Byte;
|
|
PBoolean =^Boolean;
|
|
|
|
{$MINENUMSIZE 1 this saves a lot of memory }
|
|
// if you change one of the following enumeration types
|
|
// you have also to change the compiler in an appropriate way !
|
|
TTypeKind = (tkUnknown,tkInteger,tkChar,tkEnumeration,
|
|
tkFloat,tkSet,tkMethod,tkSString,tkLString,tkAString,
|
|
tkWString,tkVariant,tkArray,tkRecord,tkInterface,
|
|
tkClass,tkObject,tkWChar,tkBool);
|
|
|
|
TTOrdType = (otSByte,otUByte,otSWord,otUWord,otSLong,otULong);
|
|
|
|
TFloatType = (ftSingle,ftDouble,ftExtended,ftComp,ftCurr,
|
|
ftFixed16,ftFixed32);
|
|
TMethodKind = (mkProcedure,mkFunction,mkSafeProcedure,mkSafeFunction);
|
|
TParamFlags = set of (pfVar,pfConst,pfArray,pfAddress,pfReference,pfOut);
|
|
TIntfFlags = set of (ifHasGuid,ifDispInterface,ifDispatch);
|
|
|
|
{$MINENUMSIZE DEFAULT}
|
|
|
|
const
|
|
ptField = 0;
|
|
ptStatic = 1;
|
|
ptVirtual = 2;
|
|
ptConst = 3;
|
|
|
|
tkString = tkSString;
|
|
|
|
type
|
|
TTypeKinds = set of TTypeKind;
|
|
|
|
TTypeInfo = record
|
|
Kind : TTypeKind;
|
|
Name : ShortString;
|
|
// here the type data follows as TTypeData record
|
|
end;
|
|
|
|
PTypeInfo = ^TTypeInfo;
|
|
PPTypeInfo = ^PTypeInfo;
|
|
|
|
PTypeData = ^TTypeData;
|
|
TTypeData = packed record
|
|
case TTypeKind of
|
|
tkUnKnown,tkLString,tkWString,tkAString,tkVariant:
|
|
();
|
|
tkInteger,tkChar,tkEnumeration,tkWChar:
|
|
(OrdType : TTOrdType;
|
|
case TTypeKind of
|
|
tkInteger,tkChar,tkEnumeration,tkBool,tkWChar : (
|
|
MinValue,MaxValue : Longint;
|
|
case TTypeKind of
|
|
tkEnumeration:
|
|
(
|
|
BaseType : PTypeInfo;
|
|
NameList : ShortString)
|
|
);
|
|
tkSet:
|
|
(CompType : PTypeInfo)
|
|
);
|
|
tkFloat:
|
|
(FloatType : TFloatType);
|
|
tkSString:
|
|
(MaxLength : Byte);
|
|
tkClass:
|
|
(ClassType : TClass;
|
|
ParentInfo : PTypeInfo;
|
|
PropCount : SmallInt;
|
|
UnitName : ShortString
|
|
// here the properties follow as array of TPropInfo
|
|
);
|
|
tkMethod:
|
|
({!!!!!!!}
|
|
);
|
|
tkInterface:
|
|
({!!!!!!!}
|
|
);
|
|
end;
|
|
|
|
// unsed, just for completeness
|
|
TPropData = packed record
|
|
PropCount : Word;
|
|
PropList : record end;
|
|
end;
|
|
|
|
PPropInfo = ^TPropInfo;
|
|
TPropInfo = packed record
|
|
PropType : PTypeInfo;
|
|
GetProc : Pointer;
|
|
SetProc : Pointer;
|
|
StoredProc : Pointer;
|
|
Index : Integer;
|
|
Default : Longint;
|
|
NameIndex : SmallInt;
|
|
|
|
// contains the type of the Get/Set/Storedproc, see also ptxxx
|
|
// bit 0..1 GetProc
|
|
// 2..3 SetProc
|
|
// 4..5 StoredProc
|
|
// 6 : true, constant index property
|
|
PropProcs : Byte;
|
|
|
|
Name : ShortString;
|
|
end;
|
|
|
|
TProcInfoProc = procedure(PropInfo : PPropInfo) of object;
|
|
|
|
PPropList = ^TPropList;
|
|
TPropList = array[0..65535] of PPropInfo;
|
|
|
|
const
|
|
tkAny = [Low(TTypeKind)..High(TTypeKind)];
|
|
tkMethods = [tkMethod];
|
|
tkProperties = tkAny-tkMethods-[tkUnknown];
|
|
|
|
{ general property handling }
|
|
// just skips the id and the name
|
|
function GetTypeData(TypeInfo : PTypeInfo) : PTypeData;
|
|
|
|
// searches in the property PropName
|
|
function GetPropInfo(TypeInfo : PTypeInfo;const PropName : string) : PPropInfo;
|
|
procedure GetPropInfos(TypeInfo : PTypeInfo;PropList : PPropList);
|
|
function GetPropList(TypeInfo : PTypeInfo;TypeKinds : TTypeKinds;
|
|
PropList : PPropList) : Integer;
|
|
|
|
// returns true, if PropInfo is a stored property
|
|
function IsStoredProp(Instance : TObject;PropInfo : PPropInfo) : Boolean;
|
|
|
|
{ subroutines to read/write properties }
|
|
function GetOrdProp(Instance : TObject;PropInfo : PPropInfo) : Longint;
|
|
procedure SetOrdProp(Instance : TObject;PropInfo : PPropInfo;
|
|
Value : Longint);
|
|
|
|
function GetStrProp(Instance : TObject;PropInfo : PPropInfo) : string;
|
|
procedure SetStrProp(Instance : TObject;PropInfo : PPropInfo;
|
|
const Value : string);
|
|
|
|
function GetFloatProp(Instance : TObject;PropInfo : PPropInfo) : Extended;
|
|
procedure SetFloatProp(Instance : TObject;PropInfo : PPropInfo;
|
|
Value : Extended);
|
|
|
|
function GetVariantProp(Instance : TObject;PropInfo : PPropInfo): Variant;
|
|
procedure SetVariantProp(Instance : TObject;PropInfo : PPropInfo;
|
|
const Value: Variant);
|
|
|
|
function GetMethodProp(Instance : TObject;PropInfo : PPropInfo) : TMethod;
|
|
procedure SetMethodProp(Instance : TObject;PropInfo : PPropInfo;
|
|
const Value : TMethod);
|
|
|
|
{ misc. stuff }
|
|
function GetEnumName(TypeInfo : PTypeInfo;Value : Integer) : string;
|
|
function GetEnumValue(TypeInfo : PTypeInfo;const Name : string) : Integer;
|
|
|
|
implementation
|
|
|
|
{$ASMMODE INTEL}
|
|
|
|
function CallMethod_Integer(s : Pointer;Address : Pointer) : Integer;assembler;
|
|
|
|
asm
|
|
mov ESI,s
|
|
mov EDI,Address
|
|
call [EDI]
|
|
// now the result should be in EAX, untested yet (FK)
|
|
end;
|
|
|
|
function CallMethod_Boolean(s : Pointer;Address : Pointer) : Boolean;assembler;
|
|
|
|
asm
|
|
mov ESI,s
|
|
mov EDI,Address
|
|
call [EDI]
|
|
// now the result should be in EAX, untested yet (FK)
|
|
end;
|
|
|
|
function GetTypeData(TypeInfo : PTypeInfo) : PTypeData;
|
|
|
|
begin
|
|
GetTypeData:=PTypeData(TypeInfo)+2+PByte(TypeInfo+1)^;
|
|
end;
|
|
|
|
function GetPropInfo(TypeInfo : PTypeInfo;const PropName : string) : PPropInfo;
|
|
|
|
var
|
|
hp : PTypeData;
|
|
i : longint;
|
|
|
|
begin
|
|
Result:=Nil;
|
|
while Assigned(TypeInfo) do
|
|
begin
|
|
// skip the name
|
|
hp:=GetTypeData(Typeinfo);
|
|
|
|
// the class info rtti the property rtti follows
|
|
// immediatly
|
|
Result:=PPropInfo(@hp^.UnitName)+byte(hp^.UnitName[0])+1;
|
|
for i:=1 to hp^.PropCount do
|
|
begin
|
|
// found a property of that name ?
|
|
if Result^.Name=PropName then
|
|
exit;
|
|
|
|
// skip to next property
|
|
Result:=PPropInfo(@Result^.Name)+byte(Result^.Name[0])+1;
|
|
end;
|
|
// parent class
|
|
Typeinfo:=hp^.ParentInfo;
|
|
end;
|
|
end;
|
|
|
|
function IsStoredProp(Instance : TObject;PropInfo : PPropInfo) : Boolean;
|
|
|
|
begin
|
|
case (PropInfo^.PropProcs shr 4) and 3 of
|
|
0:
|
|
IsStoredProp:=PBoolean(Pointer(Instance)+Longint(PropInfo^.StoredProc))^;
|
|
1:
|
|
IsStoredProp:=CallMethod(Instance,PropInfo^.StoredProc);
|
|
2:
|
|
IsStoredProp:=CallMethod(Instance,(PPointer(Instance.ClassType)+Longint(PropInfo^.StoredProc)^);
|
|
3:
|
|
IsStoredProp:=LongBool(PropInfo^.StoredProc);
|
|
end;
|
|
end;
|
|
|
|
procedure GetPropInfos(TypeInfo : PTypeInfo;PropList : PPropList);
|
|
|
|
begin
|
|
{!!!!!!!!!!!}
|
|
end;
|
|
|
|
function GetPropList(TypeInfo : PTypeInfo;TypeKinds : TTypeKinds;
|
|
PropList : PPropList) : Integer;
|
|
|
|
begin
|
|
{!!!!!!!!!!!}
|
|
end;
|
|
|
|
function GetOrdProp(Instance : TObject;PropInfo : PPropInfo) : Longint;
|
|
|
|
var
|
|
value : longint;
|
|
|
|
begin
|
|
case (PropInfo^.PropProcs) and 3 of
|
|
0:
|
|
Value:=PLongint(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
|
|
1:
|
|
Value:=CallMethod(Instance,PropInfo^.GetProc);
|
|
2:
|
|
Value:=CallMethod(Instance,(PPointer(Instance.ClassType)+Longint(PropInfo^.GetProc)^);
|
|
end;
|
|
{ cut off unnecessary stuff }
|
|
case GetTypeData(PropInfo^.PropType)^.OrdType of
|
|
otSWord,otUWord:
|
|
Value:=Value and $ffff;
|
|
otSByte,otUByte:
|
|
Value:=Value and $ff;
|
|
end;
|
|
GetOrdProp:=Value;
|
|
end;
|
|
|
|
procedure SetOrdProp(Instance : TObject;PropInfo : PPropInfo;
|
|
Value : Longint);
|
|
|
|
begin
|
|
{!!!!!!!!!!!}
|
|
end;
|
|
|
|
function GetStrProp(Instance : TObject;PropInfo : PPropInfo) : string;
|
|
|
|
begin
|
|
{!!!!!!!!!!!}
|
|
end;
|
|
|
|
procedure SetStrProp(Instance : TObject;PropInfo : PPropInfo;
|
|
const Value : string);
|
|
|
|
begin
|
|
{!!!!!!!!!!!}
|
|
end;
|
|
|
|
function GetFloatProp(Instance : TObject;PropInfo : PPropInfo) : Extended;
|
|
|
|
begin
|
|
{!!!!!!!!!!!}
|
|
end;
|
|
|
|
procedure SetFloatProp(Instance : TObject;PropInfo : PPropInfo;
|
|
Value : Extended);
|
|
|
|
begin
|
|
{!!!!!!!!!!!}
|
|
end;
|
|
|
|
function GetVariantProp(Instance : TObject;PropInfo : PPropInfo): Variant;
|
|
|
|
begin
|
|
{!!!!!!!!!!!}
|
|
end;
|
|
|
|
procedure SetVariantProp(Instance : TObject;PropInfo : PPropInfo;
|
|
const Value: Variant);
|
|
|
|
begin
|
|
{!!!!!!!!!!!}
|
|
end;
|
|
|
|
function GetMethodProp(Instance : TObject;PropInfo : PPropInfo) : TMethod;
|
|
|
|
begin
|
|
{!!!!!!!!!!!}
|
|
end;
|
|
|
|
procedure SetMethodProp(Instance : TObject;PropInfo : PPropInfo;
|
|
const Value : TMethod);
|
|
|
|
begin
|
|
{!!!!!!!!!!!}
|
|
end;
|
|
|
|
function GetEnumName(TypeInfo : PTypeInfo;Value : Integer) : string;
|
|
|
|
begin
|
|
{!!!!!!!!!!!}
|
|
end;
|
|
|
|
function GetEnumValue(TypeInfo : PTypeInfo;const Name : string) : Integer;
|
|
|
|
begin
|
|
{!!!!!!!!!!!}
|
|
end;
|
|
|
|
end.
|
|
|
|
{
|
|
$Log$
|
|
Revision 1.11 1998-09-24 23:45:28 peter
|
|
* updated for auto objpas loading
|
|
|
|
Revision 1.10 1998/09/20 08:25:34 florian
|
|
+ description of tpropinfo.propprocs bit 6 added
|
|
|
|
Revision 1.9 1998/09/19 15:25:45 florian
|
|
* procedure GetOrdProp added
|
|
|
|
Revision 1.8 1998/09/19 08:33:53 florian
|
|
+ some procedures added
|
|
|
|
Revision 1.7 1998/09/08 09:52:31 florian
|
|
* small problems fixed
|
|
|
|
Revision 1.6 1998/09/08 00:08:36 michael
|
|
Made it compilable
|
|
|
|
Revision 1.5 1998/09/07 23:11:43 florian
|
|
+ more fields to TTypeInfo added
|
|
|
|
Revision 1.4 1998/09/07 19:34:47 florian
|
|
* constant value is now supported as stored condition
|
|
|
|
Revision 1.3 1998/09/07 08:32:59 florian
|
|
+ procedure IsStoredProc added
|
|
|
|
Revision 1.2 1998/09/06 21:27:05 florian
|
|
+ some methods and declarations added
|
|
|
|
Revision 1.1 1998/08/25 22:30:00 florian
|
|
+ initial revision:
|
|
o constants
|
|
o basic type data record
|
|
}
|