RTTI

Smart Pascal has full support for RTTI, allowing you to enumerate properties, methods and extract type information.

Smart Pascal contains extensive RTTI (Runtime Type Information) for class types. This will allow you to access type information like method names, custom attributes or property capabilities of a class at runtime.

IMPORTANT: Only properties/fields and methods defined in published section are listed and can be accessed by RTTI.

type

TBase = class

protected

Field: string = 'hello';

public

// not visible by RTTI

property Hidden: string read Field write Field;

published

// visible by RTTI

property Stuff: string read Field write Field;

procedure Foo;

begin

Field := 'Hello World';

end;

TExample = class(TBase)

published

SeeMe: string = 'Fields working too';

property Another: string read Field;

function GiveMe: string;

begin

result := Field

end;

var

obj := TExample.Create();

var

rtti := RTTIRawAttributes;

var

aClass := obj.ClassType;

PrintLn(aClass.ClassName + ':');

while Assigned(aClass) do

begin

var

attribType := TypeOf(aClass);

for var

i := low(rtti) to high(rtti) do

begin

var

attrib := rtti[i];

if (attrib.T = attribType) then

begin

if attrib.A is RTTIPropertyAttribute then

begin

var

prop := RTTIPropertyAttribute(attrib.A);

printLn(prop.Name);

printLn(prop.Typ.Name);

printLn(prop.Getter(obj));

end

else if attrib.A is RTTIMethodAttribute then

begin

var

meth := RTTIMethodAttribute(attrib.A);

printLn(meth.Name);

printLn(meth.Typ.Name);

var

res := meth.call(obj, []);

end;

aClass := aClass.ClassParent;

end;

Result:

TExample: - Another,

1 : String = hello - SeeMe,

3 : String = Fields working too - Stuff,

3 : String = hello

GLOBAL VARIABLES

·	RTTIRawAttributes: array of

·	TRTTIRawAttribute - Array of all RTTI informations (attributes) for current running script

TYPES:

TRTTITypeInfo

·	property ID : integer - ID for type

·	property Name : String - Name of type

TCustomAttribute

This class and any descendant can be used to annotated classes.

type

MyAttribute = class (TCustomAttribute);

type

[MyAttribute]

TTest1 = class

end;

TRTTIRawAttribute

·	property T : TRTTITypeInfo - Type to which the attribute belongs

·	property A : TCustomAttribute - Attributeinstance provide data and access methods (type: e.g. RTTIPropertyAttribute)

RTTIPropertyAttribute

·	const capReadable = 1 - Property/field an be read

·	const capWriteable = 2 - Property/field can be written

·	function Name() : String - Name of property/field

·	function Typ() : TRTTITypeInfo - Type of property/field

·	function Getter(handle : Variant) : Variant - Returns value for property/field and instance (obj)

·	procedure Setter(handle : Variant; value : Variant) - Set Value for property/field and instance (obj)

·	function Capabilities() : integer - Returns property style (capReadable / capWriteable / capReadable + capWriteable), for fields will always return (capReadable + capWriteable)

RTTIMethodAttribute

·	const infoOverlap = 1

·	const infoOverride = 2

·	const infoStatic = 4

·	const infoClass = 8

·	const infoOverload = 16

·	const infoAbstract = 32

·	const infoFinal = 64

·	const infoConstructor = 128

·	const infoDestructor = 256

·	function Name() : String - Name of method

·	function Typ() : TRTTITypeInfo - Return Type of method

·	function Info() : integer - Return an infobitmask what annotations are set for methods (e.g. override, class, overload) - see consts (e.g. infoOverride, infoClass, infoOverload) for possible values

·	function VMTIndex : integer

·	function Call(instance : Variant; args : array of const) : Variant - Call method in context of given instance and parameters. If method is a function, call will return result value.

Utils

·	function TypeOf(class) : TRTTITypeInfo - Returns typeinfo for any class.

·	obj.classType: Return class for a instance of a class.

var aClass := obj.ClassType;

PrintLn(aClass.ClassName+':');

·	aClass.classParent: Return the parentclass for a class or nil if no upper class exists.

Code example using RTTI

type

MyAttrib = class(TCustomAttribute);

type

[MyAttrib]

TTest1 = class

end;

[TCustomAttribute]

[MyAttrib]

TTest2 = class

end;

procedure TForm1.PrintAttributes(obj: TClass);

begin

W3Memo1.Text := W3Memo1.Text + obj.ClassName + #13#10;

//WriteLn(obj.ClassName);

var

rtti := RTTIRawAttributes;

var

typeID := TypeOf(obj.ClassType);

for var

j := Low(rtti) to High(rtti) do

begin

if rtti[j].T = typeID then begin

