Pascal在运行时覆盖类方法

时间:2014-02-11 10:18:37

标签: class methods runtime override pascal

我试图在运行时覆盖对象方法 我设法得到了方法的addr,我可以确定它是corrct(参见只读用法) 我的问题是,我只能获得方法代码地址

的只读访问权限 因此我需要一种方法:
  - 强制写入受保护的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.

2 个答案:

答案 0 :(得分:2)

好的,我终于想出了如何做这件事 Pascal vmts有点令人困惑 它使用4种vmts:
*仅用于已发布的方法
*仅由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.

答案 1 :(得分:1)

基本上它是编写自修改代码。您需要设置相关页面的属性。

参见例如http://support.microsoft.com/kb/127904