mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-05-01 20:33:43 +02:00
875 lines
27 KiB
ObjectPascal
875 lines
27 KiB
ObjectPascal
{
|
|
$Id$
|
|
This file is part of the Free Pascal run time library.
|
|
|
|
Copyright (c) 1998,99 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}
|
|
|
|
uses sysutils;
|
|
|
|
|
|
// temporary types:
|
|
|
|
type
|
|
PShortString =^ShortString;
|
|
PByte =^Byte;
|
|
PWord =^Word;
|
|
PLongint =^Longint;
|
|
PBoolean =^Boolean;
|
|
PSingle =^Single;
|
|
PDouble =^Double;
|
|
PExtended =^Extended;
|
|
PComp =^Comp;
|
|
PFixed16 =^Fixed16;
|
|
{ Doesn't exist ?
|
|
PFIxed32 = ^Fixed32;
|
|
}
|
|
Variant = Pointer;
|
|
|
|
{$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,mkConstructor,mkDestructor,
|
|
mkClassProcedure, mkClassFunction);
|
|
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;
|
|
|
|
{$PACKRECORDS 1}
|
|
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:
|
|
(MethodKind : TMethodKind;
|
|
ParamCount : Byte;
|
|
ParamList : array[0..1023] of Char
|
|
{in reality ParamList is a array[1..ParamCount] of:
|
|
record
|
|
Flags : TParamFlags;
|
|
ParamName : ShortString;
|
|
TypeName : ShortString;
|
|
end;
|
|
followed by
|
|
ResultType : ShortString}
|
|
);
|
|
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) : Ansistring;
|
|
procedure SetStrProp(Instance : TObject;PropInfo : PPropInfo;
|
|
const Value : Ansistring);
|
|
|
|
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
|
|
|
|
type
|
|
|
|
PMethod = ^TMethod;
|
|
|
|
|
|
{$ASMMODE ATT}
|
|
|
|
function CallIntegerFunc(s : Pointer;Address : Pointer; INdex,IValue : Longint) : Integer;assembler;
|
|
asm
|
|
movl S,%esi
|
|
movl Address,%edi
|
|
// ? Indexed function
|
|
movl Index,%eax
|
|
xorl %eax,%eax
|
|
je .LINoPush
|
|
movl IValue,%eax
|
|
pushl %eax
|
|
.LINoPush:
|
|
push %esi
|
|
call %edi
|
|
// now the result is in EAX
|
|
end;
|
|
|
|
function CallIntegerProc(s : Pointer;Address : Pointer;Value : Integer; INdex,IVAlue : Longint) : Integer;assembler;
|
|
asm
|
|
movl S,%esi
|
|
movl Address,%edi
|
|
// Push value to set
|
|
movl Value,%eax
|
|
pushl %eax
|
|
// ? Indexed procedure
|
|
movl Index,%eax
|
|
xorl %eax,%eax
|
|
je .LIPNoPush
|
|
movl IValue,%eax
|
|
pushl %eax
|
|
.LIPNoPush:
|
|
pushl %esi
|
|
call %edi
|
|
end;
|
|
|
|
function CallExtendedFunc(s : Pointer;Address : Pointer; INdex,IValue : Longint) : Extended;assembler;
|
|
asm
|
|
movl S,%esi
|
|
movl Address,%edi
|
|
// ? Indexed function
|
|
movl Index,%eax
|
|
xorl %eax,%eax
|
|
je .LINoPush
|
|
movl IValue,%eax
|
|
pushl %eax
|
|
.LINoPush:
|
|
push %esi
|
|
call %edi
|
|
//
|
|
end;
|
|
|
|
function CallExtendedProc(s : Pointer;Address : Pointer;Value : Extended; INdex,IVAlue : Longint) : Integer;assembler;
|
|
asm
|
|
movl S,%esi
|
|
movl Address,%edi
|
|
// Push value to set
|
|
leal Value,%eax
|
|
pushl (%eax)
|
|
pushl 4(%eax)
|
|
pushl 8(%eax)
|
|
// ? Indexed procedure
|
|
movl Index,%eax
|
|
xorl %eax,%eax
|
|
je .LIPNoPush
|
|
movl IValue,%eax
|
|
pushl %eax
|
|
.LIPNoPush:
|
|
push %esi
|
|
call %edi
|
|
end;
|
|
|
|
function CallBooleanFunc(s : Pointer;Address : Pointer; Index,IValue : Longint) : Boolean;assembler;
|
|
asm
|
|
movl S,%esi
|
|
movl Address,%edi
|
|
// ? Indexed function
|
|
movl Index,%eax
|
|
xorl %eax,%eax
|
|
je .LBNoPush
|
|
movl IValue,%eax
|
|
pushl %eax
|
|
.LBNoPush:
|
|
push %esi
|
|
call %edi
|
|
end;
|
|
|
|
// Assembler functions can't have short stringreturn values.
|
|
// So we make a procedure with var parameter.
|
|
// That's not true (FK)
|
|
|
|
Procedure CallSStringFunc(s : Pointer;Address : Pointer; INdex,IValue : Longint;
|
|
Var Res: Shortstring);assembler;
|
|
asm
|
|
movl S,%esi
|
|
movl Address,%edi
|
|
// ? Indexed function
|
|
movl Index,%eax
|
|
xorl %eax,%eax
|
|
jnz .LSSNoPush
|
|
movl IValue,%eax
|
|
pushl %eax
|
|
// the result is stored in an invisible parameter
|
|
pushl Res
|
|
.LSSNoPush:
|
|
push %esi
|
|
call %edi
|
|
end;
|
|
|
|
Procedure CallSStringProc(s : Pointer;Address : Pointer;Const Value : ShortString; INdex,IVAlue : Longint);assembler;
|
|
asm
|
|
movl S,%esi
|
|
movl Address,%edi
|
|
// Push value to set
|
|
movl Value,%eax
|
|
pushl %eax
|
|
// ? Indexed procedure
|
|
movl Index,%eax
|
|
xorl %eax,%eax
|
|
jnz .LSSPNoPush
|
|
movl IValue,%eax
|
|
pushl %eax
|
|
.LSSPNoPush:
|
|
push %esi
|
|
call %edi
|
|
end;
|
|
|
|
function GetTypeData(TypeInfo : PTypeInfo) : PTypeData;
|
|
|
|
begin
|
|
GetTypeData:=PTypeData(pointer(TypeInfo)+2+PByte(pointer(TypeInfo)+1)^);
|
|
end;
|
|
|
|
function GetPropInfo(TypeInfo : PTypeInfo;const PropName : string) : PPropInfo;
|
|
|
|
var
|
|
hp : PTypeData;
|
|
i : longint;
|
|
|
|
begin
|
|
while Assigned(TypeInfo) do
|
|
begin
|
|
// skip the name
|
|
hp:=GetTypeData(Typeinfo);
|
|
|
|
// the class info rtti the property rtti follows
|
|
// immediatly
|
|
Result:=PPropInfo(pointer(@hp^.UnitName)+Length(hp^.UnitName)+1+SizeOF(Word));
|
|
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(pointer(@Result^.Name)+byte(Result^.Name[0])+1);
|
|
end;
|
|
// parent class
|
|
Typeinfo:=hp^.ParentInfo;
|
|
end;
|
|
Result:=Nil;
|
|
end;
|
|
|
|
function IsStoredProp(Instance : TObject;PropInfo : PPropInfo) : Boolean;
|
|
|
|
begin
|
|
case (PropInfo^.PropProcs shr 4) and 3 of
|
|
ptfield:
|
|
IsStoredProp:=PBoolean(Pointer(Instance)+Longint(PropInfo^.StoredProc))^;
|
|
ptstatic:
|
|
IsStoredProp:=CallBooleanFunc(Instance,PropInfo^.StoredProc,0,0);
|
|
ptvirtual:
|
|
IsStoredProp:=CallBooleanFunc(Instance,ppointer(Pointer(Instance.ClassType)+Longint(PropInfo^.StoredProc))^,0,0);
|
|
ptconst:
|
|
IsStoredProp:=LongBool(PropInfo^.StoredProc);
|
|
end;
|
|
end;
|
|
|
|
procedure GetPropInfos(TypeInfo : PTypeInfo;PropList : PPropList);
|
|
{
|
|
Store Pointers to property information in the list pointed
|
|
to by proplist. PRopList must contain enough space to hold ALL
|
|
properties.
|
|
}
|
|
Type PWord = ^Word;
|
|
|
|
Var TD : PTypeData;
|
|
TP : PPropInfo;
|
|
Count : Longint;
|
|
|
|
begin
|
|
TD:=GetTypeData(TypeInfo);
|
|
// Get this objects TOTAL published properties count
|
|
TP:=(@TD^.UnitName+Length(TD^.UnitName)+1);
|
|
Count:=PWord(TP)^;
|
|
// Now point TP to first propinfo record.
|
|
Inc(Longint(TP),SizeOF(Word));
|
|
While Count>0 do
|
|
begin
|
|
PropList^[0]:=TP;
|
|
Inc(Longint(PropList),SizeOf(Pointer));
|
|
// Point to TP next propinfo record.
|
|
// Located at Name[Length(Name)+1] !
|
|
TP:=PPropInfo(pointer(@TP^.Name)+PByte(@TP^.Name)^+1);
|
|
Dec(Count);
|
|
end;
|
|
// recursive call for parent info.
|
|
If TD^.Parentinfo<>Nil then
|
|
GetPropInfos (TD^.ParentInfo,PropList);
|
|
end;
|
|
|
|
Procedure InsertProp (PL : PProplist;PI : PPropInfo; Count : longint);
|
|
|
|
VAr I : Longint;
|
|
|
|
begin
|
|
I:=0;
|
|
While (I<Count) and (PI^.Name>PL^[I]^.Name) do Inc(I);
|
|
If I<Count then
|
|
Move(PL^[I],PL[I+1],Count-I*SizeOf(Pointer));
|
|
PL^[I]:=PI;
|
|
end;
|
|
|
|
function GetPropList(TypeInfo : PTypeInfo;TypeKinds : TTypeKinds;
|
|
PropList : PPropList) : Integer;
|
|
|
|
{
|
|
Store Pointers to property information OF A CERTAIN KIND in the list pointed
|
|
to by proplist. PRopList must contain enough space to hold ALL
|
|
properties.
|
|
}
|
|
Var TempList : PPropList;
|
|
PropInfo : PPropinfo;
|
|
I,Count : longint;
|
|
|
|
begin
|
|
Result:=0;
|
|
Count:=GetTypeData(TypeInfo)^.Propcount;
|
|
If Count>0 then
|
|
begin
|
|
GetMem(TempList,Count*SizeOf(Pointer));
|
|
Try
|
|
GetPropInfos(TypeInfo,TempList);
|
|
For I:=0 to Count-1 do
|
|
begin
|
|
PropInfo:=TempList^[i];
|
|
If PropInfo^.PropType^.Kind in TypeKinds then
|
|
begin
|
|
InsertProp(PropList,PropInfo,Result);
|
|
Inc(Result);
|
|
end;
|
|
end;
|
|
finally
|
|
FreeMem(TempList,Count*SizeOf(Pointer));
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
Procedure SetIndexValues (P: PPRopInfo; Var Index,IValue : Longint);
|
|
|
|
begin
|
|
Index:=((P^.PropProcs shr 6) and 1);
|
|
If Index<>0 then
|
|
IValue:=P^.Index
|
|
else
|
|
IValue:=0;
|
|
end;
|
|
|
|
function GetOrdProp(Instance : TObject;PropInfo : PPropInfo) : Longint;
|
|
|
|
var
|
|
value,Index,Ivalue : longint;
|
|
|
|
begin
|
|
SetIndexValues(PropInfo,Index,Ivalue);
|
|
case (PropInfo^.PropProcs) and 3 of
|
|
ptfield:
|
|
Value:=PLongint(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
|
|
ptstatic:
|
|
Value:=CallIntegerFunc(Instance,PropInfo^.GetProc,Index,IValue);
|
|
ptvirtual:
|
|
Value:=CallIntegerFunc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^,Index,IValue);
|
|
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);
|
|
|
|
var
|
|
Index,IValue : Longint;
|
|
DataSize: Integer;
|
|
|
|
begin
|
|
{ cut off unnecessary stuff }
|
|
case GetTypeData(PropInfo^.PropType)^.OrdType of
|
|
otSWord,otUWord: begin
|
|
Value:=Value and $ffff;
|
|
DataSize := 2;
|
|
end;
|
|
otSByte,otUByte: begin
|
|
Value:=Value and $ff;
|
|
DataSize := 1;
|
|
end;
|
|
else DataSize := 4;
|
|
end;
|
|
SetIndexValues(PropInfo,Index,Ivalue);
|
|
case (PropInfo^.PropProcs shr 2) and 3 of
|
|
ptfield:
|
|
case DataSize of
|
|
1: PByte(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Byte(Value);
|
|
2: PWord(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Word(Value);
|
|
4: PLongint(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
|
|
end;
|
|
ptstatic:
|
|
CallIntegerProc(Instance,PropInfo^.SetProc,Value,Index,IValue);
|
|
ptvirtual:
|
|
CallIntegerProc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.SetProc))^,Value,Index,IValue);
|
|
end;
|
|
end;
|
|
|
|
Function GetAStrProp(Instance : TObject;PropInfo : PPropInfo):Pointer;
|
|
|
|
{
|
|
Dirty trick based on fact that AnsiString is just a pointer,
|
|
hence can be treated like an integer type.
|
|
}
|
|
|
|
var
|
|
value : Pointer;
|
|
Index,Ivalue : Longint;
|
|
|
|
begin
|
|
SetIndexValues(PropInfo,Index,IValue);
|
|
case (PropInfo^.PropProcs) and 3 of
|
|
ptfield:
|
|
Value:=Pointer(PLongint(Pointer(Instance)+Longint(PropInfo^.GetProc))^);
|
|
ptstatic:
|
|
Value:=Pointer(CallIntegerFunc(Instance,PropInfo^.GetProc,Index,IValue));
|
|
ptvirtual:
|
|
Value:=Pointer(CallIntegerFunc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^,Index,IValue));
|
|
end;
|
|
GetAstrProp:=Value;
|
|
end;
|
|
|
|
Function GetSStrProp(Instance : TObject;PropInfo : PPropInfo):ShortString;
|
|
|
|
var
|
|
value : ShortString;
|
|
Index,IValue : Longint;
|
|
|
|
begin
|
|
SetIndexValues(PropInfo,Index,IValue);
|
|
case (PropInfo^.PropProcs) and 3 of
|
|
ptfield:
|
|
Value:=PShortString(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
|
|
ptstatic:
|
|
CallSStringFunc(Instance,PropInfo^.GetProc,Index,IValue,Value);
|
|
ptvirtual:
|
|
CallSSTringFunc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^,Index,Ivalue,Value);
|
|
end;
|
|
GetSStrProp:=Value;
|
|
end;
|
|
|
|
function GetStrProp(Instance : TObject;PropInfo : PPropInfo) : Ansistring;
|
|
|
|
begin
|
|
Case Propinfo^.PropType^.Kind of
|
|
tkSString : Result:=GetSStrProp(Instance,PropInfo);
|
|
tkAString : Pointer(Result):=GetAStrProp(Instance,Propinfo);
|
|
else
|
|
Result:='';
|
|
end;
|
|
end;
|
|
|
|
procedure SetAStrProp(Instance : TObject;PropInfo : PPropInfo;
|
|
const Value : AnsiString);
|
|
|
|
{
|
|
Dirty trick based on fact that AnsiString is just a pointer,
|
|
hence can be treated like an integer type.
|
|
}
|
|
|
|
var
|
|
Index,Ivalue : Longint;
|
|
begin
|
|
SetIndexValues(PropInfo,Index,IValue);
|
|
case (PropInfo^.PropProcs shr 2) and 3 of
|
|
ptfield:
|
|
PLongint(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Longint(Pointer(Value)) ;
|
|
ptstatic:
|
|
CallIntegerProc(Instance,PropInfo^.SetProc,Longint(Pointer(Value)),Index,IValue);
|
|
ptvirtual:
|
|
CallIntegerProc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.SetProc))^,Longint(Pointer(Value)),Index,IValue);
|
|
end;
|
|
end;
|
|
|
|
procedure SetSStrProp(Instance : TObject;PropInfo : PPropInfo;
|
|
const Value : ShortString);
|
|
|
|
Var Index,IValue: longint;
|
|
|
|
begin
|
|
SetIndexValues(PRopInfo,Index,IValue);
|
|
case (PropInfo^.PropProcs shr 2) and 3 of
|
|
ptfield:
|
|
PShortString(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
|
|
ptstatic:
|
|
CallSStringProc(Instance,PropInfo^.GetProc,Value,Index,IValue);
|
|
ptvirtual:
|
|
CallSStringProc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^,Value,Index,IValue);
|
|
end;
|
|
end;
|
|
|
|
procedure SetStrProp(Instance : TObject;PropInfo : PPropInfo;
|
|
const Value : AnsiString);
|
|
|
|
begin
|
|
Case Propinfo^.PropType^.Kind of
|
|
tkSString : SetSStrProp(Instance,PropInfo,Value);
|
|
tkAString : SetAStrProp(Instance,Propinfo,Value);
|
|
end;
|
|
end;
|
|
|
|
function GetFloatProp(Instance : TObject;PropInfo : PPropInfo) : Extended;
|
|
|
|
var
|
|
Index,Ivalue : longint;
|
|
Value : Extended;
|
|
|
|
|
|
begin
|
|
SetIndexValues(PropInfo,Index,Ivalue);
|
|
case (PropInfo^.PropProcs) and 3 of
|
|
ptfield:
|
|
Case GetTypeData(PropInfo^.PropType)^.FloatType of
|
|
ftSingle:
|
|
Value:=PSingle(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
|
|
ftDouble:
|
|
Value:=PDouble(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
|
|
ftExtended:
|
|
Value:=PExtended(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
|
|
ftcomp:
|
|
Value:=PComp(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
|
|
{ Uncommenting this code results in a internal error!!
|
|
ftFixed16:
|
|
Value:=PFixed16(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
|
|
ftfixed32:
|
|
Value:=PFixed32(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
|
|
}
|
|
end;
|
|
ptstatic:
|
|
Value:=CallExtendedFunc(Instance,PropInfo^.GetProc,Index,IValue);
|
|
ptvirtual:
|
|
Value:=CallExtendedFunc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^,Index,IValue);
|
|
end;
|
|
Result:=Value;
|
|
end;
|
|
|
|
procedure SetFloatProp(Instance : TObject;PropInfo : PPropInfo;
|
|
Value : Extended);
|
|
|
|
Var IValue,Index : longint;
|
|
|
|
begin
|
|
SetIndexValues(PropInfo,Index,Ivalue);
|
|
case (PropInfo^.PropProcs shr 2) and 3 of
|
|
ptfield:
|
|
Case GetTypeData(PropInfo^.PropType)^.FloatType of
|
|
ftSingle:
|
|
PSingle(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
|
|
ftDouble:
|
|
PDouble(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
|
|
ftExtended:
|
|
PExtended(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
|
|
ftcomp:
|
|
PComp(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Comp(Value);
|
|
{ Uncommenting this code results in a internal error!!
|
|
ftFixed16:
|
|
PFixed16(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
|
|
ftfixed32:
|
|
PFixed32(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
|
|
}
|
|
end;
|
|
ptstatic:
|
|
CallExtendedProc(Instance,PropInfo^.SetProc,Value,Index,IValue);
|
|
ptvirtual:
|
|
CallExtendedProc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^,Value,Index,IValue);
|
|
end;
|
|
end;
|
|
|
|
function GetVariantProp(Instance : TObject;PropInfo : PPropInfo): Variant;
|
|
|
|
begin
|
|
{!!!!!!!!!!!}
|
|
Result:=nil;
|
|
end;
|
|
|
|
procedure SetVariantProp(Instance : TObject;PropInfo : PPropInfo;
|
|
const Value: Variant);
|
|
|
|
begin
|
|
{!!!!!!!!!!!}
|
|
end;
|
|
|
|
function GetMethodProp(Instance : TObject;PropInfo : PPropInfo) : TMethod;
|
|
|
|
var
|
|
value: PMethod;
|
|
Index,Ivalue : longint;
|
|
|
|
begin
|
|
SetIndexValues(PropInfo,Index,Ivalue);
|
|
case (PropInfo^.PropProcs) and 3 of
|
|
ptfield:
|
|
Value:=PMethod(Pointer(Instance)+Longint(PropInfo^.GetProc));
|
|
ptstatic:
|
|
Value:=PMethod(CallIntegerFunc(Instance,PropInfo^.GetProc,Index,IValue));
|
|
ptvirtual:
|
|
Value:=PMethod(CallIntegerFunc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^,Index,IValue));
|
|
end;
|
|
GetMethodProp:=Value^;
|
|
end;
|
|
|
|
procedure SetMethodProp(Instance : TObject;PropInfo : PPropInfo;
|
|
const Value : TMethod);
|
|
|
|
var
|
|
Index,IValue : Longint;
|
|
|
|
begin
|
|
SetIndexValues(PropInfo,Index,Ivalue);
|
|
case (PropInfo^.PropProcs shr 2) and 3 of
|
|
ptfield:
|
|
PMethod(Pointer(Instance)+Longint(PropInfo^.SetProc))^ := Value;
|
|
ptstatic:
|
|
CallIntegerProc(Instance,PropInfo^.SetProc,Integer(@Value), Index, IValue);
|
|
ptvirtual:
|
|
CallIntegerProc(Instance,
|
|
PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.SetProc))^,
|
|
Integer(@Value), Index, IValue);
|
|
end;
|
|
end;
|
|
|
|
function GetEnumName(TypeInfo : PTypeInfo;Value : Integer) : string;
|
|
|
|
Var PS : PShortString;
|
|
PT : PTypeData;
|
|
|
|
begin
|
|
PT:=GetTypeData(TypeInfo);
|
|
// ^.BaseType);
|
|
// If PT^.MinValue<0 then Value:=Ord(Value<>0); {map to 0/1}
|
|
PS:=@PT^.NameList;
|
|
While Value>0 Do
|
|
begin
|
|
PS:=PShortString(pointer(PS)+PByte(PS)^+1);
|
|
Dec(Value);
|
|
end;
|
|
Result:=PS^;
|
|
end;
|
|
|
|
function GetEnumValue(TypeInfo : PTypeInfo;const Name : string) : Integer;
|
|
|
|
Var PS : PShortString;
|
|
PT : PTypeData;
|
|
Count : longint;
|
|
|
|
begin
|
|
If Length(Name)=0 then exit(-1);
|
|
PT:=GetTypeData(TypeInfo);
|
|
Count:=0;
|
|
Result:=-1;
|
|
PS:=@PT^.NameList;
|
|
While (Result=-1) and (PByte(PS)^<>0) do
|
|
begin
|
|
If PS^=Name then
|
|
Result:=Count;
|
|
PS:=PShortString(pointer(PS)+PByte(PS)^);
|
|
Inc(Count);
|
|
end;
|
|
end;
|
|
|
|
end.
|
|
|
|
{
|
|
$Log$
|
|
Revision 1.30 1999-11-06 14:41:31 peter
|
|
* truncated log
|
|
|
|
Revision 1.29 1999/09/16 08:59:48 florian
|
|
* GetPropInfo returns now nil if the property wasn't found
|
|
|
|
Revision 1.28 1999/09/15 20:27:24 florian
|
|
+ patch of Sebastion Guenther applied: Get/SetMethodProp implementation
|
|
|
|
Revision 1.27 1999/09/08 16:14:43 peter
|
|
* pointer fixes
|
|
|
|
Revision 1.26 1999/09/03 15:39:23 michael
|
|
* Fixes from Sebastian Guenther
|
|
|
|
Revision 1.25 1999/08/29 22:21:27 michael
|
|
* Patch from Sebastian Guenther
|
|
|
|
Revision 1.24 1999/08/06 13:21:40 michael
|
|
* Patch from Sebastian Guenther
|
|
|
|
Revision 1.23 1999/06/04 12:48:37 michael
|
|
* Fix by Sebastian Guenther.
|
|
|
|
Revision 1.22 1999/05/19 12:03:23 florian
|
|
* the set/get procedures must be called with call %edi instead call (%edi)
|
|
* handling of extended and string properties fixed
|
|
|
|
Revision 1.21 1999/05/07 11:02:14 florian
|
|
* two typos fixed
|
|
|
|
Revision 1.20 1999/05/03 07:30:07 michael
|
|
* Fixes in getenum*
|
|
|
|
Revision 1.19 1999/04/08 11:31:04 peter
|
|
* removed warnings
|
|
|
|
Revision 1.18 1999/01/19 16:08:12 pierre
|
|
?? is callSStringProc a function ??
|
|
|
|
Revision 1.17 1998/12/15 22:43:13 peter
|
|
* removed temp symbols
|
|
|
|
Revision 1.16 1998/12/02 12:35:07 michael
|
|
More changes for type-information
|
|
|
|
Revision 1.15 1998/11/26 14:57:47 michael
|
|
+ Added packrecords 1
|
|
|
|
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
|
|
|
|
}
|