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).

    1program Project2;
    2{$APPTYPE CONSOLE}
    3uses
    4  uHack in 'uHack.pas', // vlastní háček je zde
    5  Classes, SysUtils;
    6
    7var
    8  lst:TStringList;
    9
   10begin
   11  lst := TStringList.Create;
   12  try
   13    lst.Add('prvni');
   14    lst.Add('druhy');
   15    lst.Add('treti');
   16
   17  finally
   18    FreeAndNil(lst);
   19  end;
   20end.

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.

    1unit uHack;
    2{**************************************************************************************************}
    3{                                                                                                  }
    4{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
    5{ you may not use this file except in compliance with the License. You may obtain a copy of the    }
    6{ License at http://www.mozilla.org/MPL/                                                           }
    7{                                                                                                  }
    8{ The Original Code is VCLFixPack.pas.                                                             }
    9{                                                                                                  }
   10{ The Initial Developer of the Original Code is Andreas Hausladen (Andreas.Hausladen@gmx.de).      }
   11{ Portions created by Andreas Hausladen are Copyright © 2008 Andreas Hausladen.                  }
   12{ All Rights Reserved.                                                                             }
   13{                                                                                                  }
   14{**************************************************************************************************}
   15
   16{$R-} // range check off
   17interface
   18implementation
   19uses
   20  SysUtils,
   21  Windows,
   22  Classes;
   23
   24type
   25  TJumpOfs = Integer;
   26  PPointer = ^Pointer;
   27
   28  PXRedirCode = ^TXRedirCode;
   29  TXRedirCode = packed record
   30    Jump: Byte;
   31    Offset: TJumpOfs;
   32  end;
   33
   34  PWin9xDebugThunk = ^TWin9xDebugThunk;
   35  TWin9xDebugThunk = packed record
   36    PUSH: Byte;
   37    Addr: Pointer;
   38    JMP: TXRedirCode;
   39  end;
   40
   41  PAbsoluteIndirectJmp = ^TAbsoluteIndirectJmp;
   42  TAbsoluteIndirectJmp = packed record
   43    OpCode: Word;   //$FF25(Jmp, FF /4)
   44    Addr: PPointer;
   45  end;
   46
   47function GetActualAddr(Proc: Pointer): Pointer;
   48
   49  function IsWin9xDebugThunk(AAddr: Pointer): Boolean;
   50  begin
   51    Result := (AAddr <> nil) and
   52              (PWin9xDebugThunk(AAddr).PUSH = $68) and
   53              (PWin9xDebugThunk(AAddr).JMP.Jump = $E9);
   54  end;
   55
   56begin
   57  if Proc <> nil then
   58  begin
   59    if (Win32Platform <> VER_PLATFORM_WIN32_NT) and IsWin9xDebugThunk(Proc) then
   60      Proc := PWin9xDebugThunk(Proc).Addr;
   61    if (PAbsoluteIndirectJmp(Proc).OpCode = $25FF) then
   62      Result := PAbsoluteIndirectJmp(Proc).Addr^
   63    else
   64      Result := Proc;
   65  end
   66  else
   67    Result := nil;
   68end;
   69
   70procedure ReplaceVmtField(AClass: TClass; OldProc, NewProc: Pointer);
   71type
   72  PVmt = ^TVmt;
   73  TVmt = array[0..MaxInt div SizeOf(Pointer) - 1] of Pointer;
   74var
   75  I: Integer;
   76  Vmt: PVmt;
   77  n: Cardinal;
   78  P: Pointer;
   79begin
   80  OldProc := GetActualAddr(OldProc);
   81  NewProc := GetActualAddr(NewProc);
   82
   83  I := vmtSelfPtr div SizeOf(Pointer);
   84  Vmt := Pointer(AClass);
   85  while (I < 0) or (Vmt[I] <> nil) do
   86  begin
   87    P := Vmt[I];
   88    if (P <> OldProc) and (Integer(P) > $10000) and not IsBadReadPtr(P, 6) then
   89      P := GetActualAddr(P);
   90    if P = OldProc then
   91    begin
   92      WriteProcessMemory(GetCurrentProcess, @Vmt[I], @NewProc, SizeOf(NewProc), n);
   93      Exit;
   94    end;
   95    Inc(I);
   96  end;
   97end;
   98
   99// vlastni hack
  100type
  101  TNewStringList = class(TStringList)
  102  public
  103    function NewAdd(const S: string): Integer;
  104  end;
  105
  106function TNewStringList.NewAdd(const S: string): Integer;
  107begin
  108  writeln(s);  // ladici vypis
  109  Result := Count;
  110  Insert(Result, s);
  111end;
  112
  113initialization
  114  // instalace
  115  ReplaceVmtField(TStringList, @TNewStringList.Add, @TNewStringList.NewAdd);
  116finalization
  117  // a zpet
  118  ReplaceVmtField(TStringList, @TNewStringList.NewAdd, @TNewStringList.Add);
  119end.

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).


Nabízíme Delphi školení a konzultace na různá témata, primárně ve Vaší firmě.

Tagy: ,

Praxe

Komentování ukončeno

Naše nabídka

Partial English version.

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 nebo burzy práce).

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 (s výhledem na další platformy díky FireMonkey) na současném trhu (včetně Windows 8.1).

V současnosti je světová komunita přes dva miliónů vývojářů.

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.

Anketa

Poslední komentáře

Comment RSS