unit VMTUtils;

interface

uses
  SysUtils, Classes, TypInfo;

type
  EVMTError = class(Exception);

{ virtual methods methods }
function GetVirtualMethodCount(AClass: TClass): Integer;
function GetVirtualMethod(AClass: TClass; const Index: Integer): Pointer;
procedure SetVirtualMethod(AClass: TClass; const Index: Integer; const Method: Pointer);

{ dynamic methods methods }
type
  TDynamicIndexList = array[0..High(Word)] of Word;
  PDynamicIndexList = ^TDynamicIndexList;
  TDynamicAddressList = array[0..High(Word)] of pointer;
  PDynamicAddressList = ^TDynamicAddressList;

function GetDynamicMethodCount(AClass: TClass): Integer;
function GetDynamicIndexList(AClass: TClass): PDynamicIndexList;
function GetDynamicAddressList(AClass: TClass): PDynamicAddressList;
function HasDynamicMethod(AClass: TClass; Index: Integer): Boolean;

{ init table methods }
function GetInitTable(AClass: TClass): PTypeInfo;

{ field table methods }

type
  PFieldEntry = ^TFieldEntry;
  TFieldEntry = packed record
    OffSet: Integer;
    IDX: Word;
    Name: ShortString;
  end;

  PFieldClassTable = ^TFieldClassTable;
  TFieldClassTable = packed record
    Count: Smallint;
    Classes: array[0..8191] of ^TPersistentClass;
  end;

  PFieldTable = ^TFieldTable;
  TFieldTable = packed record
    EntryCount: Word;
    FieldClassTable: PFieldClassTable;
    FirstEntry: TFieldEntry;
   {Entries: array[1..65534] of TFieldEntry;}
  end;

function GetFieldTable(AClass: TClass): PFieldTable;

{ method table }

type
  PMethodEntry = ^TMethodEntry;
  TMethodEntry = packed record
    EntrySize: Word;
    Address: Pointer;
    Name: ShortString;
  end;

  PMethodTable = ^TMethodTable;
  TMethodTable = packed record
    Count: Word;
    FirstEntry: TMethodEntry;
   {Entries: array[1..65534] of TMethodEntry;}
  end;

function GetMethodTable(AClass: TClass): PMethodTable;
function GetMethodEntry(MethodTable: PMethodTable; Index: Integer): PMethodEntry;

{ class parent methods }
procedure SetClassParent(AClass: TClass; NewClassParent: TClass);
function GetClassParent(AClass: TClass): TClass;

function IsClass(Address: Pointer): Boolean;

implementation

uses
  Windows;

resourcestring
  SMemoryWriteError = 'Error writing VMT memory (%s).';
  STypeInfoError = 'Error reading type info.';

type
  PLongint= ^Longint;
  PPointer = ^Pointer;

function GetVirtualMethodCount(AClass: TClass): Integer;
var
  BeginVMT: Longint;
  EndVMT: Longint;
  TablePointer: Longint;
  I: Integer;
begin
  BeginVMT := Longint(AClass);

  // Scan the offset entries in the class table for the various fields,
  // namely vmtIntfTable, vmtAutoTable, ..., vmtDynamicTable
  // The last entry is always the vmtClassName, so stop once we got there
  //
  // This assumes that all these tables come after each other, basically:
  //P: Wrong: They don't come after each other, you have to scan them all.
  //
  //    First VMT table entry         (pointed to by vmtSelfPtr = -76)
  //        ...
  //    Last VMT table entry
  //    First IntfTable table entry   (pointed to by vmtIntfTable = -72)
  //        ...
  //    Last IntfTable table entry
  //    First AutoTable table entry   (pointed to by vmtAutoTable = - 68)
  //        ...
  //    Last AutoTable table entry
  // ...
  //    ClassName ShortString         (pointed to by vmtClassName = -44)
  //

  EndVMT := PLongint(LongInt(AClass) + vmtClassName)^;
  // Set iterator to first item behind VMT table pointer
  I := vmtSelfPtr + SizeOf(Pointer);
  repeat
    TablePointer := PLongint(Longint(AClass) + I)^;
    if (TablePointer <> 0) and (TablePointer >= BeginVMT) and
       (TablePointer < EndVMT) then
    begin
      EndVMT := Longint(TablePointer);
//      Break;
    end;
    Inc(I, SizeOf(Pointer));
  until I >= vmtClassName;

  //P: In case we don't have a class name?
{  if EndVMT = 0 then
    raise EVMTError.Create(SErrorRetrievingVmtCount);}

  Result := (EndVMT - BeginVMT) div SizeOf(Pointer);
end;

function GetVirtualMethod(AClass: TClass; const Index: Integer): Pointer;
begin
  Result := PPointer(Integer(AClass) + Index * SizeOf(Pointer))^;
end;

procedure SetVirtualMethod(AClass: TClass; const Index: Integer; const Method: Pointer);
var
  WrittenBytes: DWORD;
  PatchAddress: Pointer;
