Pascal Overriding class methods during runtime - class

Question

I am trying to overwrite an object method during runtime.
I managed to get the addr of the method and I can be sure it is corrct (see read-only usage).
My problem is that I can only get read-only access to methods code address
Therefor I either need a way:
- to force write into a Ram-Area that is protected
- to copy the whole class type into a non-protected area and modify it there. (this would be even more useful, because I would still have the original version to hand)
program DynClass;
uses
System.SysUtils,
System.Rtti,
System.TypInfo;
type
TObjectMethod = procedure of Object;
TObjectTest = class(TObject)
public
fieldVar: integer;
procedure ov1; virtual; // <-- virtual does not help
procedure ov2; virtual; // <-- the method I an trying to override
end;
{ TObjectTest }
procedure TObjectTest.ov1; begin writeLn('TObjectTest.ov1'); end;
procedure TObjectTest.ov2; begin writeLn('TObjectTest.opasv2'); end;
// the Method thats supposed to replace it
procedure Override_ov1(self: TObject);
begin writeLn('TOverrideSrc.ov1'); writeLn(TObjectTest(self).fieldVar); end;
var obj: TObjectTest;
var fMethod: TMethod;
var C: TRttiContext;
var T: TRttiType;
var M: TRttiMethod;
var VTMEntry: PVmtMethodEntry;
begin try
obj := TObjectTest.Create;
obj.fieldVar := 21;
T := C.GetType(TypeInfo(TObjectTest));
M := T.GetMethod('ov2');
VTMEntry := PVmtMethodExEntry(m.Handle).Entry;
writeln('address(API): 0x',IntToHex(Integer(M.CodeAddress),8));
writeln('address(Container): 0x',IntToHex(Integer(VTMEntry^.CodeAddress),8));
// ^ note: The address in the container matches the address the Rtti API offers
// --> I really have the virtual method table entry
// vvv This both works (meaning that all addresses are correct)
fMethod.Data := obj;
fMethod.Code := VTMEntry^.CodeAddress;
TObjectMethod(fMethod)(); // call the method in the VTMEntry
fMethod.Code := addr(Override_ov1);
TObjectMethod(fMethod)(); // call the method I want to use in overriding
// ^^^
VTMEntry^.CodeAddress := addr(Override_ov1);
// ^ access violation here
obj.ov2; // if all works, this should do the same as the call above
except on E: Exception do begin
writeLn(E.ClassName+':'+E.Message);
end; end;
readLn;
end.

Answer 1

