Below is the most up-to-date version of my “TRttiIterator” component for Delphi 2010. It is functional (indeed I am using it in various internal applications right now) though there are features which need to be added, changes and improvements to be made, and possibly some bugs to be fixed. License terms, changelog and known bugs are contained in the notation at the top of the unit.
TRttiIterator uses Delphi 2010′s “Rtti.pas” unit and does exactly what its name suggests: Iterates through all available RTTI information in whatever application you embed it within. It goes a step further, however, and can provide further insight into parameters of OnEvent handlers (which, for whatever reason, Delphi 2010′s Rtt.pas unit cannot). Whilst this component is very useful to me personally, I have no idea if it will be for you (though since you’re looking at this page I presume you have some use for it).
This version was submitted on Wednesday June 2nd 2010:
{
THIS COMPONENT IS DESIGNED TO ALLOW SIMPLIFIED ITERATION THROUGH RTTI DATA.
IT'S ORIGINAL PURPOSE IS FOR A CODE GENERATOR WHICH BUILDS WRAPPER UNITS
BASED ON RTTI DATA RATHER THAN PARSING SOURCE UNITS DIRECTLY.
IMPORTANT: AT TIME OF WRITING, THIS UNIT WILL ONLY WORK WITH DELPHI 2010 AS
IT USES DELPHI 2010'S "RTTI.PAS" UNIT (WHICH IS NOT AVAILABLE ON
EARLIER VERSIONS!)
LICENSE (IN VERY PLAIN ENGLISH)
-------------------------------
YOU MAY USE THIS CLASS AS YOU DESIRE, AND MAKE CHANGES TOO, BUT YOU MUST LEAVE
THIS ORIGINAL NOTICE IN PLACE AT ALL TIMES. YOU MUST ALSO CLEARLY MARK ALL
CUSTOM ALTERATIONS WITH YOUR NAME, AND THE DATE THE MODIFICATION(S) WAS(WERE)
MADE (EXAMPLE BELOW SHOWS THE BEST CONVENTION IF YOU INTEND TO HAVE YOUR
MODIFICATIONS COMMITED TO THE OFFICIAL UNIT).
////// MODIFICATION BY <myname> BEGIN
<SOME NEW CODE HERE>
// REM - <SOME REMOVED CODE HERE>
////// MODIFICATION BY <myname> END
1) YOU MAY NOT MAKE A PROFIT FROM THE DISTRIBUTION OF THIS UNIT AND IT'S RELATED
FILES, BUT YOU MAY USE THIS UNIT AND IT'S RELATED FILES AS PART OF ANY
COMMERCIAL PRODUCT (ROYALTY FREE).
2) IF YOU DISTRIBUTE MODIFIED VERSIONS OF THIS UNIT AND ITS RELATED FILES, YOU
MUST DO SO UNDER THE TERMS OF THIS LICENSE AND NO OTHER (SO NO PROFIT FROM
DISTRIBUTION, NOTICE IN-TACT).
3) YOU MAY USE PARTS OF THE CODE HEREIN IN OTHER UNITS, BUT THOSE UNITS MUST
ALSO BE DISTRIBUTED UNDER THE TERMS OF THIS LICNESE.
4) YOU ARE NOT REQUIRED TO DISTRIBUTE CUSTOM VERSIONS OF THIS UNIT (SO YOU CAN
KEEP CUSTOM VERSIONS AS "CLOSED-SOURCE" IF YOU CHOOSE)
DISCLAIMER (IN VERY PLAIN ENGLISH)
----------------------------------
THIS UNIT (AND ITS RELATED FILES) ARE PROVIDED AS-IS, WITHOUT GUARANTEE OR
WARANTY. SIMON J STUART WILL NOT BE HELD ACCOUNTABLE FOR ANY DAMAGES OR LOSSES
WHICH MAY OCCUR DURING - OR AS A RESULT OF - THE USE OF THIS UNIT AND/OR ITS
RELATED FILES. YOU USE THIS UNIT (AND ITS RELATED FILES) AT YOUR OWN RISK.
THIS UNIT (AND ITS RELATED FILES) HAVE BEEN TESTED THROUOGHLY TO ENSURE BOTH
THEIR SAFETY, AND DESIRED RESULTS... BUT THE ABOVE DISCLAIMER STILL STANDS.
IF YOU DO NOT AGREE TO THE ABOVE TERMS, YOU MUST REMOVE THIS UNIT (AND ITS
RELATED FILES) FROM YOUR COMPUTER(S)/STORAGE MEDIUM(S) IMMEDIATLEY.
Version: 1.0
Last Modified: 4th May 2010
Copyright (C) 2009-2010, Simon J Stuart, All Rights Reserved.
Retained under the UK 1988 Copyright Designs and Patents Act (as ammended).
http://www.lakraven.com
http://www.luarad.org
CHANGELOG:
3rd May 2010 (Simon J Stuart):
- Added "Filter" property. If not null, then only iterates types within
the named unit... such as "StdCtrls". Applies only to "IterateAll".
4th May 2010 (Simon J Stuart):
- Added "IterateInOrder" procedure, "UnitCount" and "UnitNames" property.
This iterates the types in Unit Order, Alphabetically. Useful for my
needs, may well be useful for you as well.
- Added "OnUnitStart" and "OnUnitFinish" events to accompany the
"IterateInOrder" procedure. Again, useful for my needs!
- Changed "OnProgress" to show progress for all units
- Added "OnUnitProgress" to show progress of types within a unit
TO DO LIST:
- Expand on the Exception Handler to provide better information.
- Add "Sender: TObject" to all OnEvents.
- Interface Types
- Any other missing type kind
}
unit RttiLib;
interface
uses
SysUtils, Classes, Rtti, TypInfo;
type
StrArray = Array of String;
PStrArray = ^StrArray;
TRtti_Type = (LSTRING, LCHAR, LVARIANT, LCOLOR, LCLASS, LBOOLEAN, LENUM, LPOINTER,
LSET, LARRAY, LDYNARRAY, LRECORD, LINTERFACE, LCLASSREF, LPROCEDURE,
LMETHOD, LUNKNOWN);
{$M+}
TRtti_ClassOptions = class(TObject)
private
_DoClasses : Boolean;
_DoProperties : Boolean;
_DoMethods : Boolean;
_DoEvents : Boolean;
published
property DoClasses : Boolean read _DoClasses write _DoClasses;
property DoProperties : Boolean read _DoProperties write _DoProperties;
property DoMethods : Boolean read _DoMethods write _DoMethods;
property DoEvents : Boolean read _DoEvents write _DoEvents;
end;
TRtti_EnumOptions = class(TObject)
private
_DoEnums : Boolean;
_DoElements : Boolean;
published
property DoEnums : Boolean read _DoEnums write _DoEnums;
property DoElements : Boolean read _DoElements write _DoElements;
end;
TRtti_SetOptions = class(TObject)
private
_DoSets : Boolean;
_DoElements : Boolean;
published
property DoSets : Boolean read _DoSets write _DoSets;
property DoElements : Boolean read _DoElements write _DoElements;
end;
TRtti_ArrayOptions = class(TObject)
private
_DoArrays : Boolean;
published
property DoArrays : Boolean read _DoArrays write _DoArrays;
end;
TRtti_DynArrayOptions = class(TObject)
private
_DoDynArrays : Boolean;
published
property DoDynArrays : Boolean read _DoDynArrays write _DoDynArrays;
end;
TRtti_RecordOptions = class(TObject)
private
_DoRecords : Boolean;
_DoFields : Boolean;
published
property DoRecords : Boolean read _DoRecords write _DoRecords;
property DoFields : Boolean read _DoFields write _DoFields;
end;
TRtti_InterfaceOptions = class(TObject)
private
_DoInterfaces : Boolean;
published
property DoInterfaces : Boolean read _DoInterfaces write _DoInterfaces;
end;
TRtti_PointerOptions = class(TObject)
private
_DoPointers : Boolean;
published
property DoPointers : Boolean read _DoPointers write _DoPointers;
end;
TRtti_OnException = procedure (Msg: String) of object;
TRtti_OnTypeStart = procedure (QualifiedName: String) of object;
TRtti_OnTypeFinish = procedure (QualifiedName: String) of object;
TRtti_OnProgress = procedure (Current, Total: Integer; Percent: Extended) of object;
TRtti_OnUnitStart = procedure (CurrentUnit: String) of object;
TRtti_OnUnitFinish = procedure (CurrentUnit: String) of object;
// CLASS "OnEvent" METHOD TYPES
TRtti_OnClassStart = procedure (RClass: TRttiType) of object;
TRtti_OnProperty = procedure (RClass: TRttiType; RProperty: TRttiProperty; BasicType: TRtti_Type) of object;
TRtti_OnMethodStart = procedure (RClass: TRttiType; RMethod: TRttiMethod) of object;
TRtti_OnMethodParam = procedure (RClass: TRttiType; RMethod: TRttiMethod; Parameter: TRttiParameter; BasicType: TRtti_Type) of object;
TRtti_OnMethodFinish = procedure (RClass: TRttiType; RMethod: TRttiMethod) of object;
TRtti_OnEventStart = procedure (RClass: TRttiType; REvent: TRttiProperty; Prototype: String) of object;
TRtti_OnEventParam = procedure (RClass: TRttiType; REvent: TRttiProperty; Parameter: TRttiType; ParamName: String;
ParamNumber: Integer; BasicType: TRtti_Type) of object;
TRtti_OnEventFinish = procedure (RClass: TRttiType; REvent: TRttiProperty) of object;
TRtti_OnClassFinish = procedure (RClass: TRttiType) of object;
// RECORD "OnEvent" METHOD TYPES
TRtti_OnRecordStart = procedure (RRecord: TRttiRecordType) of object;
TRtti_OnField = procedure (RRecord: TRttiRecordType; RField: TRttiField; FieldBasicType: TRtti_Type; FieldNumber: Integer) of object;
TRtti_OnRecordFinish = procedure (RRecord: TRttiRecordType) of object;
// STATIC ARRAY "OnEvent" METHOD TYPES
TRtti_OnArray = procedure (RArray: TRttiArrayType; ElementBasicType: TRtti_Type) of object;
// DYNAMIC ARRAY "OnEvent" METHOD TYPES
TRtti_OnDynArray = procedure (RDynArray: TRttiDynamicArrayType; ElementBasicType: TRtti_Type) of object;
// ENUM "OnEvent" METHOD TYPES
TRtti_OnEnumStart = procedure (REnum: TRttiEnumerationType) of object;
TRtti_OnEnumElement = procedure (REnum: TRttiEnumerationType; ElementName: String; ElementIndex: Integer) of object;
TRtti_OnEnumFinish = procedure (REnum: TRttiEnumerationType) of object;
// SET "OnEvent" METHOD TYPES
TRtti_OnSetStart = procedure (RSet: TRttiSetType) of object;
TRtti_OnSetElement = procedure (RSet: TRttiSetType; ElementName: String; ElementIndex: Integer) of object;
TRtti_OnSetFinish = procedure (RSet: TRttiSetType) of object;
// INTERFACE "OnEvent" METHOD TYPES {TODO}
TRtti_OnInterfaceStart = procedure (RInterface: TRttiInterfaceType) of object;
TRtti_OnInterfaceFinish = procedure (RInterface: TRttiInterfaceType) of object;
// POINTER "OnEvent" METHOD TYPES {TODO}
TRtti_OnPointer = procedure (RPointer: TRttiPointerType; BasicType: TRtti_Type) of object;
// The Rtti Iterator
TRttiIterator = class(TComponent)
private
C : TRttiContext;
UnitList : StrArray;
_CurrentType : String;
_QualifiedArray : TStringList;
_UnitList : TStringList;
_UnitCount : Integer;
_TotalTypes : Integer;
_CurrentCount : Integer;
_Filter : String;
_InOrder : Boolean;
_ClassOptions : TRtti_ClassOptions;
_EnumOptions : TRtti_EnumOptions;
_SetOptions : TRtti_SetOptions;
_ArrayOptions : TRtti_ArrayOptions;
_DynArrayOptions : TRtti_DynArrayOptions;
_RecordOptions : TRtti_RecordOptions;
_InterfaceOptions : TRtti_InterfaceOptions;
_PointerOptions : TRtti_PointerOptions;
FOnException : TRtti_OnException;
FOnIterateStart : TNotifyEvent;
FOnIterateFinish : TNotifyEvent;
FOnTypeStart : TRtti_OnTypeStart;
FOnTypeFinish : TRtti_OnTypeFinish;
FOnProgress : TRtti_OnProgress;
FOnUnitProgress : TRtti_OnProgress;
FOnUnitStart : TRtti_OnUnitStart;
FOnUnitFinish : TRtti_OnUnitFinish;
// CLASSES
FOnClassStart : TRtti_OnClassStart;
FOnProperty : TRtti_OnProperty;
FOnMethodStart : TRtti_OnMethodStart;
FOnMethodParam : TRtti_OnMethodParam;
FOnMethodFinish : TRtti_OnMethodFinish;
FOnEventStart : TRtti_OnEventStart;
FOnEventParam : TRtti_OnEventParam;
FOnEventFinish : TRtti_OnEventFinish;
FOnClassFinish : TRtti_OnClassFinish;
// RECORDS
FOnRecordStart : TRtti_OnRecordStart;
FOnField : TRtti_OnField;
FOnRecordFinish : TRtti_OnRecordFinish;
// STATIC ARRAYS
FOnArray : TRtti_OnArray;
// DYNAMIC ARRAYS
FOnDynArray : TRtti_OnDynArray;
// ENUMS
FOnEnumStart : TRtti_OnEnumStart;
FOnEnumElement : TRtti_OnEnumElement;
FOnEnumFinish : TRtti_OnEnumFinish;
// SETS
FOnSetStart : TRtti_OnSetStart;
FOnSetElement : TRtti_OnSetElement;
FOnSetFinish : TRtti_OnSetFinish;
// INTERFACES {TODO}
// POINTERS {TODO}
FOnPointer : TRtti_OnPointer;
procedure StartIterating(RType: TRttiType);
procedure IterateClass(RClass: TRttiType);
procedure IterateEnum(REnum: TRttiEnumerationType);
procedure IterateSet(RSet: TRttiSetType);
procedure IterateArray(RArray: TRttiArrayType);
procedure IterateDynArray(RArray: TRttiDynamicArrayType);
procedure IterateRecord(RRecord: TRttiRecordType);
procedure IterateInterface(RInterface: TRttiInterfaceType);
procedure IteratePointer(RPointer: TRttiPointerType);
procedure AddToArray(const StrList: PStrArray; const Value: String; DotStrip: Boolean = false);
published
property CurrentType : String read _CurrentType;
property QualifiedNames : TStringList read _QualifiedArray;
property UnitNames : TStringList read _UnitList;
property UnitCount : Integer read _UnitCount;
property TotalTypes : Integer read _TotalTypes;
property Filter : String read _Filter write _Filter;
property ClassOptions : TRtti_ClassOptions read _ClassOptions write _ClassOptions;
property EnumOptions : TRtti_EnumOptions read _EnumOptions write _EnumOptions;
property SetOptions : TRtti_SetOptions read _SetOptions write _SetOptions;
property ArrayOptions : TRtti_ArrayOptions read _ArrayOptions write _ArrayOptions;
property DynamicArrayOptions : TRtti_DynArrayOptions read _DynArrayOptions write _DynArrayOptions;
property RecordOptions : TRtti_RecordOptions read _RecordOptions write _RecordOptions;
property InterfaceOptions : TRtti_InterfaceOptions read _InterfaceOptions write _InterfaceOptions;
property PointerOptions : TRtti_PointerOptions read _PointerOptions write _PointerOptions;
property OnException : TRtti_OnException read FOnException write FOnException;
property OnIterateStart : TNotifyEvent read FOnIterateStart write FOnIterateStart;
property OnIterateFinish : TNotifyEvent read FOnIterateFinish write FOnIterateFinish;
property OnTypeStart : TRtti_OnTypeStart read FOnTypeStart write FOnTypeStart;
property OnTypeFinish : TRtti_OnTypeFinish read FOnTypeFinish write FOnTypeFinish;
property OnProgress : TRtti_OnProgress read FOnProgress write FOnProgress;
property OnUnitProgress : TRtti_OnProgress read FOnUnitProgress write FOnUnitProgress;
property OnUnitStart : TRtti_OnUnitStart read FOnUnitStart write FOnUnitStart;
property OnUnitFinish : TRtti_OnUnitFinish read FOnUnitFinish write FOnUnitFinish;
// CLASSES
property OnClass_Start : TRtti_OnClassStart read FOnClassStart write FOnClassStart;
property OnClass_Property : TRtti_OnProperty read FOnProperty write FOnProperty;
property OnClass_MethodStart : TRtti_OnMethodStart read FOnMethodStart write FOnMethodStart;
property OnClass_MethodParam : TRtti_OnMethodParam read FOnMethodParam write FOnMethodParam;
property OnClass_MethodFinish : TRtti_OnMethodFinish read FOnMethodFinish write FOnMethodFinish;
property OnClass_EventStart : TRtti_OnEventStart read FOnEventStart write FOnEventStart;
property OnClass_EventParam : TRtti_OnEventParam read FOnEventParam write FOnEventParam;
property OnClass_EventFinish : TRtti_OnEventFinish read FOnEventFinish write FOnEventFinish;
property OnClass_Finish : TRtti_OnClassFinish read FOnClassFinish write FOnClassFinish;
// RECORDS
property OnRecord_Start : TRtti_OnRecordStart read FOnRecordStart write FOnRecordStart;
property OnRecord_Field : TRtti_OnField read FOnField write FOnField;
property OnRecord_Finish : TRtti_OnRecordFinish read FOnRecordFinish write FOnRecordFinish;
// STATIC ARRAYS
property OnArray : TRtti_OnArray read FOnArray write FOnArray;
// DYNMAIC ARRAYS
property OnDynArray : TRtti_OnDynArray read FOnDynArray write FOnDynArray;
// ENUMS
property OnEnum_Start : TRtti_OnEnumStart read FOnEnumStart write FOnEnumStart;
property OnEnum_Element : TRtti_OnEnumElement read FOnEnumElement write FOnEnumElement;
property OnEnum_Finish : TRtti_OnEnumFinish read FOnEnumFinish write FOnEnumFinish;
// SETS
property OnSet_Start : TRtti_OnSetStart read FOnSetStart write FOnSetStart;
property OnSet_Element : TRtti_OnSetElement read FOnSetElement write FOnSetElement;
property OnSet_Finish : TRtti_OnSetFinish read FOnSetFinish write FOnSetFinish;
// INTERFACES {TODO}
// POINTERS {TODO}
property OnPointer : TRtti_OnPointer read FOnPointer write FOnPointer;
public
function InterpretAs(t: TRttiType): TRtti_Type;
function ExtractSS(var p: Pointer): string;
function ProcessEventDeclaration(TypeInfo: PTypeInfo; EventName: String = ''): String;
function FindTypeByName(const TypeName: String): TRttiType;
procedure Iterate(QualifiedName: String);
procedure IterateAll();
procedure IterateInOrder();
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
const
CharTypes = [TypInfo.tkChar, TypInfo.tkWChar];
StringTypes = [TypInfo.tkString, TypInfo.tkLString, TypInfo.tkWString, TypInfo.tkUString];
IntegerTypes = [TypInfo.tkInteger, TypInfo.tkInt64];
VariantTypes = [TypInfo.tkVariant, TypInfo.tkFloat];
MethodTypes = [TypInfo.tkMethod];
ClassTypes = [TypInfo.tkClass];
BooleanTypes = [TypInfo.tkEnumeration];
UnknownTypes = [TypInfo.tkUnknown];
SetTypes = [TypInfo.tkSet];
ArrayTypes = [TypInfo.tkArray];
DynArrayTypes = [TypInfo.tkDynArray];
RecordTypes = [TypInfo.tkRecord];
InterfaceTypes = [TypInfo.tkInterface];
ClassRefTypes = [TypInfo.tkClassRef];
PointerTypes = [TypInfo.tkPointer];
ProcedureTypes = [TypInfo.tkProcedure];
procedure Register;
implementation
////////////////////////////////////////////////////////////////////////////////
// HELPER METHODS //
////////////////////////////////////////////////////////////////////////////////
procedure TRttiIterator.AddToArray(const StrList: PStrArray; const Value: String; DotStrip: Boolean = false);
var
I: Integer;
IsDuplicate: Boolean;
Val: String;
begin
if DotStrip then
Val := Copy(Value, 1, Pos('.', Value)-1)
else
Val := Value;
IsDuplicate := False;
if Length(StrList^) > 0 then begin
for I := 0 to Length(StrList^) -1 do begin
if (StrList^[I] = Val) then begin
IsDuplicate := True;
Break;
end;
end;
end;
if NOT (IsDuplicate) then begin
SetLength(StrList^, Length(StrList^) +1);
StrList^[Length(StrList^)-1] := Val;
end;
end;
function TRttiIterator.InterpretAs(t: TRttiType): TRtti_Type;
begin
with t do begin
if TypeKind in StringTypes then
Result := LSTRING
else if TypeKind in CharTypes then
Result := LCHAR
else if (TypeKind in IntegerTypes)
OR (TypeKind in VariantTypes)
AND NOT (QualifiedName = 'Graphics.TColor') then
Result := LVARIANT
else if QualifiedName = 'Graphics.TColor' then
Result := LCOLOR
else if (TypeKind in BooleanTypes)
AND NOT ( (QualifiedName = 'System.Boolean') OR (QualifiedName = 'System.ByteBool')
OR (QualifiedName = 'System.WordBool') OR (QualifiedName = 'System.LongBool')
OR (QualifiedName = 'System.Bool') ) then begin
Result := LENUM;
end else if (TypeKind in BooleanTypes)
AND ( (QualifiedName = 'System.Boolean') OR (QualifiedName = 'System.ByteBool')
OR (QualifiedName = 'System.WordBool') OR (QualifiedName = 'System.LongBool')
OR (QualifiedName = 'System.Bool') ) then
Result := LBOOLEAN
else if TypeKind in ClassTypes then begin
Result := LCLASS;
end else if TypeKind in PointerTypes then
Result := LPOINTER
else if TypeKind in SetTypes then
Result := LSET
else if TypeKind in ArrayTypes then
Result := LARRAY
else if TypeKind in DynArrayTypes then
Result := LDYNARRAY
else if TypeKind in RecordTypes then
Result := LRECORD
else if TypeKind in InterfaceTypes then
Result := LINTERFACE
else if TypeKind in ClassRefTypes then
Result := LCLASSREF
else if TypeKind in ProcedureTypes then
Result := LPROCEDURE
else if TypeKind in MethodTypes then
Result := LMETHOD
else
Result := LUNKNOWN;
end;
end;
function TRttiIterator.ExtractSS(var p: Pointer): string;
begin
Result := String(ShortString(p^));
Inc(PByte(p), Length(Result) + 1);
end;
function TRttiIterator.ProcessEventDeclaration(TypeInfo: PTypeInfo; EventName: String = ''): String;
type
PParamFlags = ^TParamFlags;
var
TypeData: PTypeData;
Ptr: PByte;
B: Byte;
Flags: TParamFlags;
begin
Result := '';
if not Assigned(TypeInfo) or (TypeInfo^.Kind <> tkMethod) then Exit;
// Result := 'type ' + TypeInfo^.Name + ' = ';
TypeData := GetTypeData(TypeInfo);
case TypeData^.MethodKind of
mkClassProcedure, mkClassFunction:
Result := Result + 'class ';
end;
case TypeData^.MethodKind of
mkProcedure, mkClassProcedure, mkSafeProcedure:
Result := Result + 'procedure';
mkFunction, mkClassFunction, mkSafeFunction:
Result := Result + 'function ';
mkConstructor:
Result := Result + 'constructor ';
mkDestructor:
Result := Result + 'destructor ';
end;
Result := Result + ' ' + EventName;
Ptr := PByte(@TypeData^.ParamList);
if TypeData^.ParamCount > 0 then
begin
Result := Result + '(';
for b := 0 to TypeData^.ParamCount-1 do
begin
if b > 0 then Result := Result + '; ';
Flags := PParamFlags(Ptr)^;
Inc(Ptr, SizeOf(TParamFlags));
if pfVar in Flags then Result := Result + 'var ';
if pfConst in Flags then Result := Result + 'const ';
if pfArray in Flags then Result := Result + 'array of ';
if pfOut in Flags then Result := Result + 'out ';
Result := Result + String(PShortString(Ptr)^);
Inc(Ptr, 1 + Length(PShortString(Ptr)^));
if Length(PShortString(Ptr)^) > 0 then Result := Result + ': ' + String(PShortString(Ptr)^);
Inc(Ptr, 1 + Length(PShortString(Ptr)^));
end;
Result := Result + ')';
end;
case TypeData^.MethodKind of
mkFunction, mkClassFunction, mkSafeFunction:
Result := Result + ': ' + String(PShortString(Ptr)^);
end;
Result := Result + ';'; // of object;';
case TypeData^.MethodKind of
mkSafeProcedure, mkSafeFunction:
Result := Result + ' safecall;';
end;
end;
function TRttiIterator.FindTypeByName(const TypeName: String): TRttiType;
var
I: Integer;
Candidate: String;
t: TRttiType;
begin
t := nil;
for I := 0 to _QualifiedArray.Count - 1 do begin
Candidate := Copy(_QualifiedArray[I], 0, pos('.', _QualifiedArray[I]) - 1) + '.' + TypeName;
try
t := C.FindType(Candidate);
except end;
if t <> nil then
Break;
end;
Result := t;
end;
////////////////////////////////////////////////////////////////////////////////
// THE CORE OF THE ITERATOR //
////////////////////////////////////////////////////////////////////////////////
procedure TRttiIterator.IterateClass(RClass: TRttiType);
var
p: TRttiProperty;
m: TRttiMethod;
mp: TRttiParameter;
e: TRttiProperty;
// FOR EVENT PARAMETERS
I: Integer;
ParamP: Pointer;
eParamCount: Integer;
Flags: TypInfo.TParamFlags;
ept: TRttiType;
eParamName,
eTypeName: String;
begin
if Assigned(FOnClassStart) then
FOnClassStart(RClass);
// ITERATE PROPERTIES
if _ClassOptions.DoProperties then begin
try
for p in RClass.GetProperties do begin
try
AddToArray(@UnitList, p.PropertyType.QualifiedName, true);
if ((Assigned(FOnProperty)) AND NOT (p.PropertyType.TypeKind in MethodTypes))then
FOnProperty(RClass, p, InterpretAs(p.PropertyType));
except
if Assigned(FOnException) then
FOnException('Error iterating this Property');
end;
end;
except
// EXCEPTION HANDLER HERE
if Assigned(FOnException) then
FOnException('Error iterating Class Properties');
end;
end;
// ITERATE METHODS
if _ClassOptions.DoMethods then begin
try
for m in RClass.GetMethods do begin
try
if Assigned(FOnMethodStart) then
FOnMethodStart(RClass, m);
try
for mp in m.GetParameters do begin
try
AddToArray(@UnitList, mp.ParamType.QualifiedName, true);
if Assigned(FOnMethodParam) then
FOnMethodParam(RClass, m, mp, InterpretAs(mp.ParamType));
except
if Assigned(FOnException) then
FOnException('Error iterating this Method Parameter');
end;
end;
except
if Assigned(FOnException) then
FOnException('Error iterating Method Parameters');
end;
if Assigned(FOnMethodFinish) then
FOnMethodFinish(RClass, m);
except
if Assigned(FOnException) then
FOnException('Error iterating this Method');
end;
end;
except
if Assigned(FOnException) then
FOnException('Error iterating Class Methods');
end;
end;
// ITERATE EVENTS (USING A SOMEWHAT HACKY BUT PROVEN METHOD)
{
PLEASE NOTE THAT AT THIS MOMENT THE NEW DELPHI 2010 RTTI UNIT HAS NO DIRECT
OR ELEGANT METHOD FOR OBTAINING DETAILED PARAMETER INFORMATION FOR EVENTS,
SO I HAVE COME UP WITH A "HACKY" BUT WORKABLE SOLUTION TO ATTEMPT TO GAIN MORE
INSIGHT ON EACH PARAMETER. MY METHOD ITERATES THROUGH ALL KNOWN UNIT NAMES,
ATTEMPTING TO MATCH THEM WITH THE ALREADY-KNOWN CLASS NAME TO CREATE A
"QUALIFIEDNAME" WHICH CAN BE USED TO QUERY FOR MORE RTTI DATA.
}
if _ClassOptions.DoEvents then begin
try
for e in RClass.GetProperties do begin
try
AddToArray(@UnitList, e.PropertyType.QualifiedName, true);
if e.PropertyType.TypeKind in MethodTypes then begin
if Assigned(FOnEventStart) then
FOnEventStart(RClass, e, ProcessEventDeclaration(e.PropertyType.Handle, e.Name));
try
// INSTERT EVENT PARAMETER INFO STUFF HERE
if Assigned(FOnEventParam) then begin
eParamCount := 0;
ParamP := @TypInfo.GetTypeData(e.PropertyType.Handle).ParamList;
for I := 1 to GetTypeData(e.PropertyType.Handle).ParamCount do begin
eParamCount := EParamCount + 1;
Flags := TypInfo.TParamFlags(ParamP^);
Inc(PByte(ParamP), SizeOf(TParamFlags));
eParamName := ExtractSS(ParamP);
eTypeName := ExtractSS(ParamP);
ept := FindTypeByName(eTypeName);
FOnEventParam(RClass, e, ept, eParamName, eParamCount, InterpretAs(ept));
end;
end;
except
if Assigned(FOnException) then
FOnException('Error iterating Event Parameters');
end;
if Assigned(FOnEventFinish) then
FOnEventFinish(RClass, e);
end;
except
if Assigned(FOnException) then
FOnException('Error iterating this Event');
end;
end;
except
if Assigned(FOnException) then
FOnException('Error iterating Class Events');
end;
end;
if Assigned(FOnClassFinish) then
FOnClassFinish(RClass);
end;
procedure TRttiIterator.IterateEnum(REnum: TRttiEnumerationType);
var
I: Integer;
begin
if Assigned(FOnEnumStart) then
FOnEnumStart(REnum);
if _EnumOptions._DoElements then begin
try
for I := REnum.MinValue to REnum.MaxValue do begin
try
if Assigned(FOnEnumElement) then
FOnEnumElement(REnum, GetEnumName(REnum.Handle, I), I);
except
if Assigned(FOnException) then
FOnException('Error iterating this Enum Element');
end;
end;
except
if Assigned(FOnException) then
FOnException('Error iterating this Enum');
end;
end;
if Assigned(FOnEnumFinish) then
FOnEnumFinish(REnum);
end;
procedure TRttiIterator.IterateSet(RSet: TRttiSetType);
var
I: Integer;
o: TRttiOrdinalType;
begin
if Assigned(FOnSetStart) then
FOnSetStart(RSet);
if _SetOptions.DoElements then begin
try
o := TRttiOrdinalType(RSet.ElementType);
for I := o.MinValue to o.MaxValue do begin
if Assigned(OnSet_Element) then
OnSet_Element(RSet, GetEnumName(o.Handle, I), I);
end;
except
if Assigned(FOnException) then
FOnException('Error iterating this Set Element');
end;
end;
if Assigned(FOnSetFinish) then
FOnSetFinish(RSet);
end;
procedure TRttiIterator.IterateArray(RArray: TRttiArrayType);
begin
if Assigned(FOnArray) then
FOnArray(RArray, InterpretAs(RArray.ElementType));
end;
procedure TRttiIterator.IterateDynArray(RArray: TRttiDynamicArrayType);
begin
if Assigned(FOnArray) then
FOnDynArray(RArray, InterpretAs(RArray.ElementType));
end;
procedure TRttiIterator.IterateRecord(RRecord: TRttiRecordType);
var
f: TRttiField;
I: Integer;
begin
if Assigned(FOnRecordStart) then
FOnRecordStart(RRecord);
if _RecordOptions._DoFields then begin
try
I := 0;
for f in RRecord.GetFields do begin
try
I := I + 1;
if Assigned(FOnField) then
FOnField(RRecord, f, InterpretAs(f.FieldType), I);
except
if Assigned(FOnException) then
FOnException('Error iterating this Record Field');
end;
end;
except
if Assigned(FOnException) then
FOnException('Error iterating this Record');
end;
end;
if Assigned(FOnRecordFinish) then
FOnRecordFinish(RRecord);
end;
procedure TRttiIterator.IterateInterface(RInterface: TRttiInterfaceType);
begin
// GOT A LOT TO DO HERE
end;
procedure TRttiIterator.IteratePointer(RPointer: TRttiPointerType);
begin
if Assigned(FOnPointer) then
FOnPointer(RPointer, InterpretAs(RPointer.ReferredType));
end;
procedure TRttiIterator.StartIterating(RType: TRttiType);
begin
try
_CurrentType := RType.QualifiedName;
if Assigned(FOnTypeStart) then
FOnTypeStart(_CurrentType);
SetLength(UnitList, 0);
AddToArray(@UnitList, RType.QualifiedName, true);
if (InterpretAs(RType) = LCLASS) AND (_ClassOptions.DoClasses) then begin // IS THE TYPE A CLASS?
try
IterateClass(TRttiType(RType))
except
if Assigned(FOnException) then
FOnException('Error iterating Class');
end;
end else if (InterpretAs(RType) = LENUM) AND (_EnumOptions.DoEnums) then begin // IS THE TYPE AN ENUM?
try
IterateEnum(TRttiEnumerationType(RType))
except
if Assigned(FOnException) then
FOnException('Error iterating Enum');
end;
end else if (InterpretAs(RType) = LSET) AND (_SetOptions.DoSets) then begin // IS THE TYPE A SET?
try
IterateSet(TRttiSetType(RType))
except
if Assigned(FOnException) then
FOnException('Error iterating Set');
end;
end else if (InterpretAs(RType) = LARRAY) AND (_ArrayOptions.DoArrays) then begin // IS THE TYPE A STATIC ARRAY?
try
IterateArray(TRttiArrayType(RType))
except
if Assigned(FOnException) then
FOnException('Error iterating Array');
end;
end else if (InterpretAs(RType) = LDYNARRAY) AND (_DynArrayOptions.DoDynArrays) then begin // IS THE TYPE A DYNAMIC ARRAY?
try
IterateDynArray(TRttiDynamicArrayType(RType))
except
if Assigned(FOnException) then
FOnException('Error iterating Dynamic Array');
end;
end else if (InterpretAs(RType) = LRECORD) AND (_RecordOptions.DoRecords) then begin // IS THE TYPE A RECORD?
try
IterateRecord(TRttiRecordType(RType))
except
if Assigned(FOnException) then
FOnException('Error iterating Record');
end;
end else if (InterpretAs(RType) = LINTERFACE) AND (_InterfaceOptions.DoInterfaces) then begin // IS THIS TYPE AN INTERFACE?
try
IterateInterface(TRttiInterfaceType(RType))
except
if Assigned(FOnException) then
FOnException('Error iterating Interface');
end;
end else if (InterpretAs(RType) = LPOINTER) AND (_PointerOptions.DoPointers) then begin // IS THIS TYPE A POINTER?
try
IteratePointer(TRttiPointerType(RType));
except
if Assigned(FOnException) then
FOnException('Error iterating Pointer');
end;
end;
if Assigned(FOnTypeFinish) then
FOnTypeFinish(_CurrentType);
except
if Assigned(FOnException) then
FOnException('Error iterating Type');
end;
end;
procedure TRttiIterator.Iterate(QualifiedName: string);
begin
// THIS WILL ITERATE A SINGLE NAMED TYPE
if Assigned(FOnIterateStart) then
FOnIterateStart(Self);
StartIterating(C.FindType(QualifiedName));
if Assigned(FOnIterateFinish) then
FOnIterateFinish(Self);
end;
procedure TRttiIterator.IterateAll;
var
t: TRttiType;
begin
// THIS WILL CYCLE THROUGH ALL AVAILABLE TYPES AND ITERATE THEM
_CurrentCount := 0;
if Assigned(FOnIterateStart) then
FOnIterateStart(Self);
for t in C.GetTypes do begin
_CurrentCount := _CurrentCount + 1;
if (Assigned(FOnUnitProgress)) then
FOnUnitProgress(_CurrentCount, _TotalTypes, (_CurrentCount / _TotalTypes) * 100);
if ((Copy(t.QualifiedName, 1, Pos('.', t.QualifiedName) -1) = _Filter) OR (_Filter = '')) then
StartIterating(t);
end;
if Assigned(FOnIterateFinish) then
FOnIterateFinish(Self);
end;
procedure TRttiIterator.IterateInOrder();
var
I: Integer;
begin
_InOrder := True;
for I := 0 to _UnitList.Count - 1 do begin
if Assigned(FOnProgress) then
FOnProgress(I, _UnitList.Count, (I + 1 / _UnitList.Count) * 100);
_Filter := _UnitList[I];
if Assigned(FOnUnitStart) then
FOnUnitStart(_UnitList[I]);
IterateAll();
if Assigned(FOnUnitFinish) then
FOnUnitFinish(_UnitList[I]);
end;
_InOrder := False;
end;
////////////////////////////////////////////////////////////////////////////////
// HOUSEKEEPING METHODS //
////////////////////////////////////////////////////////////////////////////////
constructor TRttiIterator.Create(AOwner: TComponent);
var
ThisRtti: TRttiType;
I: Integer;
Duplicate: Boolean;
begin
C := TRttiContext.Create; // CREATE THE Rtti CONTEXT OBJECT
_InOrder := False;
_QualifiedArray := TStringList.Create;
_UnitList := TStringList.Create;
_TotalTypes := 0;
_UnitCount := 0;
for ThisRtti in C.GetTypes do begin
_QualifiedArray.Add(ThisRtti.QualifiedName);
_TotalTypes := _TotalTypes + 1;
Duplicate := False;
for I := 0 to _UnitList.Count - 1 do begin
if (_UnitList[I] = Copy(ThisRtti.QualifiedName, 1, Pos('.', ThisRtti.QualifiedName) -1)) then begin
Duplicate := True;
break;
end;
end;
if not (Duplicate) then begin
_UnitList.Add(Copy(ThisRtti.QualifiedName, 1, Pos('.', ThisRtti.QualifiedName) -1));
_UnitCount := _UnitCount + 1;
end;
end;
_UnitList.Sorted := True;
_QualifiedArray.Sorted := True;
_ClassOptions := TRtti_ClassOptions.Create();
with _ClassOptions do begin
DoClasses := True;
DoProperties := True;
DoMethods := True;
DoEvents := True;
end;
_EnumOptions := TRtti_EnumOptions.Create();
with _EnumOptions do begin
DoEnums := True;
DoElements := True;
end;
_SetOptions := TRtti_SetOptions.Create();
with _SetOptions do begin
DoSets := True;
DoElements := True;
end;
_ArrayOptions := TRtti_ArrayOptions.Create();
with _ArrayOptions do begin
DoArrays := True;
end;
_DynArrayOptions := TRtti_DynArrayOptions.Create();
with _DynArrayOptions do begin
DoDynArrays := True;
end;
_RecordOptions := TRtti_RecordOptions.Create();
with _RecordOptions do begin
DoRecords := True;
DoFields := True;
end;
inherited;
end;
destructor TRttiIterator.Destroy;
begin
FreeAndNil(_QualifiedArray);
FreeAndNil(_UnitList);
FreeAndNil(_ClassOptions);
FreeAndNil(_EnumOptions);
FreeAndNil(_SetOptions);
FreeAndNil(_ArrayOptions);
FreeAndNil(_DynArrayOptions);
FreeAndNil(_RecordOptions);
inherited;
end;
procedure Register;
begin
RegisterComponents('Rtti', [TRttiIterator]);
end;
end.
January 26, 2011 at 8:42 am
Hi,
Thank you for the code, looks like what I need at the moment.
Could you please post example usage of the unit?
Kind regards
M.C.
October 20, 2011 at 4:00 pm
I know this is a very late reply, I actually only just noticed this comment (I’m really sorry for that)!
TRttiIterator is actually about to be substancially updated (improved) as I have rewritten it from the ground up for use in the new Lua4Delphi 2 Wrapper Generator!
I will include with it a demo which uses the RTTI information harvested through the Iterator to reconstruct the Type’s declaration in a TMemo (or similar) control.
This demo will show quite well how TRttiIterator can be used to introspect all aspects of one or more Delphi Types for whatever purpose you may require (in my case creating wrapper units, but you can use this same information in an infinite variety of ways!)