unit ClaForm;

interface

uses
  SysUtils, Classes, Graphics, Controls, Forms,
  StdCtrls, ExtCtrls, Buttons, Clipbrd, Comctrls, Db, Dbcgrids,
  Dbctrls, Dbgrids, Dblookup, DbTables, Ddeman, Dialogs,
  Filectrl, Grids, Mask, Menus, Mplayer, Olectnrs,
  Outline, Tabnotbk, Tabs, IniFiles, Printers,
  Registry, DsgnIntf, TypInfo;

type
  TForm1 = class(TForm)
    Listbox1: TListBox;
    ListBox2: TListBox;
    Splitter1: TSplitter;
    procedure Listbox1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure ListBox2Click(Sender: TObject);
  public
    procedure AddType (pti: PTypeInfo);
  end;

  procedure ShowClass (pti: PTypeInfo; sList: TStrings);
  // repeated from TypInfo.Pas
  procedure SortPropList(PropList: PPropList; PropCount: Integer);

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Listbox1Click(Sender: TObject);
var
  pti: PTypeInfo;
begin
  pti := PTypeInfo (ListBox1.Items.Objects [
    Listbox1.ItemIndex]);
  ListBox2.Items.Clear;
  Caption := 'RTTI information for ' +
    ListBox1.Items [Listbox1.ItemIndex];
  ShowClass (pti, ListBox2.Items);
end;

// show RTTI information for class type
procedure ShowClass (pti: PTypeInfo; sList: TStrings);
var
  ptd: PTypeData;
  ppi: PPropInfo;
  pProps: PPropList;
  nProps, I: Integer;
  ParentClass: TClass;
begin
  // protect against misuse
  if pti^.Kind <> tkClass then
    raise Exception.Create ('Invalid type information');

  // get a pointer to the TTypeData structure
  ptd := GetTypeData (pti);

  // access the TTypeInfo structure
  sList.Add ('Type Name: ' + pti^.Name);
  sList.Add ('Type Kind: ' + GetEnumName (
    TypeInfo (TTypeKind),
    Integer (pti^.Kind)));

  // access the TTypeData structure
  {omitted: the same information of pti^.Name...
  sList.Add ('ClassType: ' + ptd^.ClassType.ClassName);}
  sList.Add ('Size: ' + IntToStr (
    ptd^.ClassType.InstanceSize) + ' bytes');
  sList.Add ('Defined in: ' + ptd^.UnitName + '.pas');

  // add the list of parent classes (if any)
  ParentClass := ptd^.ClassType.ClassParent;
  if ParentClass <> nil then
  begin
    sList.Add ('');
    sList.Add ('=== Parent classes ===');
    while ParentClass <> nil do
    begin
      sList.Add (ParentClass.ClassName);
      ParentClass := ParentClass.ClassParent;
    end;
  end;

  // add the list of properties (if any)
  nProps := ptd^.PropCount;
  if nProps > 0 then
  begin
    // format the initial output
    sList.Add ('');
    sList.Add ('=== Properties (' +
      IntToStr (nProps) + ') ===');
    // allocate the required memory
    GetMem (pProps, sizeof (PPropInfo) * nProps);
    // protect the memory allocation
    try
      // fill the TPropList structure
      // pointed to by pProps
      GetPropInfos(pti, pProps);
      // sort the properties
      SortPropList(pProps, nProps);
      // show name and data type of each property
      for I := 0 to nProps - 1 do
      begin
        ppi := pProps [I];
        sList.Add (ppi.Name + ': ' +
          ppi.PropType^.Name);
      end;
    finally
      // free the allocated memmory
      FreeMem (pProps, sizeof (PPropInfo) * nProps);
    end;
  end;
end;

