Trochu hackování v Delphi

vložil ondra 6. ledna 2014 23:18

Tento článek nepojednává o tom, jak obejít ochranu v RAD Studiu nebo MS Office, podíváme se spíš na to, jak modifikovat cizí kód, aniž bychom museli upravovat původní unity.

P.S.:Jedná se o pokračování a rozšíření mého seriálu o háčcích v Delphi (viz. tag hacky), tentokrát z pera Ondřeje Pokorného (www.kluug.net, už jsem ho několikrát odkazoval) / poznámka administrátora.

Proč neupravit rovnou původní zdrojový soubor?

Největší problém je aktualizace, stáhnu si novou verzi knihovny a musím svoje vlastní změny opět provést. Stejné platí i pro zdrojové kódy přímo Delphi, tam ještě přijde problém při každé nové instalaci.

Jak se dostat na protected metody/proměnné nějaké třídy?

K protected má přístup jakýkoliv potomek třídy. Stejně tak má přístup k protected všechno ve stejné unitě. Tento obecně známý a platný trik se tak přímo nabízí:

type
  TGraphicControlHack = class(TGraphicControl);

var
  xControl: TGraphicControl;
  xCanvas: TCanvas;
begin
  // … some code …

  xCanvas := TGraphicControlHack(xControl).Canvas;

  // … some code …
end.

Jak se dostat na privátní metody/proměnné nějaké třídy?

Příklad z praxe: Potřebuji se dostat na privátní proměnnou FSock: TTCPBlockSocket; a funkci function ReadResult: Integer; z TSMTPSend (unit smtpsend.pas ze Synapse):

  TSMTPSend = class(TSynaClient)
  private
    FSock: TTCPBlockSocket;
    FResultCode: Integer;
    FResultString: string;
    FFullResult: TStringList;
    FESMTPcap: TStringList;
    FESMTP: Boolean;
    FAuthDone: Boolean;
    FESMTPSize: Boolean;
    FMaxSize: Integer;
    FEnhCode1: Integer;
    FEnhCode2: Integer;
    FEnhCode3: Integer;
    FSystemName: string;
    FAutoTLS: Boolean;
    FFullSSL: Boolean;
    procedure EnhancedCode(const Value: string);
    function ReadResult: Integer;
  […]

(FSock je sice přístupná přes veřejnou property Sock, ale z testovacích důvodů budeme přistupovat přímo k FSock).

Delphi 2009 a novější

Od Delphi 2007 existují class helpery. Od Delphi 2009 se dají použít k přístupu ke všem metodám a proměnným - z private, strict private, protected, strict protected apod. Důležité je před nimi vždy psát Self:

type

  TSMTPSendHelper = class helper for TSMTPSend
  public
    function MailToDNS(const Value: string): Boolean;
  end;

{ TSMTPSendHelper }

