Magicmida/Tracer.pas at master · jongames/Magicmida · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
unit Tracer;

interface

uses Windows, SysUtils, Utils;

type
  TTracePredicate = function(const C: TContext): Boolean of object;

  TTracer = class
  private
    FProcessID, FThreadID: Cardinal;
    FThreadHandle: THandle;
    FPredicate: TTracePredicate;
    FCounter, FLimit: Cardinal;
    FLimitReached: Boolean;
    Log: TLogProc;

    function OnSingleStep(const Ev: TDebugEvent): Cardinal;
  public
    constructor Create(AProcessID, AThreadID: Cardinal; AThreadHandle: THandle;
      APredicate: TTracePredicate; ALog: TLogProc);

    procedure Trace(AAddress: NativeUInt; ALimit: Cardinal);

    property Counter: Cardinal read FCounter;
    property LimitReached: Boolean read FLimitReached;
  end;

implementation

{ TTracer }

constructor TTracer.Create(AProcessID, AThreadID: Cardinal; AThreadHandle: THandle;
  APredicate: TTracePredicate; ALog: TLogProc);
begin
  FProcessID := AProcessID;
  FThreadID := AThreadID;
  FThreadHandle := AThreadHandle;
  FPredicate := APredicate;
  Log := ALog;
end;

procedure TTracer.Trace(AAddress: NativeUInt; ALimit: Cardinal);
var
  C: TContext;
  Ev: TDebugEvent;
  Status: Cardinal;
begin
  FCounter := 0;
  FLimit := ALimit;
  FLimitReached := False;

  C.ContextFlags := CONTEXT_CONTROL;
  if not GetThreadContext(FThreadHandle, C) then
    RaiseLastOSError;

  C.Eip := AAddress;
  C.EFlags := C.EFlags or $100; // Trap
  if not SetThreadContext(FThreadHandle, C) then
    RaiseLastOSError;

  if not ContinueDebugEvent(FProcessID, FThreadID, DBG_CONTINUE) then
    Exit;

  Status := DBG_EXCEPTION_NOT_HANDLED;
  while WaitForDebugEvent(Ev, INFINITE) do
  begin
    case Ev.dwDebugEventCode of
      EXCEPTION_DEBUG_EVENT:
      begin
        if Ev.Exception.ExceptionRecord.ExceptionCode = EXCEPTION_SINGLE_STEP then
        begin
          Status := OnSingleStep(Ev);
          if Status = DBG_CONTROL_BREAK then
            Break;
        end
        else
        begin
          Log(ltFatal, 'Unexpected exception during tracing: ' + IntToHex(Ev.Exception.ExceptionRecord.ExceptionCode, 8));
          Exit;
        end;
      end;

      else
        Status := DBG_CONTINUE;
    end;

    ContinueDebugEvent(Ev.dwProcessId, Ev.dwThreadId, Status);
  end;
end;

function TTracer.OnSingleStep(const Ev: TDebugEvent): Cardinal;
var
  C: TContext;
begin
  Inc(FCounter);
  if (FLimit <> 0) and (FCounter > FLimit) then
  begin
    FLimitReached := True;
    Log(ltInfo, 'Giving up trace due to instruction limit');
    Exit(DBG_CONTROL_BREAK);
  end;

  C.ContextFlags := CONTEXT_CONTROL;
  if not GetThreadContext(FThreadHandle, C) then
    RaiseLastOSError;

  C.EFlags := C.EFlags or $100;
  if not SetThreadContext(FThreadHandle, C) then
    RaiseLastOSError;

  if FPredicate(C) then
    Result := DBG_CONTROL_BREAK
  else
    Result := DBG_CONTINUE;
end;

end.