procedure TForm1.AddType (pti: PTypeInfo);
begin
  ListBox1.Items.AddObject(pti.Name, TObject (pti));
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  // add classes to the first listbox
  AddType (TypeInfo (TApplication));
  AddType (TypeInfo (TAutoIncField));
  AddType (TypeInfo (TBatchMove));
  AddType (TypeInfo (TBCDField));
  AddType (TypeInfo (TBevel));
  AddType (TypeInfo (TBitBtn));
  AddType (TypeInfo (TBitmap));
  AddType (TypeInfo (TBlobField));
  AddType (TypeInfo (TBlobStream));
  AddType (TypeInfo (TBooleanField));
  AddType (TypeInfo (TBrush));
  AddType (TypeInfo (TButton));
  AddType (TypeInfo (TButtonControl));
  AddType (TypeInfo (TBytesField));
  AddType (TypeInfo (TCanvas));
  AddType (TypeInfo (TCaptionProperty));
  AddType (TypeInfo (TChangeLink));
  AddType (TypeInfo (TCharProperty));
  AddType (TypeInfo (TCheckBox));
  AddType (TypeInfo (TClassProperty));
  AddType (TypeInfo (TClipboard));
  AddType (TypeInfo (TCollection));
  AddType (TypeInfo (TCollectionItem));
  AddType (TypeInfo (TColorDialog));
  AddType (TypeInfo (TColorProperty));
  AddType (TypeInfo (TColumn));
  AddType (TypeInfo (TColumnTitle));
  AddType (TypeInfo (TComboBox));
  AddType (TypeInfo (TCommonDialog));
  AddType (TypeInfo (TComponent));
  AddType (TypeInfo (TComponentEditor));
  AddType (TypeInfo (TComponentList));
  AddType (TypeInfo (TComponentProperty));
  AddType (TypeInfo (TControl));
  AddType (TypeInfo (TControlCanvas));
  AddType (TypeInfo (TControlScrollBar));
  AddType (TypeInfo (TCurrencyField));
  AddType (TypeInfo (TCursorProperty));
  AddType (TypeInfo (TCustomCheckBox));
  AddType (TypeInfo (TCustomComboBox));
  AddType (TypeInfo (TCustomControl));
  AddType (TypeInfo (TCustomEdit));
  AddType (TypeInfo (TCustomGrid));
  AddType (TypeInfo (TCustomGroupBox));
  AddType (TypeInfo (TCustomLabel));
  AddType (TypeInfo (TCustomListBox));
  AddType (TypeInfo (TCustomMaskEdit));
  AddType (TypeInfo (TCustomMemo));
  AddType (TypeInfo (TCustomMemoryStream));
  AddType (TypeInfo (TCustomOutline));
  AddType (TypeInfo (TCustomPanel));
  AddType (TypeInfo (TCustomRadioGroup));
  AddType (TypeInfo (TDatabase));
  AddType (TypeInfo (TDataSource));
  AddType (TypeInfo (TDateField));
  AddType (TypeInfo (TDateTimeField));
  AddType (TypeInfo (TDBCheckBox));
  AddType (TypeInfo (TDBComboBox));
  AddType (TypeInfo (TDBCtrlGrid));
  AddType (TypeInfo (TDBEdit));
  AddType (TypeInfo (TDBGrid));
  AddType (TypeInfo (TDBImage));
  AddType (TypeInfo (TDBListBox));
  AddType (TypeInfo (TDBLookupCombo));
  AddType (TypeInfo (TDBLookupList));
  AddType (TypeInfo (TDBLookupListBox));
  AddType (TypeInfo (TDBMemo));
  AddType (TypeInfo (TDBNavigator));
  AddType (TypeInfo (TDBRadioGroup));
  AddType (TypeInfo (TDBText));
  AddType (TypeInfo (TDDEClientConv));
  AddType (TypeInfo (TDDEClientItem));
  AddType (TypeInfo (TDDEServerConv));
  AddType (TypeInfo (TDDEServerItem));
  AddType (TypeInfo (TDefaultEditor));
  AddType (TypeInfo (TDesigner));
  AddType (TypeInfo (TDirectoryListBox));
  AddType (TypeInfo (TDragControlObject));
  AddType (TypeInfo (TDragObject));
  AddType (TypeInfo (TDrawGrid));
  AddType (TypeInfo (TDriveComboBox));
  AddType (TypeInfo (TEdit));
  AddType (TypeInfo (TEnumProperty));
  AddType (TypeInfo (TField));
  AddType (TypeInfo (TFieldDef));
  AddType (TypeInfo (TFieldDefs));
  AddType (TypeInfo (TFileListBox));
  AddType (TypeInfo (TFiler));
  AddType (TypeInfo (TFileStream));
  AddType (TypeInfo (TFilterComboBox));
  AddType (TypeInfo (TFindDialog));
  AddType (TypeInfo (TFloatField));
  AddType (TypeInfo (TFloatProperty));
  AddType (TypeInfo (TFont));
  AddType (TypeInfo (TFontDialog));
  AddType (TypeInfo (TFontNameProperty));
  AddType (TypeInfo (TFontProperty));
  AddType (TypeInfo (TForm));
  AddType (TypeInfo (TFormDesigner));
  AddType (TypeInfo (TGraphic));
  AddType (TypeInfo (TGraphicControl));
  AddType (TypeInfo (TGraphicField));
  AddType (TypeInfo (TGraphicsObject));
  AddType (TypeInfo (TGroupBox));
  AddType (TypeInfo (THandleStream));
  AddType (TypeInfo (THeader));
  AddType (TypeInfo (THeaderControl));
  AddType (TypeInfo (THeaderSection));
  AddType (TypeInfo (THeaderSections));
  AddType (TypeInfo (THintWindow));
  AddType (TypeInfo (THotKey));
  AddType (TypeInfo (TIcon));
  AddType (TypeInfo (TIconOptions));
  AddType (TypeInfo (TImage));
  AddType (TypeInfo (TImage));
  AddType (TypeInfo (TImageList));
  AddType (TypeInfo (TIndexDef));
  AddType (TypeInfo (TIndexDefs));
  AddType (TypeInfo (TIniFile));
  AddType (TypeInfo (TInplaceEdit));
  AddType (TypeInfo (TIntegerField));
  AddType (TypeInfo (TIntegerProperty));
  AddType (TypeInfo (TLabel));
  AddType (TypeInfo (TList));
  AddType (TypeInfo (TListBox));
  AddType (TypeInfo (TListColumn));
  AddType (TypeInfo (TListItem));
  AddType (TypeInfo (TListItems));
  AddType (TypeInfo (TListView));
  AddType (TypeInfo (TMainMenu));
  AddType (TypeInfo (TMaskEdit));
  AddType (TypeInfo (TMediaPlayer));
  AddType (TypeInfo (TMemo));
  AddType (TypeInfo (TMemoField));
  AddType (TypeInfo (TMemoryStream));
  AddType (TypeInfo (TMenu));
  AddType (TypeInfo (TMenuItem));
  AddType (TypeInfo (TMetafile));
  AddType (TypeInfo (TMetafileCanvas));
  AddType (TypeInfo (TMethodProperty));
  AddType (TypeInfo (TModalResultProperty));
  AddType (TypeInfo (TMPFileNameProperty));
  AddType (TypeInfo (TNotebook));
  AddType (TypeInfo (TNotebook));
  AddType (TypeInfo (TObject));
  AddType (TypeInfo (TOleContainer));
  AddType (TypeInfo (TOpenDialog));
  AddType (TypeInfo (TOrdinalProperty));
  AddType (TypeInfo (TOutline));
  AddType (TypeInfo (TOutlineNode));
  AddType (TypeInfo (TPageControl));
  AddType (TypeInfo (TPaintBox));
  AddType (TypeInfo (TPanel));
  AddType (TypeInfo (TParaAttributes));
  AddType (TypeInfo (TParam));
  AddType (TypeInfo (TParams));
  AddType (TypeInfo (TPen));
  AddType (TypeInfo (TPersistent));
  AddType (TypeInfo (TPicture));
  AddType (TypeInfo (TPopupMenu));
  AddType (TypeInfo (TPrintDialog));
  AddType (TypeInfo (TPrinter));
  AddType (TypeInfo (TPrinterSetupDialog));
  AddType (TypeInfo (TProgressBar));
  AddType (TypeInfo (TPropertyEditor));
  AddType (TypeInfo (TQuery));
  AddType (TypeInfo (TRadioButton));
  AddType (TypeInfo (TRadioGroup));
  AddType (TypeInfo (TReader));
  AddType (TypeInfo (TRegIniFile));
  AddType (TypeInfo (TRegistry));
  AddType (TypeInfo (TReplaceDialog));
  AddType (TypeInfo (TResourceStream));
  AddType (TypeInfo (TRichEdit));
  AddType (TypeInfo (TSaveDialog));
  AddType (TypeInfo (TScreen));
  AddType (TypeInfo (TScrollBar));
  AddType (TypeInfo (TScrollBox));
  AddType (TypeInfo (TScrollingWinControl));
  AddType (TypeInfo (TSession));
  AddType (TypeInfo (TSetElementProperty));
  AddType (TypeInfo (TSetProperty));
  AddType (TypeInfo (TShape));
  AddType (TypeInfo (TShape));
  AddType (TypeInfo (TShortCutProperty));
  AddType (TypeInfo (TSmallIntField));
  AddType (TypeInfo (TSpeedButton));
  AddType (TypeInfo (TStatusBar));
  AddType (TypeInfo (TStatusPanel));
  AddType (TypeInfo (TStatusPanels));
  AddType (TypeInfo (TStoredProc));
  AddType (TypeInfo (TStream));
  AddType (TypeInfo (TStringField));
  AddType (TypeInfo (TStringList));
  AddType (TypeInfo (TStringProperty));
  AddType (TypeInfo (TStrings));
  AddType (TypeInfo (TStringGrid));
  AddType (TypeInfo (TTabbedNotebook));
  AddType (TypeInfo (TTabControl));
  AddType (TypeInfo (TTable));
  AddType (TypeInfo (TTabOrderProperty));
  AddType (TypeInfo (TTabSet));
  AddType (TypeInfo (TTabSheet));
  AddType (TypeInfo (TTextAttributes));
  AddType (TypeInfo (TThread));
  AddType (TypeInfo (TTimeField));
  AddType (TypeInfo (TTimer));
  AddType (TypeInfo (TTrackBar));
  AddType (TypeInfo (TTreeNode));
  AddType (TypeInfo (TTreeNodes));
  AddType (TypeInfo (TTreeView));
  AddType (TypeInfo (TUpdateSQL));
  AddType (TypeInfo (TUpDown));
  AddType (TypeInfo (TVarBytesField));
  AddType (TypeInfo (TWinControl));
  AddType (TypeInfo (TWordField));
  AddType (TypeInfo (TWriter));
  AddType (TypeInfo (Exception));
  AddType (TypeInfo (EAbort));
  AddType (TypeInfo (EAccessViolation));
  AddType (TypeInfo (EControlC));
  AddType (TypeInfo (EConvertError));
  AddType (TypeInfo (EDivByZero));
  AddType (TypeInfo (EExternalException));
  AddType (TypeInfo (EInOutError));
  AddType (TypeInfo (EIntError));
  AddType (TypeInfo (EIntOverFlow));
  AddType (TypeInfo (EInvalidCast));
  AddType (TypeInfo (EInvalidOp));
  AddType (TypeInfo (EInvalidPointer));
  AddType (TypeInfo (EMathError));
  AddType (TypeInfo (EOutOfMemory));
  AddType (TypeInfo (EOverflow));
  AddType (TypeInfo (EPrivilege));
  AddType (TypeInfo (EPropReadOnly));
  AddType (TypeInfo (EPropWriteOnly));
  AddType (TypeInfo (ERangeError));
  AddType (TypeInfo (EStackOverflow));
  AddType (TypeInfo (EUnderflow));
  AddType (TypeInfo (EVariantError));
  AddType (TypeInfo (EZeroDivide));
