uvmt.pas

delphi 写的delphi的程序 Handel is a free, standalone development tool created with Delphi 3 that enable

unit UVMT;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls, TypInfo;

type
  { Published method record }
  PVmtMethod = ^TVmtMethod;
  TVmtMethod = packed record
  {$ifdef WIN32}
    Size: Word;
  {$endif}
    Address: Pointer;
    Name: ShortString;
  end;
  { Published method table }
  PVmtMethodTable = ^TVmtMethodTable;
  TVmtMethodTable = packed record
    Count: Word;
    Methods: array[0..MaxListSize] of Byte;
    { Methods: array[1..Count] of TVmtMethod; }
  end;

  { Field class table }
  PFieldClassTable = ^TFieldClassTable;
  TFieldClassTable = packed record
    Count: Word;
    Classes: packed array[0..MaxListSize] of TClass;
    { Classes: packed array[1..Count] of TClass; }
  end;

  { Published field record }
  PVmtField = ^TVmtField;
  TVmtField = packed record
    Offset: Cardinal;    { Offset of field in the class data. }
    ClassIndex: Word;    { Index in the FieldClassTable. }
    Name: ShortString;
  end;
  { Published field table }
  PVmtFieldTable = ^TVmtFieldTable;
  TVmtFieldTable = packed record
    Count: Word;
    FieldClassTable: {$ifdef WIN32} PFieldClassTable {$else} Word {$endif};
    Fields: packed array[0..MaxListSize] of Byte;
    { Fields: packed array [1..Count] of TVmtField; }
  end;

  { Dynamic method table }
  PVmtDynMethodTable = ^TVmtDynMethodTable;
  TVmtDynMethodTable = packed record
    Count: Word;
    Data: packed array[0..MaxListSize] of Byte;
    { Indexes: packed array[1..Count] of SmallInt;
      Addresses: packed array[1..Count] of Pointer; }
  end;
  PDynIndexes = ^TDynIndexes;
  TDynIndexes = packed array[0..MaxListSize] of SmallInt;
  PDynAddresses = ^TDynAddresses;
  TDynAddresses = packed array[0..MaxListSize] of Pointer;

{$ifndef VER80}
  { Initialization/finalization record }
  PTypeKind = ^TTypeKind;
  PVmtInitTable = ^TVmtInitTable;
  PVmtInitRecord = ^TVmtInitRecord;
  TVmtInitRecord = packed record
    InitTable: PVmtInitTable;
    Offset: Cardinal;   { offset of field in object }
  end;
  PVmtInitArray = ^TVmtInitArray;
  TVmtInitArray = array[0..MaxListSize] of TVmtInitRecord;

  { Initialization/finalization table }
  TVmtInitTable = packed record
    TypeKind: Byte;
    Data: packed array[0..MaxListSize] of Byte;
    { TypeName: ShortString;
      DataSize: Cardinal;
      Count: Cardinal;
      Records: array[1..Count] of TVmtInitRecord; }
  end;

  { OLE Automation Table (see OleAuto.pas) }
const
  { Parameter type masks }
  atTypeMask = $7F;
  atByRef    = $80;
  MaxAutoEntries = 4095;
  MaxAutoParams = 255;

type
  { Mask the type with atTypeMask to get the variant type code,
    e.g., varEmpty..varVariant. The atByRef bit is set when
    the parameter is passed by reference, e.g., VAR. }
  TAutoType = Byte;
  { Automation entry parameter list }
  PAutoParamList = ^TAutoParamList;
  TAutoParamList = packed record
    ReturnType: TAutoType;
    Count: Byte;
    Types: array[0..MaxAutoParams] of TAutoType;
  end;
  { Automation entry flags }
  TVmtAutoFlag = (afMethod, afPropGet, afPropSet, afVirtual);
  TVmtAutoFlags = set of TVmtAutoFlag;
  { Automation table entry }
  PVmtAutoEntry = ^TVmtAutoEntry;
  TVmtAutoEntry = packed record
    DispID: Integer;
    Name: PShortString;
    Flags: Integer; { Lower byte is TVmtAutoFlags }
    Params: PAutoParamList;
    Address: Pointer;
  end;

  { Automation table layout }
  PVmtAutoTable = ^TVmtAutoTable;
  TVmtAutoTable = packed record
    Count: Integer;
    Entries: array[0..MaxAutoEntries] of TVmtAutoEntry;
  end;
{$endif}

  { Virtual Method Table }
  PVmt = ^TVmt;
  TVmt = record
    AutoTable:    PVmtAutoTable;
    InitTable:    PVmtInitTable;
    TypeInfo:       PTypeInfo         ;
    FieldTable:     PVmtFieldTable    ;
    MethodTable:    PVmtMethodTable   ;
    DynMethodTable: PVmtDynMethodTable;
    ClassName:      PShortString      ;
    InstanceSize:   Cardinal;
    ClassParent:    TClass;
    SafecallException: Pointer;
    DefaultHandler: Pointer; { These four hidden fields point to }
    NewInstance:    Pointer; { special virtual methods that are }
    FreeInstance:   Pointer; { inherited from TObject. }
    Destroy:        Pointer;
    { Here begin the virtual method pointers.
      Each virtual method is stored as a code pointer, e.g.,
      VirtualMethodTable: array[0..Count] of Pointer; }
  end;

  TMethodFunc = function(const Vmt: TVmt; const Method: TVmtMethod;
                         Data: Pointer): Boolean;
  TVmtFlag = (vmtBaseClasses);
  TVmtFlags = set of TVmtFlag;
  TFieldFunc = function(const Vmt: TVmt; const Field: TVmtField;
                        Data: Pointer): Boolean;
