The following code:
---------------------------------------------------------
Unit
RTTIObject;
Interface
Uses
Classes,
SysUtils,
StrUtils,
Contnrs,
TypInfo;
Type
TRTTIObject = Class(TObject)
Private
fInstanceName: String;
fTypeData: PTypeData;
fPropList: PPropList;
fNumProperties: Integer;
Protected
Procedure SetProperty(Const aName, aValue: String); Overload;
Function GetProperty(Const aName: String): String; Overload;
Procedure SetProperty(Const aIndex: Integer; aValue: String);
Overload;
Function GetProperty(Const aIndex: Integer): String; Overload;
Function GetPropertyName(Const aIndex: Integer): String;
Function GetPropertyType(Const aIndex: Integer): String;
Function GetPropertyIndex(Const aName: String): Integer;
Public
Constructor Create(Const aInstanceName: String); Virtual;
Destructor Destroy; Override;
Property Properties[aName: String]: String Read GetProperty
Write SetProperty;
Property Properties[aIndex: Integer]: String Read GetProperty
Write
SetProperty;
Property PropertyCount: Integer Read fNumProperties;
Published
Property InstanceName: String Read fInstanceName;
End;
Implementation
Procedure TRTTIObject.SetProperty(Const aName, aValue: String);
Var
lRow : Integer;
Begin
lRow := GetPropertyIndex(aName);
SetProperty(lRow, aValue);
End;
Function TRTTIObject.GetProperty(Const aName: String): String;
Var
lRow : Integer;
Begin
lRow := GetPropertyIndex(aName);
Result := GetProperty(lRow);
End;
Procedure TRTTIObject.SetProperty(Const aIndex: Integer; aValue: String);
Var
lName: String;
Begin
lName := fPropList^[aIndex]^.Name;
Case fPropList^[aIndex]^.PropType^.Kind Of
tkInteger : SetOrdProp(Self, lName, StrToInt(aValue));
tkFloat : If fPropList^[aIndex]^.PropType^.Name = 'TDateTime'
Then
SetFloatProp(Self, lName,
StrToDateTime(aValue))
Else
SetFloatProp(Self, lName,
StrToFloat(aValue));
tkSString : SetStrProp(Self, lName, aValue);
tkLString : SetStrProp(Self, lName, aValue);
tkAString : SetStrProp(Self, lName, aValue);
tkWString : SetStrProp(Self, lName, aValue);
tkVariant : SetVariantProp(Self, lName, aValue);
tkBool : SetOrdProp(Self, lName, Ord(LowerCase(aValue) =
'true'));
tkInt64 : SetOrdProp(Self, lName, StrToInt(aValue));
tkQWord : SetOrdProp(Self, lName, StrToInt(aValue));
tkUString : SetStrProp(Self, lName, aValue);
End;
End;
Function TRTTIObject.GetProperty(Const aIndex: Integer): String;
Var
lName: String;
Begin
lName := fPropList^[aIndex]^.Name;
Case fPropList^[aIndex]^.PropType^.Kind Of
tkInteger : Result := IntToStr(GetOrdProp(Self, lName));
tkFloat : If fPropList^[aIndex]^.PropType^.Name = 'TDateTime'
Then
Result :=
DateTimeToStr(GetFloatProp(Self, lName))
Else
Result := FloatToStr(GetFloatProp(Self,
lName));
tkSString : Result := GetStrProp(Self, lName);
tkLString : Result := GetStrProp(Self, lName);
tkAString : Result := GetStrProp(Self, lName);
tkWString : Result := GetStrProp(Self, lName);
tkVariant : Result := GetVariantProp(Self, lName);
tkBool : If Boolean(GetOrdProp(Self, lName)) Then
Result := 'True'
Else
Result := 'False';
tkInt64 : Result := IntToStr(GetOrdProp(Self, lName));
tkQWord : Result := IntToStr(GetOrdProp(Self, lName));
tkUString : Result := GetStrProp(Self, lName);
End;
End;
Function TRTTIObject.GetPropertyName(Const aIndex: Integer): String;
Begin
Result := fPropList^[aIndex]^.Name;
End;
Function TRTTIObject.GetPropertyType(Const aIndex: Integer): String;
Begin
Result := fPropList^[aIndex]^.PropType^.Name;
End;
Function TRTTIObject.GetPropertyIndex(Const aName: String): Integer;
Var
lRow : Integer;
lName : String;
Begin
Result := -1;
For lRow := 0 To fNumProperties - 1 Do
Begin
lName := GetPropertyName(lRow);
If lName = aName Then
Begin
Result
:= lRow;
Break;
End;
End;
End;
Constructor TRTTIObject.Create(Const aInstanceName: String);
Begin
Inherited Create;
fInstanceName := aInstanceName;
fTypeData := GetTypeData(Self.ClassInfo);
GetMem(fPropList, fTypeData^.PropCount * SizeOf(Pointer));
fNumProperties := GetPropList(Self.ClassInfo, [ tkInteger, tkFloat,
tkSString, tkLString, tkAString, tkWString, tkVariant, tkBool,
tkInt64, tkQWord, tkUString ], fPropList);
End;
Destructor TRTTIObject.Destroy;
Begin
FreeMem(fPropList, fTypeData^.PropCount * SizeOf(Pointer));
Inherited Destroy;
End;
End.
---------------------------------
Uses
RTTIObject;
Var
MyRTTIObject : TRTTIObject;
Begin
MyRTTIObject := TRTTIObject.Create('MyRTTIObject');
MyRTTIObject.Free;
End.
--------------------------------------
gives strange results...
the compiler issues no warning whatsoever but when i try to run the
compiled test program, it gives this :
---------------------------------
C:\Programacao\testcase>rttiobject-testcase.exe
An unhandled exception occurred at $0040E1E7 :
EAccessViolation : Access violation
$0040E1E7 TRTTIOBJECT__DESTROY, line 143 of RTTIObject.pas
$0040E18A TRTTIOBJECT__CREATE, line 139 of RTTIObject.pas
$00401515 main, line 8 of rttiobject-testcase.pas
---------------------------------------------------------
looks like the constructor is calling the destructor before doing
anything at all...
what i did wrong ?
_______________________________________________
fpc-pascal maillist - fpc-pascal@lists.freepascal.org
http://lists.freepascal.org/mailman/listinfo/fpc-pascal