end;

// code extracted from TypInfo.pas
procedure SortPropList(PropList: PPropList; PropCount: Integer); assembler;
asm
        { ->    EAX Pointer to prop list        }
        {       EDX Property count              }
        { <-    nothing                         }

        PUSH    EBX
        PUSH    ESI
        PUSH    EDI
        MOV     ECX,EAX
        XOR     EAX,EAX
        DEC     EDX
        CALL    @@qsort
        POP     EDI
        POP     ESI
        POP     EBX
        JMP     @@exit

@@qsort:
        PUSH    EAX
        PUSH    EDX
        LEA     EDI,[EAX+EDX]           { pivot := (left + right) div 2 }
        SHR     EDI,1
        MOV     EDI,[ECX+EDI*4]
        ADD     EDI,OFFSET TPropInfo.Name
@@repeat:                               { repeat                        }
@@while1:
        CALL    @@compare               { while a[i] < a[pivot] do inc(i);}
        JAE     @@endWhile1
        INC     EAX
        JMP     @@while1
@@endWhile1:
        XCHG    EAX,EDX
@@while2:
        CALL    @@compare               { while a[j] > a[pivot] do dec(j);}
        JBE     @@endWhile2
        DEC     EAX
        JMP     @@while2
@@endWhile2:
        XCHG    EAX,EDX
        CMP     EAX,EDX                 { if i <= j then begin          }
        JG      @@endRepeat
        MOV     EBX,[ECX+EAX*4]         { x := a[i];                    }
        MOV     ESI,[ECX+EDX*4]         { y := a[j];                    }
        MOV     [ECX+EDX*4],EBX         { a[j] := x;                    }
        MOV     [ECX+EAX*4],ESI         { a[i] := y;                    }
        INC     EAX                     { inc(i);                       }
        DEC     EDX                     { dec(j);                       }
                                        { end;                          }
        CMP     EAX,EDX                 { until i > j;                  }
        JLE     @@repeat