type
  TVMTForm = class(TForm)
    Panel1: TPanel;
    Splitter1: TSplitter;
    Panel2: TPanel;
    Label1: TLabel;
    lbComponent: TListBox;
    Label2: TLabel;
    lbClass: TListBox;
    Button1: TButton;
    VMTMemo: TMemo;
    Label3: TLabel;
    procedure FormShow(Sender: TObject);
    procedure lbClassClick(Sender: TObject);
    procedure lbComponentClick(Sender: TObject);
  private
    { Private declarations }
    procedure WriteVmtInfo(ClassType: TClass);
    procedure FmtLn(const Fmt: string; Args: array of const);
    procedure WriteDynMethods(Vmt: PVmt);
    procedure WriteFields(Table: PVmtFieldTable);
    procedure WriteMethods(Table: PVmtMethodTable);
    procedure WriteFieldClasses(Table: PFieldClassTable);
    procedure WriteObjInfo(Obj: TObject);
  public
    { Public declarations }
  end;

var
  VMTForm: TVMTForm;

implementation

uses utype, uconst;

{$R *.DFM}

procedure TVMTForm.FormShow(Sender: TObject);
var
  I: Integer;
  Name, CName: string;
begin
   Caption:= 'VMT Information about ' + ProxyDesigner.Form.Name;
   with ProxyDesigner.Form do
   begin
      for I:= 0 to ComponentCount - 1 do
      begin
         Name:= Components[I].Name;
         CName:= Components[I].ClassName;
         if Name <> '' then lbComponent.Items.AddObject(Name, Components[I]);
         if lbClass.Items.IndexOf(CName) = -1 then
            lbClass.Items.AddObject(CName, Components[I]);
      end;
   end;
   lbComponent.Items.AddObject(ProxyDesigner.Form.ClassName, ProxyDesigner.Form);
end;

procedure TVMTForm.FmtLn(const Fmt: string; Args: array of const);
begin
  VMTMemo.Lines.Add(Format(Fmt, Args));
end;

procedure TVMTForm.WriteVmtInfo(ClassType: TClass);
var
  Vmt: PVmt;
begin
  Vmt := PVmt(ClassType);
  Dec(Vmt, 1);
  FmtLn('VMT=%p', [Vmt]);
  FmtLn('  Destroy = %p', [Vmt^.Destroy]);
  FmtLn('  FreeInstance = %p', [Vmt^.FreeInstance]);
  FmtLn('  NewInstance = %p', [Vmt^.NewInstance]);
  FmtLn('  DefaultHandler = %p', [Vmt^.DefaultHandler]);
  FmtLn('  InstanceSize = %d', [Vmt^.InstanceSize]);
  if Vmt^.ClassParent = nil then
    FmtLn('  ClassParent=nil', [''])
  else
    FmtLn('  ClassParent=%s (%p)', [ClassType.ClassParent.ClassName, Pointer(Vmt^.ClassParent)]);
  FmtLn('  ClassName = %s', [Vmt^.ClassName^]);

  FmtLn('  ClassInfo = %p', [Vmt^.TypeInfo]);
  FmtLn('  DynMethodTable = %p', [Vmt^.DynMethodTable]);
  if Vmt^.DynMethodTable <> Nil then WriteDynMethods(Vmt);

 { FmtLn('  MethodTable = %p', [Vmt^.MethodTable]);
  if Vmt^.MethodTable <> Nil then WriteMethods(GetMethodTable(Vmt));

  FmtLn('  FieldTable = %p', [Vmt^.FieldTable]);
  if Vmt^.FieldTable <> Nil then  WriteFields(GetFieldTable(Vmt));
 }
{$ifdef Delphi2}
  FmtLn('  InitTable = %p', [Vmt^.InitTable]);
  if Vmt^.InitTable <> nil then
    WriteInitTable(GetInitTable(Vmt));

  FmtLn('  AutoTable = %p', [Vmt^.AutoTable]);
  if Vmt^.AutoTable <> nil then
    WriteAutoTable(GetAutoTable(Vmt));
{$endif}

