Pascal Переопределение методов класса во время выполнения

Question

Я пытаюсь перезаписать метод объекта во время выполнения.
Мне удалось получить addr метода, и я могу быть уверен, что это corrct (см. Только чтение).
Моя проблема заключается в том, что я могу только получить доступ только для чтения к методам кода адреса

Therefor я либо нужен способ:
- заставить писать в Ram-зоне, защищенной
- к скопируйте весь тип класса в незащищенную область и измените его там. (это было бы еще более полезно, потому что у меня все еще была бы оригинальная версия)

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

Хорошо, я наконец-то понял, как это сделать.
Pascal vmts немного путают.
Он использует 4 вида vmts:
* Один используется только для опубликованных методов
* One используется только RTTI, содержащий дополнительные данные для всех методов
* Один используемых сообщений и динамических методов
* И тот, используется, когда вы просто вызываете ObjectMethod
Это заняло много времени назад, но теперь это работает.
Для тех из вас, интересно, как его сделать, у меня есть:

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

В основном это написано самомодифицирующимся кодом. Вам необходимо установить атрибуты связанной страницы.

См., Например, http://support.microsoft.com/kb/127904