function TSMTPSendHelper.MailToDNS(const Value: string): Boolean;
begin
  Self.FSock.SendString('RCPT TO:<' + Value + '> NOTIFY=FAILURE,SUCCESS
    ORCPT=rfc822;'+Value  + CRLF);
  Result := Self.ReadResult div 100 = 2;
end;

Delphi 2007 a starší

Ve starších Delphi je situace mnohem složitější a je závislá na původním kódu (t.j. pokud se kód knihovny změní, modifikace přestanou fungovat). Tímto taky padá ta největší výhoda nezávislosti úprav na aktualizaci původní knihovny.

K proměnným se dá dostat ještě relativně jednoduše přetypováním na vlastní definici hlavičky:

type

  TDummySMTPSend = class(TSynaClient)
  private
    FSock: TTCPBlockSocket;
  end;

var
  xS: TSMTPSend;
begin
  xS := TSMTPSend.Create;
  try
    TDummySMTPSend(xS).FSock.SendString('');
  finally
    xS.Free;
  end;
end.

K metodám už to tak jednoduše nepůjde. Pokud by to někoho zajímalo, tak návod jak se dostat k privátní metodě je popsán v tutoriálu od deepsoftware.ru.

Jak nahradit privátní proměnnou cizí třídy?

Za zmínku taky stojí, že stejným způsobem mohu privátní proměnnou nahradit vlastní instancí.

Jako příklad uvedu metodu, kterou se dají odchytávat změny v Screen.CustomForms (použitelnost v praxi ale značne limituje to, že při změně fokusu formuláře se provede delete/insert).

program NewForms;

uses
  Forms,
  Classes,
  uNewForms in 'uNewForms.pas' {Form1};

{$R *.res}

type
  TMyCustomFormsList = class(TList)
  protected
    procedure Notify(Ptr: Pointer; Action: TListNotification); override;
  end;

  TScreenHelper = class helper for TScreen
  public
    procedure InstallCreateFormHook;
  end;

{ TScreenHelper }

procedure TScreenHelper.InstallCreateFormHook;
var
  xNewCustomForms: TList;
begin
  xNewCustomForms := TMyCustomFormsList.Create;
  xNewCustomForms.Assign(Self.FCustomForms);
  Self.FCustomForms.Free;
  Self.FCustomForms := xNewCustomForms;
end;

{ TMyCustomFormsList }

procedure TMyCustomFormsList.Notify(Ptr: Pointer; Action: TListNotification);
begin
  inherited;

  case Action of
    lnAdded: begin
      //form added
    end;
    lnDeleted: begin
      //form removed
    end;
  end;
end;

begin
  Screen.InstallCreateFormHook;

  Application.Initialize;
  Application.MainFormOnTaskbar := True;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

Jak vidíte, pomocí class helperu se dostanu na FCustomForms, kterou uvolním a nahradím vlastním objektem. Ještě před tím ale pro jistotu zkopíruju obsah FCustomForms (pokud byl už předtím vytvořen nějaký formulář).

Podobný postup se dá aplikovat i na starší Delphi, jen je potřeba použít trik s hlavičkou.

Jak nahradit jakoukoliv metodu metodou vlastní?

Tato metoda se nazývá Detour a dá se aplikovat na všechny funkce a procedury, ke kterým máte přístup. Nejdříve zdrojový kód, který detour umožňuje (z stackoverflow.com):

unit Detour;

//SOURCE (author RRUZ): http://stackoverflow.com/questions/6905287/
//how-to-change-the-implementation-detour-of-an-externally-declared-function

interface

{$IFDEF FPC}
  {$MODE DELPHI}
{$ENDIF}

uses SysUtils, Windows;

type
  //strctures to hold the address and instructions to patch
  TJumpOfs = Integer;
  PPointer = ^Pointer;

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

  PAbsoluteIndirectJmp = ^TAbsoluteIndirectJmp;
  TAbsoluteIndirectJmp = packed record
    OpCode: Word;
    Addr: PPointer;
  end;

{$IFNDEF FPC}{$IF (CompilerVersion < 23)}//PRE - Delphi XE2
  NativeUInt = DWORD;
{$IFEND}{$ENDIF}

procedure HookProc(Proc, Dest: Pointer; var BackupCode: TXRedirCode);
procedure UnhookProc(Proc: Pointer; var BackupCode: TXRedirCode);

implementation

//get the address of a procedure or method of a function
function GetActualAddr(Proc: Pointer): Pointer;
begin
  if Proc <> nil then
  begin
    if (Win32Platform = VER_PLATFORM_WIN32_NT) and 
        (PAbsoluteIndirectJmp(Proc).OpCode = $25FF) then
      Result := PAbsoluteIndirectJmp(Proc).Addr^
    else
      Result := Proc;
  end
  else
    Result := nil;
end;

//patch the original function or procedure
procedure HookProc(Proc, Dest: Pointer; var BackupCode: TXRedirCode);
var
  n: NativeUInt;
  Code: TXRedirCode;
begin
  if (BackupCode.Jump <> 0) or (Proc = Dest) then
    exit;

  Proc := GetActualAddr(Proc);
  Assert(Proc <> nil);
  //store the address of the original procedure to patch
  if ReadProcessMemory(GetCurrentProcess, Proc, @BackupCode, SizeOf(BackupCode), {%H-}n) then
  begin
    Code.Jump := $E9;
    Code.Offset := PAnsiChar(Dest) - PAnsiChar(Proc) - SizeOf(Code);
    //replace the target procedure address with the new one.
    WriteProcessMemory(GetCurrentProcess, Proc, @Code, SizeOf(Code), n);
  end;
end;

//restore the original address of the hooked function or procedure
procedure UnhookProc(Proc: Pointer; var BackupCode: TXRedirCode);
var
  n: NativeUInt;
begin
  if (BackupCode.Jump <> 0) and (Proc <> nil) then
  begin
    Proc := GetActualAddr(Proc);
    Assert(Proc <> nil);
    WriteProcessMemory(GetCurrentProcess, Proc, @BackupCode, SizeOf(BackupCode), {%H-}n);
    BackupCode.Jump := 0;
  end;
end;

end.

HookProc nedělá nic jiného, než zapíše Jump instrukci na začátek originální metody, která ukazuje na novou metodu.

Použití detour k opravě bugu QC 32663 ve VCL.

TWinControl.CanFocus vrací True i když je formulář, na kterém je komponenta, skrytý. Když potom zavoláte

if Control.CanFocus then
  Control.SetFocus;

Delphi nemilosrdně vyhodí chybu. Embarcadero se k opravě nemá, musíme si to opravit sami:

unit uCanFocusFix;

interface

implementation

uses Controls, Forms, Detour;

type
  TWinControlFix = class(TWinControl)
  private
    class var FCanFocusBackup: TXRedirCode;
  private
    function FixedCanFocus: Boolean;
  public
    class procedure InstallFix;
    class procedure UninstallFix;
  end;

{ TWinControlFix }

function TWinControlFix.FixedCanFocus: Boolean;
var
  xControl: TWinControl;
begin
  xControl := Self;
  while Assigned(xControl) do
  begin
    if not (xControl.Visible and xControl.Enabled) then
    begin
      Result := False;
      Exit;
    end;
    xControl := xControl.Parent;
  end;

  Result := True
end;

class procedure TWinControlFix.InstallFix;
begin
  HookProc(@TWinControl.CanFocus, @TWinControlFix.FixedCanFocus, FCanFocusBackup);
end;

class procedure TWinControlFix.UninstallFix;
begin
  UnhookProc(@TWinControl.CanFocus, FCanFocusBackup);
end;

initialization

  TWinControlFix.InstallFix;

finalization

  TWinControlFix.UninstallFix;

end.

Pomocí HookProc nahradím CanFocus mojí novou funkcí FixedCanFocus, pomocí UnhookProc obnovím původní CanFocus; (v tomto případě se může obnovení původní funkce CanFocus i vynechat).

Nahrazení funkce a zavolání původní funkce

Předchozí příklad opravy bugu VCL se dá vyřešit i trochu jinak - zavoláním původní funkce CanFocus a otestováním, jestli je formulář viditelný a aktivovaný.

Do původní funkce se ale samozřejmě po použití Detour nedostaneme, takže hook musíme na začátku nové funkce odinstalovat a na konci opět nainstalovat:

function TWinControlFix.FixedCanFocus: Boolean;
var
  xForm: TCustomForm;
begin
  UninstallFix;
  try
    Result := CanFocus;
    if Result then begin
      xForm := GetParentForm(Self);
      Result := xForm.Visible and xForm.Enabled;
    end;
  finally
    InstallFix;
  end;
end;

Příklad nahrazení přetížené funkce MessageDlgPosHelp

Spousta tvůrců Delphi knihoven se spokojí s jednoduchou ochranou demo verze své knihovny: povětšinou při inicializování (v sekci initialization) prostě spustí MessageDlg se zprávou o tom, že aplikace používá demoverzi té-a-té knihovny.

Tímto nechci nikoho navádět k nekupování demoverzí cizích knihoven, pokud se programováním živíte, tak to je stejný případ s hackováním Vašich programů. Ale i pro programátora je vždy lepší koupit zdrojový kód a podporu ke knihovně, kterou potřebujete.

Každopádně by se i autoři měli zamyslet nad smysluplností takové jednoduché ochrany. Zbavit se jí je jednoduché a nepotřebujete k tomu znát ani zdrojové kódy (ty samozřejmě nemáte, je to přece demoverze).

Klíčem je nahradit MessageDlgPosHelp (nejlépe obě přetížené verze) prázdnými metodami. To se musí stát ještě před tím, než se provede inicializace externí knihovny. Vytvořte si tedy novou unitu a přidejte ji do uses Delphi projektu co nejvýše (hned za vlastní memory management knihovnu, pokud ji používáte). V její initialization sekci instalujte hook, který pak odinstalujete před voláním Application.Initialize;.

Malým problémem může být, že pod stejným názvem MessageDlgPosHelp se skrývají 2 různé přetížené funkce. Abychom se dostali k adrese té správné funkce, nemůžeme použít jednoduše @MessageDlgPosHelp, musíme jít oklikou přes lokální proměnnou.

program MessageDlgHack;

uses
  Forms,
  uMessageDlgHack in 'uMessageDlgHack.pas',
  uMain in 'uMain.pas' {Form3},
  Detour in '..\Detour.pas';

{$R *.res}

begin
  UninstallMessageDlgHack;

  Application.Initialize;
  Application.MainFormOnTaskbar := True;
  Application.CreateForm(TForm3, Form3);
  Application.Run;
end.

unit uMessageDlgHack;

interface

uses
  Detour, Dialogs;

procedure InstallMessageDlgHack;
procedure UninstallMessageDlgHack;

implementation

var
  fMessageDlgPosHelp1: TXRedirCode;
  fMessageDlgPosHelp2: TXRedirCode;

type
  TMessageDlgPosHelp1 = function(const Msg: string; DlgType: TMsgDlgType;
    Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer;
    const HelpFileName: string): Integer;
  TMessageDlgPosHelp2 = function(const Msg: string; DlgType: TMsgDlgType;
    Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer;
    const HelpFileName: string; DefaultButton: TMsgDlgBtn): Integer;

function DummyMessageDlgPosHelp1(const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer;
  const HelpFileName: string): Integer;
begin
  //do nothing
end;

function DummyMessageDlgPosHelp2(const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer;
  const HelpFileName: string; DefaultButton: TMsgDlgBtn): Integer;
begin
  //do nothing
end;

procedure InstallMessageDlgHack;
var
  xMesDlg1: TMessageDlgPosHelp1;
  xMesDlg2: TMessageDlgPosHelp2;
begin
  xMesDlg1 := MessageDlgPosHelp;
  xMesDlg2 := MessageDlgPosHelp;

  HookProc(@xMesDlg1, @DummyMessageDlgPosHelp1, fMessageDlgPosHelp1);
  HookProc(@xMesDlg2, @DummyMessageDlgPosHelp2, fMessageDlgPosHelp2);
end;

procedure UninstallMessageDlgHack;
var
  xMesDlg1: TMessageDlgPosHelp1;
  xMesDlg2: TMessageDlgPosHelp2;
begin
  xMesDlg1 := MessageDlgPosHelp;
  xMesDlg2 := MessageDlgPosHelp;

  UnhookProc(@xMesDlg1, fMessageDlgPosHelp1);
  UnhookProc(@xMesDlg2, fMessageDlgPosHelp2);
end;

initialization

  InstallMessageDlgHack;

end.

Nahrazení virtuální funkce

Mějme kód:

type

  TObjectA = class(TObject)
  public
    procedure Log; virtual;
  end;

  TObjectB = class(TObjectA)
  public
    procedure Log; override;
  end;

  TObjectC = class(TObjectB)
  public
    procedure Log; override;
  end;

{ TObjectA }

procedure TObjectA.Log;
begin
  Writeln('A');
end;

{ TObjectB }

procedure TObjectB.Log;
begin
  inherited;

  Writeln('X');
end;

{ TObjectC }

procedure TObjectC.Log;
begin
  inherited;

  Writeln('C');
end;

var
  xObject: TObjectC;
begin
  xObject := TObjectC.Create;
  try
    xObject.Log;
  finally
    xObject.Free;
  end;

  Readln;
end.

Jak jistě tušíte, výsledek je volání:

A
X
C

Co ale dělat, aby výsledek byl

A
B
C

?

Použijeme detour jako v předchozích případech. Jen volání inherited musíme přepsat pomocí statických metod.

type
  TFixedObjectB = class(TObjectB)
  private
    class var fLogBackup: TXRedirCode;
  private
    procedure FixedLog;
  public
    class procedure InstallFix;
    class procedure UninstallFix;
  end;

{ TFixedObjectB }

procedure TFixedObjectB.FixedLog;
type
  TProc = procedure of object;
var
  xInheritedLog: TMethod;
begin
  //call inherited
  xInheritedLog.Code := @TObjectA.Log;
  xInheritedLog.Data := Self;
  TProc(xInheritedLog)();

  //fixed call
  Writeln('B');
end;

class procedure TFixedObjectB.InstallFix;
begin
  HookProc(@TObjectB.Log, @TFixedObjectB.FixedLog, fLogBackup);
end;

class procedure TFixedObjectB.UninstallFix;
begin
  UnhookProc(@TObjectB.Log, fLogBackup);
end;

Závěr

K hackování cizího kódu se musí přistupovat opatrně a mělo by být až poslední možností před upravováním cizího zdrojového kódu.

Netvrdím, že je to nejlepší metoda, jak opravovat chyby v cizím kódu, vždy chce zvážit pro a proti té které možnosti.

Každopádně ale není na škodu o ní něco vědět. Od Delphi 2009 nám kombinace ClassHelper+Detour dává téměř neomezené možnosti k úpravám cizího kódu.

Stáhnout ukázky: háčky v Delphi (30K).


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

Tagy: ,

Návody

Komentáře

7.1.2014 11:03:57 #

pepak

Tohle je tak pěkný přehled, že musím překonat nefunkčnost téhle konkrétní stránky v mém prohlížeči, spustit jiný prohlížeč a autora pochválit. Rozhodně bookmarkuji pro budoucí použití.

pepak

7.1.2014 11:25:42 #

radekc

Pepaku, co máš za prohlížeč a co ti nefunguje? Posli screenshot na moji adresu prosím.

radekc

7.1.2014 20:27:28 #

pepak

Radku, s tím si nedělej starosti, to se občas moje Opera*) zblázní a přestane reagovat na klávesy, včetně kláves pro UI, které by webová stránka neměla ovlivnit. Vina je čistě moje, že mám příliš atypicky nastavený prohlížeč, neočekávám, že by to měl webmaster řešit.

