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.
|
Вывести информацию о классах
