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