*) S vypnutým vším možným včetně javascriptu, kterou pomocí Privoxy maskuju za Firefox a získanou stránku zase pomocí Privoxy upravuju do podoby, která mi vyhovuje.

pepak

7.1.2014 22:01:21 #

oxo

Díky Pepáku za pochvalu a díky Radku za zveřejnění.

Ještě se doplním:

1) V nahrazených metodách třídy konstanta Self odkazuje samozřejmě na původní objekt, ne na ten nový.

Jako příklad poslouží tento kód z "Nahrazení virtuální funkce", který vypíše "TObjectC" i když by vlastně v normálním případě nikdy neměl:
procedure TFixedObjectB.FixedLog;
//[...]
begin
//[...]
  Writeln(Self.ClassName);//returns "TObjectC although TObjectC cannot be a descendant of TFixedObjectB!
end;

Pozor ale na optimalizace, podobný postup u operátoru "is" už neprojde:
procedure TFixedObjectB.FixedLog;
//[...]
begin
//[...]
  if
    (Self is TObjectC) or//compiler error
    (Self is TFixedObjectB)//returns always true, although it should be false!
  then
    Writeln(Self.ClassName);//returns "TObjectC although TObjectC cannot be a descendant of TFixedObjectB!
end;

Nejsem kovaný v assembleru, takže se moc nekouknu na to, jak kód "(Self is TFixedObjectB)" převede compiler, ale tuším, že tuto podmínku vyhodnotí jako vždy kladnou a natvrdo ji nahradí konstantou "true". Toto chování se dá očekávat, protože compiler nemůže tušit, že mu v Self podstrčíme úplně jiný objekt. (Tady mě klidně opravte/doplňte, je to ode mě pouze spekulace).


2) Příklad "Nahrazení funkce a zavolání původní funkce" samozřejmě není thread-safe.

V případě CanFocus to není problém, protože celá VCL není thread-safe. Pokud by ale nahrazovaná metoda mohla být volána z více threadů, pozor na to, že v bloku try-finally je oprava odinstalovaná a volání z jiného threadu provede hned původní funkci bez opravy! V tom případě je asi nejlepší tu funkci přepsat tak, aby původní funkce nebyla vůbec volána. Použití Critical Sections je také možné, ale přijdete o výhodu podpory více vláken.

oxo

8.1.2014 10:32:51 #

oxo

Ale co to plácám, Critical Sections samozřejmě nepomůžou.

oxo

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