Háček: nahrazení virtuální metody cizí třídy

vložil Radek Červinka 29. března 2010 21:37

Pokračujeme druhým dílem háčků. Dnes to bude nahrazení virtuální metody třídy.

Samozřejmě je většinou jednodušší ze třídy podědit a metodu nahradit v následníku, ale někdy může být výhodné přímé nahrazení. Příkladem mohou být ladící výpisy nebo oprava (vylepšení) nějaké komponenty.

Dále popsaný mechanismus je převzat z VCLFixPack.

Použití a vlastní kód ukáži na příkladu nahrazení TStringList.Add za verzi s výpisem přidávaných řetezců (bude se jednat o konzolovou aplikaci, tj. lze pro výpis použít writeln a výpis bude směřován přímo do konzole).

program Project2;
{$APPTYPE CONSOLE}
uses
  uHack in 'uHack.pas', // vlastní háček je zde
  Classes, SysUtils;

var
  lst:TStringList;

begin
  lst := TStringList.Create;
  try
    lst.Add('prvni');
    lst.Add('druhy');
    lst.Add('treti');

  finally
    FreeAndNil(lst);
  end;
end.

Bez háčku se prostě přidají tři položky do TStringList a nic se nestane. Takže nyní implementace háčku a mechanismu pro jeho použití. Pozor - upravená metoda Add není úplně funkčně stejná (jedná se jen o příklad).

Náš kód začíná od řádku 100, před ním jsou podpůrné procedury. Vlastní instalace háčku je v sekci initialization a tak stačí přidat unit uHack do uses.

unit uHack;
{**************************************************************************************************}
{                                                                                                  }
{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
{ you may not use this file except in compliance with the License. You may obtain a copy of the    }
{ License at http://www.mozilla.org/MPL/                                                           }
{                                                                                                  }
{ The Original Code is VCLFixPack.pas.                                                             }
{                                                                                                  }
{ The Initial Developer of the Original Code is Andreas Hausladen (Andreas.Hausladen@gmx.de).      }
{ Portions created by Andreas Hausladen are Copyright © 2008 Andreas Hausladen.                  }
{ All Rights Reserved.                                                                             }
{                                                                                                  }
{**************************************************************************************************}

{$R-} // range check off
interface
implementation
uses
  SysUtils,
  Windows,
  Classes;

type
  TJumpOfs = Integer;
  PPointer = ^Pointer;

  PXRedirCode = ^TXRedirCode;
  TXRedirCode = packed record
    Jump: Byte;
    Offset: TJumpOfs;
  end;

  PWin9xDebugThunk = ^TWin9xDebugThunk;
  TWin9xDebugThunk = packed record
    PUSH: Byte;
    Addr: Pointer;
    JMP: TXRedirCode;
  end;

  PAbsoluteIndirectJmp = ^TAbsoluteIndirectJmp;
  TAbsoluteIndirectJmp = packed record
    OpCode: Word;   //$FF25(Jmp, FF /4)
    Addr: PPointer;
  end;

function GetActualAddr(Proc: Pointer): Pointer;

  function IsWin9xDebugThunk(AAddr: Pointer): Boolean;
  begin
    Result := (AAddr <> nil) and
              (PWin9xDebugThunk(AAddr).PUSH = $68) and
              (PWin9xDebugThunk(AAddr).JMP.Jump = $E9);
  end;

begin
  if Proc <> nil then
  begin
    if (Win32Platform <> VER_PLATFORM_WIN32_NT) and IsWin9xDebugThunk(Proc) then
      Proc := PWin9xDebugThunk(Proc).Addr;
    if (PAbsoluteIndirectJmp(Proc).OpCode = $25FF) then
      Result := PAbsoluteIndirectJmp(Proc).Addr^
    else
      Result := Proc;
  end
  else
    Result := nil;
end;

procedure ReplaceVmtField(AClass: TClass; OldProc, NewProc: Pointer);
type
  PVmt = ^TVmt;
  TVmt = array[0..MaxInt div SizeOf(Pointer) - 1] of Pointer;
var
  I: Integer;
  Vmt: PVmt;
  n: Cardinal;
  P: Pointer;
begin
  OldProc := GetActualAddr(OldProc);
  NewProc := GetActualAddr(NewProc);

  I := vmtSelfPtr div SizeOf(Pointer);
  Vmt := Pointer(AClass);
  while (I < 0) or (Vmt[I] <> nil) do
  begin
    P := Vmt[I];
    if (P <> OldProc) and (Integer(P) > $10000) and not IsBadReadPtr(P, 6) then
      P := GetActualAddr(P);
    if P = OldProc then
    begin
      WriteProcessMemory(GetCurrentProcess, @Vmt[I], @NewProc, SizeOf(NewProc), n);
      Exit;
    end;
    Inc(I);
  end;
end;

// vlastni hack
type
  TNewStringList = class(TStringList)
  public
    function NewAdd(const S: string): Integer;
  end;

function TNewStringList.NewAdd(const S: string): Integer;
begin
  writeln(s);  // ladici vypis
  Result := Count;
  Insert(Result, s);
end;

initialization
  // instalace
  ReplaceVmtField(TStringList, @TNewStringList.Add, @TNewStringList.NewAdd);
finalization
  // a zpet
  ReplaceVmtField(TStringList, @TNewStringList.NewAdd, @TNewStringList.Add);
end.

Jádrem je procedura ReplaceVmtField, která provede vlastní nahrazení - tj. jedná se o obecný kód, který můžete použít ve Vašem programu. Procedura projde tabulku virtuálních metod třídy (VMT) a pokud nalezne metodu jejíž adresa je rovna předanému parametru, provede záměnu za novou metodu (musí mít stejný počet parametrů atd.), která byla také předaná.

V sekci finalization se provede (pro jistotu) vrácení původní metody (tj. opačná záměna).

Tagy: ,

Praxe

Komentování ukončeno

Naše nabídka

MVP
Ing. Radek Červinka - Embarcadero MVP
profil na linkedin, Twitter:@delphicz

Nabízím placené poradenství a konzultace v oblasti programování a vývoje SW.
Dále nabízíme i vývoj speciálního software na zakázku.

Neváhejte nás kontaktovat (i ohledně reklamy).

Pokud chcete podpořit tento server libovolnou částkou, můžete použít PayPal. Moc děkuji.

Delphi Certified Developer

O Delphi.cz

Delphi je jediný moderní RAD nástroj podporující tvorbu nativních aplikací pro platformu Win32, Win64, Mac OSX a na iPhone a Android.

Delphi.cz je nezávislý portál pro uživatele Delphi. Portál není koncipován pro úplné začátečníky, i když i ti se zde nebudou nudit, ale spíše na programátory, kteří již něco znají a chtějí své znalosti dále rozvíjet a sledovat novinky.

Poslední komentáře

Comment RSS