RTTI и другие трюки с информацией о классах, модулях и т.п.

Code:

procedure EnumMethods( aClass: TClass; lines: TStrings );

type

   TMethodtableEntry = packedRecord

     len: Word;

     adr: Pointer;

     name: ShortString;

end;

{Note: name occupies only the size required, so it is not a true shortstring! The actual

entry size is variable, so the method table is not an array of TMethodTableEntry!}

var

pp: ^Pointer;

pMethodTable: Pointer;

pMethodEntry: ^TMethodTableEntry;

i, numEntries: Word;

begin

if aClass = nilthen

   Exit;

pp := Pointer(Integer( aClass ) + vmtMethodtable);

pMethodTable := pp^;

lines.Add(format('Class %s: method table at %p', [aClass.Classname, pMethodTable ] ));

if pMethodtable <> nilthen

begin

   {first word of the method table contains the number of entries}

   numEntries := PWord( pMethodTable )^;

   lines.Add(format('  %d published methods', [numEntries] ));

   {make pointer to first method entry, it starts at the second word of the table}

   pMethodEntry := Pointer(Integer( pMethodTable ) + 2);

   for i := 1to numEntries do

   begin

     with pMethodEntry^ do

       lines.Add(format( '  %d: len: %d, adr: %p, name: %s', [i, len, adr, name] ));

     {make pointer to next method entry}

     pMethodEntry := Pointer(Integer( pMethodEntry ) + pMethodEntry^.len);

   end;

end;

   EnumMethods( aClass.ClassParent, lines );

end;

procedure TForm2.Button1Click(Sender: TObject);

begin

memo1.clear;

EnumMethods( Classtype, memo1.lines );

end;

Code:

function GetComponentProperties(Instance: TPersistent; AList: TStrings): Integer;

var

I, Count: Integer;

PropInfo: PPropInfo;

PropList: PPropList;

begin

Result := 0;

Count := GetTypeData(Instance.ClassInfo)^.PropCount;

if Count > 0then

begin

   GetMem(PropList, Count * SizeOf(Pointer));

   try

     GetPropInfos(Instance.ClassInfo, PropList);

     for I := 0to Count - 1do

     begin

       PropInfo := PropList^[I];

       if PropInfo = nilthen

         Break;

       if IsStoredProp(Instance, PropInfo) then

       begin

         {

         case PropInfo^.PropType^.Kind of

           tkInteger:

           tkMethod:

           tkClass:

           ...

         end;

         }

       end;

       Result := AList.Add(PropInfo^.Name);

     end;

   finally

     FreeMem(PropList, Count * SizeOf(Pointer));

   end;

end;

end;

Code:

uses

TypInfo

procedure ListProperties(AInstance: TPersistent; AList: TStrings);

var

i: integer;

pInfo: PTypeInfo;

pType: PTypeData;

propList: PPropList;

propCnt: integer;

tmpStr: string;

begin

pInfo := AInstance.ClassInfo;

if (pInfo = nil) or (pInfo^.Kind <> tkClass) then

   raise Exception.Create('Invalid type information');

pType := GetTypeData(pInfo);  {Pointer to TTypeData}

AList.Add('Class name: ' + pInfo^.Name);

{If any properties, add them to the list}

propCnt := pType^.PropCount;

if propCnt > 0then

begin

   AList.Add(EmptyStr);

   tmpStr := IntToStr(propCnt) + ' Propert';

   if propCnt > 1then

     tmpStr := tmpStr + 'ies'

   else

     tmpStr := tmpStr + 'y';

   AList.Add(tmpStr);

   FillChar(tmpStr[1], Length(tmpStr), '-');

   AList.Add(tmpStr);

   {Get memory for the property list}

   GetMem(propList, sizeOf(PPropInfo) * propCnt);

   try

     {Fill in the property list}

     GetPropInfos(pInfo, propList);

     {Fill in info for each property}

     for i := 0to propCnt - 1do

       AList.Add(propList[i].Name+': '+propList[i].PropType^.Name);

   finally

     FreeMem(propList, sizeOf(PPropInfo) * propCnt);

   end;

end;

end;

function GetPropertyList(AControl: TPersistent; AProperty: string): PPropInfo;

var

i: integer;

props: PPropList;

typeData: PTypeData;

begin

Result := nil;

if (AControl = nil) or (AControl.ClassInfo = nil) then

   Exit;

typeData := GetTypeData(AControl.ClassInfo);

if (typeData = nil) or (typeData^.PropCount = 0) then

   Exit;

GetMem(props, typeData^.PropCount * SizeOf(Pointer));

try

   GetPropInfos(AControl.ClassInfo, props);

   for i := 0to typeData^.PropCount - 1do

   begin

     with Props^[i]^ do

       if (Name = AProperty) then

         result := Props^[i];

   end;

finally

   FreeMem(props);

end;

end;

Code:

ListProperties(TProject(treeview1.items[0].data), memo3.lines);

Code:

type

  TProject = class(tComponent)

  private

    FNaam: string;

    procedure SetNaam(const Value: string);

  public

    constructor Create(AOwner: tComponent);

    destructor Destroy;

  published

    property Naam: stringread FNaam write SetNaam;

  end;