{$ifdef Delphi3}
 { FmtLn('  IntfTable=%p', [Vmt^.IntfTable]);
  if Vmt^.IntfTable <> nil then
    WriteIntfTable(Vmt^.IntfTable);
  FmtLn('  SelfPtr=%p', [Pointer(Vmt^.SelfPtr)]);}
{$endif}
end;

procedure TVMTForm.WriteDynMethods(Vmt: PVmt);
var
  I: Integer;
  Indexes: PDynIndexes;
  Addresses: PDynAddresses;
  Table: PVmtDynMethodTable;
begin
 { Table := GetDynMethodTable(Vmt);
  FmtLn('    Count: %d', [Table^.Count]);
  Indexes := GetDynIndexes(Table);
  Addresses := GetDynAddresses(Table);
  for I := 0 to Table^.Count-1 do
  begin
    if Indexes^[I] and $F000 = $F000 then
      FmtLn('    Dyn Method %d=%p (%d)', [I, Addresses^[I], Indexes^[I]])
    else
      FmtLn('    Dyn Method %d=%p (%4.4x)', [I, Addresses^[I], Word(Indexes^[I])]);
  end;}
end;

procedure TVMTForm.WriteMethods(Table: PVmtMethodTable);
var
  I: Integer;
  Meth: PVmtMethod;
  Ptr: PByte;
begin
 { WriteLn('    Count: ', Table^.Count);
  Ptr := PByte(@Table^.Methods);
  for I := 1 to Table^.Count do
  begin
    Meth := PVmtMethod(Ptr);
    with Meth^ do
    begin
      Inc(Ptr, GetMethodSize(Meth^));
      FmtLn('    Method %d=%s at %p', [I, Name, Address]);
    end;
  end;}
end;

procedure TVMTForm.WriteFieldClasses(Table: PFieldClassTable);
var
  I: Integer;
begin
  with Table^ do
  begin
    WriteLn('      Count: ', Count);
    for I := 0 to Count-1 do
      FmtLn('      Class %d: %s (%p)', [I, Classes[I].ClassName, Pointer(Classes[I])]);
  end;
end;

procedure TVMTForm.WriteFields(Table: PVmtFieldTable);
var
  I: Integer;
  Ptr: PByte;
  Fld: PVmtField;
  FldClass: PFieldClassTable;
begin
 { WriteLn('    Count: ', Table^.Count);
  FmtLn('    Field class table: %p', [Table^.FieldClassTable]);
  FldClass := Table^.FieldClassTable;
  if FldClass <> nil then
    WriteFieldClasses(FldClass);

  Ptr := PByte(@Table^.Fields);
  for I := 1 to Table^.Count do
  begin
    Fld := PVmtField(Ptr);
    Inc(Ptr, GetFieldSize(Fld^));
    with Fld^ do
      FmtLn('    Field %d=%s: %s (Ofs=%d, Idx=%d)',
        [I, Name, GetFieldClass(FldClass^, Fld^).ClassName, Offset, ClassIndex]);
  end; }
end;


procedure TVMTForm.lbClassClick(Sender: TObject);
begin
   if lbClass.ItemIndex = -1 then Exit;
   VMTMemo.Clear;
   WriteVmtInfo((lbClass.Items.Objects[lbClass.ItemIndex]).ClassType);
end;

procedure TVMTForm.lbComponentClick(Sender: TObject);
begin
   if lbComponent.ItemIndex = -1 then Exit;
   WriteObjInfo((lbComponent.Items.Objects[lbComponent.ItemIndex]));
end;

procedure TVMTForm.WriteObjInfo(Obj: TObject);
type
  PMethod = ^TMethod;
begin
  VMTMemo.Clear;
  FmtLn('@Obj=%p', [Pointer(Obj)]);
  FmtLn('  ClassType=%p', [Pointer(Obj.ClassType)]);
  FmtLn('  ClassParent=%p', [Pointer(Obj.ClassParent)]);
  FmtLn('  ClassInfo=%p', [Pointer(Obj.ClassInfo)]);
  FmtLn('  InstanceSize=%d', [Obj.InstanceSize]);

  WriteVmtInfo(Obj.ClassType);
end;

end.