@@endRepeat:
        POP     ESI
        POP     EBX

        CMP     EAX,ESI
        JL      @@rightNonEmpty         { if i >= right then begin      }
        CMP     EDX,EBX
        JG      @@leftNonEmpty1         { if j <= left then exit        }
        RET

@@leftNonEmpty1:
        MOV     EAX,EBX
        JMP     @@qsort                 { qsort(left, j)                }

@@rightNonEmpty:
        CMP     EAX,EBX
        JG      @@leftNonEmpty2
        MOV     EDX,ESI                 { qsort(i, right)               }
        JMP     @@qsort
@@leftNonEmpty2:
        PUSH    EAX
        PUSH    ESI
        MOV     EAX,EBX
        CALL    @@qsort                 { qsort(left, j)                }
        POP     EDX
        POP     EAX
        JMP     @@qsort                 { qsort(i, right)               }

@@compare:
        PUSH    EAX
        PUSH    EDI
        MOV     ESI,[ECX+EAX*4]
        ADD     ESI,OFFSET TPropInfo.Name
        PUSH    ESI
        XOR     EBX,EBX
        MOV     BL,[ESI]
        INC     ESI
        CMP     BL,[EDI]
        JBE     @@firstLenSmaller
        MOV     BL,[EDI]
@@firstLenSmaller:
        INC     EDI
        TEST    BL,BL
        JE      @@endLoop
@@loop:
        MOV     AL,[ESI]
        MOV     AH,[EDI]
        AND     EAX,$DFDF
        CMP     AL,AH
        JNE     @@difference
        INC     ESI
        INC     EDI
        DEC     EBX
        JNZ     @@loop
@@endLoop:
        POP     ESI
        POP     EDI
        MOV     AL,[ESI]
        MOV     AH,[EDI]
        CMP     AL,AH
        POP     EAX
        RET
@@difference:
        POP     ESI
        POP     EDI
        POP     EAX
        RET
@@exit:
end;

procedure TForm1.ListBox2Click(Sender: TObject);
var
  Text: string;
  Index: Integer;
  pti: PTypeInfo;
begin
  // get the current item
  Text := ListBox2.Items [ListBox2.ItemIndex];
  // search the first listbox
  Index := ListBox1.Items.IndexOf (Text);
  // if found, it was a parent class: show RTTI
  if Index >= 0 then
  begin
    pti := PTypeInfo (ListBox1.Items.Objects [Index]);
    Caption := 'RTTI information for ' + Text;
    ListBox2.Items.Clear;
    ShowClass (pti, ListBox2.Items);
  end;
end;

end.