Ok I finally figured out how to do this thing.
Pascal vmts are kind of confusing.
It uses 4 kinds of vmts:
* One only used for published methods
* One only used by Rtti, containing additional data for all methods
* One used by message and dynamic methods
* And the one that is used, when you just call an ObjectMethod
It took a lot of backwards engeneering, but now it work.
For those of you wondering how its done, I have this:
program DynClass;
uses windows;
type
// ***
// * Most of these types I got from "http://hallvards.blogspot.de/2006/04/hack-9-dynamic-method-table-structure.html"
// ***
PClass = ^TClass;
TDMTIndex = Smallint;
PDmtIndices = ^TDmtIndices;
TDmtIndices = array[0..High(Word)-1] of TDMTIndex;
PDmtMethods = ^TDmtMethods;
TDmtMethods = array[0..High(Word)-1] of Pointer;
PDmt = ^TDmt;
TDmt = packed record
Count: word;
Indicies: TDmtIndices; // really [0..Count-1]
Methods : TDmtMethods; // really [0..Count-1]
end;
PVmtMethodEntry = ^TVmtMethodEntry;
TVmtMethodEntry = packed record
Len: Word;
CodeAddress: Pointer;
Name: ShortString;
{Tail: TVmtMethodEntryTail;} // only exists if Len indicates data here
end;
PVmtMethodEntryEx = ^TVmtMethodEntryEx;
TVmtMethodEntryEx = packed record
Entry: PVmtMethodEntry;
Flags: Word;
VirtualIndex: Smallint; // signed word
end;
PEquals = function (Self,Obj: TObject): Boolean;
PGetHashCode = function (Self: TObject): Integer;
PToString = function (Self: TObject): string;
PSafeCallException = function (Self: TObject; ExceptObject: TObject; ExceptAddr: Pointer): HResult;
PAfterConstruction = procedure (Self: TObject);
PBeforeDestruction = procedure (Self: TObject);
PDispatch = procedure (Self: TObject; var Message);
PDefaultHandler = procedure (Self: TObject; var Message);
PNewInstance = function (Self: TClass) : TObject;
PFreeInstance = procedure (Self: TObject);
PDestroy = procedure (Self: TObject; OuterMost: ShortInt);
PVmt = ^TVmt;
TVmt = packed record
SelfPtr : TClass;
IntfTable : Pointer;
AutoTable : Pointer;
InitTable : Pointer;
TypeInfo : Pointer;
FieldTable : Pointer;
MethodTable : Pointer;
DynamicTable : PDmt;
ClassName : PShortString;
InstanceSize : PLongint;
Parent : PClass;
Equals : PEquals; // these I had to add they might
GetHashCode : PGetHashCode; // be incorrect for older delphi
ToString : PToString; // versions (this works for XE2)
SafeCallException : PSafeCallException;
AfterConstruction : PAfterConstruction;
BeforeDestruction : PBeforeDestruction;
Dispatch : PDispatch;
DefaultHandler : PDefaultHandler;
NewInstance : PNewInstance;
FreeInstance : PFreeInstance;
Destroy : PDestroy;
{UserDefinedVirtuals: array[0..999] of procedure;}
end;
// v taked from System.Rtti
function GetBitField(Value, Shift, Bits: Integer): Integer;
begin Result := (Value shr Shift) and ((1 shl Bits) - 1); end;
// v substituted from System.Rtti
function GetIsDynamic(handle: PVmtMethodEntryEx): boolean;
begin case GetBitField(Handle.Flags,3,2) of
2,3: result := true;
else result := false; end; end;
// a method that can be used to write data into protected RAM
function hackWrite(const addr: PPointer; const value: Pointer): boolean;
var RestoreProtection, Ignore: DWORD; begin
if VirtualProtect(addr,SizeOf(addr^),PAGE_EXECUTE_READWRITE,RestoreProtection) then begin
addr^ := Value; result := true;
VirtualProtect(addr,SizeOf(addr^),RestoreProtection,Ignore);
FlushInstructionCache(GetCurrentProcess,addr,SizeOf(addr^)); // flush cache
end else result := false; end;
// the Vmt is located infront of a Class
function GetVmt(AClass: TClass): PVmt;
begin Result := PVmt(AClass); Dec(PVmt(Result)); end;
// seares the vmt for
function getVirtualIndex(vmt: PVmt; aMeth: shortString; out isDynamic: boolean): SmallInt;
var P: PByte;
procedure readClassic;
var count: PWord; meth: PVmtMethodEntry; next: PByte; I: integer; begin
Count := PWord(P); inc(PWord(P));
for I := 0 to pred(Count^) do begin
meth := PVmtMethodEntry(P);
if meth.Name=aMeth then
begin result := I; break; end;
inc(p,meth.Len);
end; end;
procedure readExtendedMethods;
var Count: PWord; I: integer; meth: PVmtMethodEntryEx; begin
Count := PWord(P); inc(PWord(P));
for i := 0 to pred(count^) do begin
meth := PVmtMethodEntryEx(P);
if meth.Entry.Name=aMeth then begin
result := meth.VirtualIndex;
isDynamic := GetIsDynamic(meth);
exit; end;
inc(PVmtMethodEntryEx(P));
end; end;
begin isDynamic := false;
P := vmt.MethodTable; result := low(SmallInt);
readClassic; // classic method are method declared in a published area
if result=low(SmallInt)
then readExtendedMethods; // extended methods were added in D2010, when Rtti was introduced
end;
procedure overwriteMethod(vmt: PVmt; vmtID: smallInt; isDynamic: boolean; meth: Pointer); overload;
var loc: PByte; dynIndex: word; i: smallInt;
begin if vmtID<>low(SmallInt) then begin
if isDynamic then begin
loc := #vmt.DynamicTable.Indicies[0]; // goto first index entry
for i := 0 to vmt.DynamicTable.Count-1 do begin
if vmt.DynamicTable.Indicies[i] = vmtId
then begin vmtId := i; break; end; end;
// ^ find the vmt id in the dynamic table
inc(loc,
(vmt.DynamicTable.Count*sizeOf(TDMTIndex))+ // end of indices
(vmtID*sizeOf(Pointer))); // desired method entry
end else begin
loc := PByte(vmt);
inc(PVmt(loc)); // skip to the end of the vmt (thats where all the methods are stored)
inc(loc,vmtID*sizeOf(Pointer)); // skip to the exact position of the method
end; end;
hackWrite(PPointer(loc),meth); // overwrite it
end;
procedure overwriteMethod(c: TClass; methName: shortString; meth: Pointer); overload;
var vmtID: smallInt; isDynamic: boolean; vmt: PVmt; begin
vmt := GetVmt(c);
vmtID := getVirtualIndex(vmt,methName,isDynamic);
overwriteMethod(vmt,vmtID,isDynamic,meth);
end;
// ** everything on needs for dynPascal is now defined
type TBaseTestClass = class(TObject)
public
procedure updateA; virtual; abstract;
procedure updateB; virtual; abstract;
end;
type TTestClass = class(TBaseTestClass)
public
procedure foobar; dynamic;
procedure updateA; override;
procedure updateB; override;
end;
type TTestClass2 = class(TTestClass)
public
procedure updateA; override;
procedure updateB; override;
end;
{ TTestClass }
procedure TTestClass.foobar; begin writeLn('foobar'); end;
procedure TTestClass.updateA; begin writeLn('TTestClass.updateA'); end;
procedure TTestClass.updateB; begin writeLn('TTestClass.updateB'); end;
{ TTestClass2 }
procedure TTestClass2.updateA; begin writeLn('TTestClass2.updateA'); end;
procedure TTestClass2.updateB; begin writeLn('TTestClass2.updateB'); end;
procedure testMeth(self: TObject);
begin writeLn('!!!!!!!!!!!!Overwritten method called!!!!!!!!!!!!'); end;
var fTable: PVmt;
var a,b: TObject;
var vmt: PVmt;
var I: integer; begin
fTable := GetVmt(TTestClass);
a := TTestClass.Create;
b := TTestClass2.Create;
// ** demonstration calls, to show that the types work normal at first
TBaseTestClass(a).updateA;
TBaseTestClass(b).updateA;
TBaseTestClass(a).updateB;
TBaseTestClass(b).updateB;
writeLn('');
// ** overwrite a few methods with testMeth and repeat the calling process
overwriteMethod(TTestClass,'foobar',addr(testMeth));
// ^ dynamic methods like foobar work differently but I included handles for those, too
overwriteMethod(TTestClass,'updateA',addr(testMeth));
overwriteMethod(TTestClass2,'updateA',addr(testMeth));
TTestClass(a).foobar;
TBaseTestClass(a).updateA;
TBaseTestClass(b).updateA;
TBaseTestClass(a).updateB; // These 2 methods I didn't overwrite
TBaseTestClass(b).updateB; // ...
readLn;
end.

Answer 2

Basically it is writing self-modifying code. You need to set the attributes of the related page.
See e.g. http://support.microsoft.com/kb/127904