//WriteLn(rtti[j].A.ClassName);

W3Memo1.Text := W3Memo1.Text + ' [' + rtti[j].A.ClassName + ']'#13#10;

end;

procedure TForm1.PrintAttributesForType(typeID: TRTTITypeInfo);

begin

var

rtti := RTTIRawAttributes;

var

j: Integer;

for j := Low(rtti) to High(rtti) do

begin

if rtti[j].T = typeID then

WriteLn(rtti[j].A.ClassName);

end;

procedure PrintPropertiesForType(obj: TObject);

begin

var

rtti := RTTIRawAttributes;

var

aClass := obj.ClassType;

PrintLn(aClass.ClassName + ':');

while Assigned(aClass) do

begin

var

typeID := TypeOf(aClass);

var

j: Integer;

for j := Low(rtti) to High(rtti) do

begin

var

attrib := rtti[j];

asm

console.dir(attrib);

end;

if (attrib.T = TypeID) and (attrib.A is RTTIPropertyAttribute) then

begin

var

prop := RTTIPropertyAttribute(attrib.A);

Print('- ' + prop.Name);

Print(', ' + IntToStr(prop.Capabilities));

Print(' : ');

Print(prop.Typ.Name);

Print(' = ');

var

v := prop.Getter(obj);

PrintLn(v);

prop.Setter(obj, v + v);

end;

aClass := aClass.ClassParent;

end;

procedure TForm1.W3Button1Click(Sender: TObject);

begin

W3Memo1.Text := '';

PrintAttributes(TTest1);

PrintAttributes(TTest2);

PrintAttributesForType(TypeOf(TTest1));

PrintAttributesForType(TypeOf(TTest2));

//PrintPropertiesForType(Sender);

end;

procedure TForm1.W3Button2Click(Sender: TObject);

begin

WriteLn('GetPropList called');

GetPropList(self);

end;

type

Test = class

published

Field: integer;

procedure Blub();

begin

end;

{some code fragments}

begin

W3Memo1.Text := W3Memo1.Text + obj.ClassName + #13#10;

//WriteLn(obj.ClassName);

var rtti := RTTIRawAttributes;

var typeID := TypeOf(obj.ClassType);

for var j:=Low(rtti) to High(rtti) do begin

if rtti[j].T = typeID then begin

WriteLn(rtti[j].A.ClassName);

W3Memo1.Text := W3Memo1.Text + ' [' + rtti[j].A.ClassName + ']'#13#10;

end;

End;

var

rtti := RTTIRawAttributes;

for var i := low(rtti) to high(rtti) do

begin

WriteLn(rtti[i].T.Name);

if rtti[i].A is RTTIPropertyAttribute then

WriteLn(RTTIPropertyAttribute(rtti[i].A).Name)

else if rtti[i].A is RTTIMethodAttribute then

WriteLn(RTTIMethodAttribute(rtti[i].A).Name);

end;

var

rtti := RTTIRawAttributes;

for var ir := Low(rtti) to High(rtti) do

begin

var

attrib := rtti[ir];

ShowMessage(JSON.Stringify(attrib));

end;

procedure PrintPropertiesForType2(obj: TObject);

begin

var

rtti := RTTIRawAttributes;

var

aClass := obj.ClassType;

PrintLn(aClass.ClassName + ':');

while Assigned(aClass) do

begin

var

typeID := TypeOf(aClass);

var

i: Integer;

for i := Low(rtti) to High(rtti) do

begin

var

attrib := rtti[i];

if (attrib.T = TypeID) and (attrib.A is RTTIPropertyAttribute) then

begin

var

prop := RTTIPropertyAttribute(attrib.A);

Print('- ' + prop.Name);

Print(', ' + IntToStr(prop.Capabilities));

Print(' : ');

Print(prop.Typ.Name);

Print(' = ');

var

v := prop.Getter(obj);

PrintLn(v);

prop.Setter(obj, v + v);

end;

aClass := aClass.ClassParent;

end;

procedure TForm1.W3Button3Click(Sender: TObject);

begin

var

b := new TBase;

var

s := new TSub;

PrintPropertiesForType2(b); //TBase:

PrintPropertiesForType2(s); //TSub:

PrintLn(b.Field); // 1

PrintLn(s.SuBField); // hello

end;

RTTI based persistence

RTTI based persistence, only published properties are automatically serialized. I will no doubt add support for more complex storage, much like Delphi’s TFiler architecture, but as a demonstration of RTTI under Smart Pascal this is more than enough.

unit w3persistent;

interface

uses

W3System;

type

EPersistent = Class(EW3Exception);

IPersistent = Interface

function objToString:String;

procedure objFromString(const aData:String);

procedure objReset;

end;