begin
  PatchAddress := PPointer(Integer(AClass) + Index * SizeOf(Pointer))^;

  //! StH: WriteProcessMemory IMO is not exactly the politically correct approach;
  // better VirtualProtect, direct patch, VirtualProtect
  if not WriteProcessMemory( GetCurrentProcess,
                             PatchAddress, @Method,
                             SizeOf(Pointer), WrittenBytes) then
  begin
    raise EVMTError.CreateFmt(SMemoryWriteError, [SysErrorMessage(GetLastError)]);
  end;

  if WrittenBytes <> SizeOf(Pointer) then
    raise EVMTError.CreateFmt(SMemoryWriteError, [IntToStr(WrittenBytes)]);

  // make sure that everything keeps working in a dual processor setting
  FlushInstructionCache(GetCurrentProcess, PatchAddress, SizeOf(Pointer));
end;

{ Dynamic method routines }

type
  TvmtDynamicTable = packed record
    Count: Word;
   {IndexList: array[1..Count] of Word;
    AddressList: array[1..Count] of Pointer;}
  end;

function GetDynamicMethodCount(AClass: TClass): Integer;
asm
       MOV     EAX, [EAX].vmtDynamicTable
       TEST    EAX, EAX
       JE      @@exit
       MOVZX   EAX, Word ptr [EAX]
@@exit:
end;

function GetDynamicIndexList(AClass: TClass): PDynamicIndexList;
asm
       MOV      EAX, [EAX].vmtDynamicTable
       ADD      EAX, 2
end;

function GetDynamicAddressList(AClass: TClass): PDynamicAddressList;
asm
       MOV      EAX, [EAX].vmtDynamicTable
       MOVZX    EDX, Word ptr [EAX]
       ADD      EAX, EDX
       ADD      EAX, EDX
       ADD      EAX, 2
end;

function HasDynamicMethod(AClass: TClass; Index: Integer): Boolean;
asm
        { ->    EAX     vmt of class            }
        {       DX      dynamic method index    }

        PUSH    EDI
        XCHG    EAX,EDX
        JMP     @@haveVMT
@@outerLoop:
        MOV     EDX,[EDX]
@@haveVMT:
        MOV     EDI,[EDX].vmtDynamicTable
        TEST    EDI,EDI
        JE      @@parent
        MOVZX   ECX,word ptr [EDI]
        PUSH    ECX
        ADD     EDI,2
        REPNE   SCASW
        JE      @@found
        POP     ECX
@@parent:
        MOV     EDX,[EDX].vmtParent
        TEST    EDX,EDX
        JNE     @@outerLoop
        MOV     EAX, 0
        JMP     @@exit

@@found:
        POP     EAX
        MOV     EAX, 1
@@exit:
        POP     EDI
end;

{ Interface table methods }

{ Init table methods }

function GetInitTable(AClass: TClass): PTypeInfo;
asm
       MOV    EAX, [EAX].vmtInitTable
end;

{ Field Table methods }

function GetFieldTable(AClass: TClass): PFieldTable;
asm
      MOV     EAX, [EAX].vmtFieldTable
end;

{ Method Table }

function GetMethodTable(AClass: TClass): PMethodTable;
asm
        MOV     EAX, [EAX].vmtMethodTable
end;

function GetMethodEntry(MethodTable: PMethodTable; Index: Integer): PMethodEntry;
begin
  Result := Pointer(Cardinal(MethodTable) +2);
  for Index := Index downto 1 do
    Inc(Cardinal(Result), Result^.EntrySize);
end;

{ Class Parent methods }

procedure SetClassParent(AClass: TClass; NewClassParent: TClass);
var
  WrittenBytes: DWORD;
  PatchAddress: Pointer;
begin
  PatchAddress := PPointer(Integer(AClass) + vmtParent)^;

  //! StH: WriteProcessMemory IMO is not exactly the politically correct approach;
  // better VirtualProtect, direct patch, VirtualProtect
  if not WriteProcessMemory( GetCurrentProcess,
                             PatchAddress, @NewClassParent,
                             SizeOf(Pointer), WrittenBytes) then
  begin
    raise EVMTError.CreateFmt(SMemoryWriteError, [SysErrorMessage(GetLastError)]);
  end;

  if WrittenBytes <> SizeOf(Pointer) then
    raise EVMTError.CreateFmt(SMemoryWriteError, [IntToStr(WrittenBytes)]);

  // make sure that everything keeps working in a dual processor setting
  FlushInstructionCache(GetCurrentProcess, PatchAddress, SizeOf(Pointer));
end;

function GetClassParent(AClass: TClass): TClass;
begin
  Result := TClass(PPointer(Integer(AClass) + vmtParent)^^);
end;

function IsClass(Address: Pointer): Boolean;
asm
        CMP     Address, Address.vmtSelfPtr
        JNZ     @False
        MOV     Result, True
        JMP     @Exit
@False:
        MOV     Result, False
@Exit:
end;

end.