TPersistent = Class(TObject,IPersistent)

private

(* Implements:: IPersistent *)

function objToString:String;

Procedure objFromString(const aData:String);

procedure objReset;

protected

Procedure AssignTo(const aTarget:TPersistent);virtual;

public

Procedure Assign(const aSource:TPersistent);virtual;

End;

TNamedValuePair = Record

nvName: String;

nvValue: Variant;

End;

TNamedValuePairArray = Array of TNamedValuePair;

TPersistentHelper = Class helper for TPersistent

public

class function getRTTIProperties(var aPairs:TNamedValuePairArray):Integer;

class procedure setRTTIProperties(const aPairs:TNamedValuePairArray);

end;

implementation

resourcestring

CNT_ERR_TPERSISTENT_READ = 'Persistent read error [%s]';

CNT_ERR_TPERSISTENT_WRITE = 'Persistent write error [%s]';

//#############################################################################

// TPersistentHelper

//#############################################################################

class procedure TPersistentHelper.setRTTIProperties

(const aPairs:TNamedValuePairArray);

var

mRTTI: Array of TRTTIRawAttribute;

mAttrib: TRTTIRawAttribute;

mTypeId: TRTTITypeInfo;

x,y: Integer;

Begin

if aPairs.length>0 then

begin

for y:=aPairs.low to aPairs.high do

Begin

mTypeId:=TypeOf(self.classtype);

mRTTI:=RTTIRawAttributes;

if mRtti.length>0 then

Begin

for x:=mRtti.low to mRtti.high do

begin

mAttrib:=mRtti[x];

if (mAttrib.T = mTypeId)

and (mAttrib.A is RTTIPropertyAttribute) then

begin

var prop := RTTIPropertyAttribute(mAttrib.A);

if prop.name = aPairs[y].nvName then

prop.setter(variant(self),aPairs[y].nvValue);

end;

class function TPersistentHelper.getRTTIProperties

(var aPairs:TNamedValuePairArray):Integer;

var

mRTTI: Array of TRTTIRawAttribute;

mAttrib: TRTTIRawAttribute;

mTypeId: TRTTITypeInfo;

x: Integer;

mPair: TNamedValuePair;

Begin

aPairs.clear;

result:=-1;

mTypeId:=TypeOf(self.classtype);

mRTTI:=RTTIRawAttributes;

if mRtti.Length>0 then

begin

for x:=mRtti.Low to mRtti.High do

begin

mAttrib:=mRtti[x];

if (mAttrib.T = mTypeId)

and (mAttrib.A is RTTIPropertyAttribute) then

begin

var prop := RTTIPropertyAttribute(mAttrib.A);

mPair.nvName:=prop.name;

mPair.nvValue:=Prop.Getter(Variant(self));

aPairs.add(mPair);

end;

result:=aPairs.length;

end;

//#############################################################################

// TPersistent

//#############################################################################

procedure TPersistent.objReset;

var

mData: TNamedValuePairArray;

x: Integer;

Begin

if getRTTIProperties(mData)>0 then

begin

for x:=mData.low to mData.high do

mData[x].nvValue:=undefined;

setRTTIProperties(mData);

end;

function TPersistent.objToString:String;

var

mData: TNamedValuePairArray;

mCount: Integer;

x: Integer;

Begin

mCount:=getRTTIProperties(mData);

if mCount>0 then

begin

try

asm

@Result = JSON.stringify(@mData);

end;

finally

mData.clear;

end;

end

end;

Procedure TPersistent.objFromString(const aData:String);

var

mData: TNamedValuePairArray;

Begin

if length(aData)>0 then

Begin

asm

@mData = JSON.parse(@aData);

end;

if mData.length>0 then

Begin

setRTTIProperties(mData);

mData.clear;

end;

end else

objReset;

end;

Procedure TPersistent.Assign(const aSource:TPersistent);

Begin

if aSource<>NIL then

Begin

try

objFromString(aSource.objToString);

except

on e: exception do

Raise EPersistent.CreateFmt(CNT_ERR_TPERSISTENT_READ,[e.message]);

end;

procedure TPersistent.AssignTo(const aTarget: TPersistent);

begin

if aTarget<>NIL then

begin

try

aTarget.objFromString(objToString);

except

on e: exception do

Raise EPersistent.CreateFmt(CNT_ERR_TPERSISTENT_WRITE,[e.message]);

end;

end.

Notes:

·	Using the class is more or less identical to Delphi. Simply derive your class from TPersistent, and all published properties can be transfered via the Assign() and AssignTo() methods. You can also access the serialization methods directly via the IPersistent interface.

·	It does not check datatypes before trying to serialize so only use it with ordinal types (string, boolean, word, integer etc). Neither does it check for arrays.