procedure DoDebugLoop;
{ собственно, это главная процедура перехватчика.
большую часть времени он крутится именно в ней }
var
  Event: TDebugEvent;
  { стандартная Win32 структура. для интересующихся:}
  ЕDebugEvent = record
    dwDebugEventCode: DWORD; // тип пришедшего события
    dwProcessId: DWORD;   // Id прерванного процесса
    dwThreadId: DWORD; // Id прерванного потока
    case Integer of
      0: (Exception: TExceptionDebugInfo);
      1: (CreateThread: TCreateThreadDebugInfo);
      2: (CreateProcessInfo: TCreateProcessDebugInfo);
      3: (ExitThread: TExitThreadDebugInfo);
      4: (ExitProcess: TExitThreadDebugInfo);
      5: (LoadDll: TLoadDLLDebugInfo);
      6: (UnloadDll: TUnloadDLLDebugInfo);
      7: (DebugString: TOutputDebugStringInfo);
      8: (RipInfo: TRIPInfo);
      // эти части смотрите сами - не могу же я все разжевывать! :-)
  end;

begin
  FillChar(ThreadList, SizeOf(ThreadList), 0);

  HProc := 0;
  { хэндл процесса, который будем отлаживать.
  пока процесс не запущенным считается,
  соответственно - хэндла нету }
  ProcessFinished := True;
  { поскольку процесс не запустился,
  то он считается завершенным :-) }
  BPAddr := 0;
  { точку останова уточним,
  когда загрузится нужная DLL }
  RestoreBreak := False;

  repeat
    if not WaitForDebugEvent(Event, INFINITE) then
      break;
    { ожидаем прихода отладочного события. в реальном отладчике здеесь
    вместо INFINITE лучше задать маленькую константу, ожидать в цикле,
    там же в цикле организовывать взаимодействие с юзверем. или вообще
    для интерфейса отдельный поток создать }
    dwContinueStatus := DBG_EXCEPTION_NOT_HANDLED;
    { поскольку большинство исключений мы не обрабатываем,
    то по умолчанию так и говорим системе }
    CurThread := GetThreadHandleFromList(ThreadList, Event.dwThreadId);
    { просто поиск в массиве ThreadList. Id нам известен, ищем хэндл }
    case Event.dwDebugEventCode of
      { проверим - а что, собственно случилось? }
      CREATE_PROCESS_DEBUG_EVENT:
      { запустился новый процесс. запомним его хэндл, и сбросим флажок ProcessFinished }
      begin
        HProc := Event.CreateProcessInfo.HProcess;
        ProcessFinished := False;
        AddThreadToList(ThreadList, Event.dwThreadId, Event.CreateProcessInfo.hThread);
      end;
      EXIT_PROCESS_DEBUG_EVENT:
      { процесс завершился - значит, можно смело закрывать наш перехватчик.
      заодно установим флажок ProcessFinished }
      begin
        ProcessFinished := True;
        ContinueDebugEvent(Event.dwProcessId, Event.dwThreadId, DBG_CONTINUE);
        { это на всякий случай - чтобы ось точно прибила и процесс, и отладчик.
        в принципе, оно не надо, но смотри выше комментарий к ProcessFinished }
        break; { все, из цикла отладки можно смело выходить }
      end;
      CREATE_THREAD_DEBUG_EVENT:
        { процесс запустил новый поток. здесь у нас есть единственная возможность
        запомнить его хэндл. так и делаем }
        AddThreadToList(ThreadList, Event.dwThreadId, Event.CreateThread.hThread);
      EXIT_THREAD_DEBUG_EVENT:
        { процесс завершил исполнение потока. забудем его хэндл }
        DeleteThreadFromList(ThreadList, Event.dwThreadId);
      LOAD_DLL_DEBUG_EVENT:
        { процесс загрузил какую-то DLL'ку. проверим, не та ли
        это, которая нам нужна. если та, установим точку останова.
        текст процедуры смотрите ниже }
        ProcessDLLExport(HProc, DWORD(Event.LoadDll.lpBaseOfDll));
      UNLOAD_DLL_DEBUG_EVENT:
        { процесс выгрузил какую-то DLL'ку. по-правилам,
        это надо бы обработать, но поскольку я перехватываю вызовы kernel32.dll,
        который всегда (за очень-очень редким исключением :-) линкуется статически,
        то это событие я просто игнорирую. а вообще-то надо запомнить
        адрес загрузки нужной нам DLL в LOAD_DLL_DEBUG_EVENT
        (ибо это единственный способ идентифицировать DLL'ку),
        а здесь проверять - не наша ли это. если наша - обнулить BPAddr.
        можете дописать сами - как любят говорить авторы книг:
        "в качестве упражнения" :-) [Енота: ага. а сам, когда видит
        в книге эту фразу, разражается потоком нецензурной лексики :-)] }
        WriteLn('unloading DLL: ', IntToHex(DWORD(Event.UnloadDll.lpBaseOfDll), 8));
      EXCEPTION_DEBUG_EVENT:
        { какое-то исключение. проверим поточнее... }
        case Event.Exception.ExceptionRecord.ExceptionCode of
        EXCEPTION_BREAKPOINT:
        { это - точка останова. здесь мы уточним: наша или нет. дело в том,
        что система сама генерирует это событие, когда процесс загрузился,
        но перед тем, как он запущен (полсе того, как системный загрузчик
        загрузил процесс и все его DLL'ки. как раз перед тем, как исполнить
        первую инструкцию процесса). плюс - мало ли, какой код внутри
        исследуемого процесса может быть? так что... }
        begin
          dwContinueStatus := DBG_CONTINUE;
          { скажем системе, что это исключение мы обработали сами, пусть не напрягается }
          Context.ContextFlags := CONTEXT_CONTROL or CONTEXT_INTEGER or CONTEXT_SEGMENTS;
          GetThreadContext(CurThread, Context);
          { получили контекст прерванного потока. больше всего нас интересуют IP и Flags.
          остальные регистры запросили просто для полноты картины }
          if (BPAddr <> 0) and (Context.EIP = BPAddr + 1) then
          begin
            { если мы уже установили нашу точку останова и прервались именно на ней... }
            RetAddr := ReadProcessLong(HProc, Context.ESP);
            { то получим адрес возврата из перехваченной нами функции.
            он нам не нужен, на самом-то деле, это просто пример - откуда его брать.
            если вам нужны параметры - ReadProcessLong(HProc, Context.ESP + 4)
            будет первым, ...+ 8) - вторым, и так далее... кстати, ReadProcessLong -
            просто обертка для системной функции ReadProcessMemory. читает 4 байтика.
            для удобства. думаю, что у вас не будет проблем сделать себе такую же :-) }
            WriteLn('Return address: 0x', IntToHex(RetAddr, 8));
            { дальше - уменьшим IP на еденичку (чтобы исполнить ту инструкцию,
            которую мы заменили на нашу точку останова)... реально, EIP-1
            хранится в BPAddr. так и запишем... }
            Context.EIP := BPAddr;
            { ...и восстановим оригинальный первый байтик этой инструкции }
            WriteProcessByte(HProc, BPAddr, OrigByte);
            { установим флажок для того, чтобы система генерировала
            событие EXCEPTION_SINGLE_STEP. в этом событии надо будет вернуть
            точку останова на место, иначе перехват состоится ровно один раз :-)
            [Енота: а то бы читатель сам не догадался...] }
            RestoreBreak := True;
            Context.EFlags := Context.EFlags or EFLAGS_TRACE;
            { вышеприведенной инструкцией мы сообщаем системе,
            что хотим получать по событию (EXCEPTION_SINGLE_STEP) после каждой
            исполненной в отлаживаемом процессе машинной команды. кстати,
            значение константы EFLAGS_TRACE = $100 }
            Context.ContextFlags := CONTEXT_CONTROL;
            SetThreadContext(CurThread, Context);
            { установим новое значение регистров потока }
          end;
        end;
        EXCEPTION_SINGLE_STEP:
        { выполнена одна машинная команда. скорее всего,
        возниконовение этого события - результат выполнения нашей точки останова,
        но кто знает? проверим флажки. если надо - восстановим точку останова }
        begin
          dwContinueStatus := DBG_CONTINUE;
          { скажем системе, что это исключение мы обработали сами, пусть не напрягается }
          Context.ContextFlags := CONTEXT_CONTROL;
          GetThreadContext(CurThread, Context);
          if RestoreBreak and (Context.EIP >= BPAddr) and (Context.EIP <= BPAddr + 32) then
          begin
            { это действительно "наше" событие. восстановим точку останова,
            чтобы перехватчик работал и дальше }
            OrigByte := WriteInt3(HProc, BPAddr);
            RestoreBreak := False;

            Context.EFlags := Context.EFlags and not EFLAGS_TRACE;
            { сбросим флажок трассировки, ибо больше это событие нам не надо }
          end
          else
            if RestoreBreak then
              Context.EFlags := Context.EFlags or EFLAGS_TRACE;
          { вернем флажок трассировки, если событие не наше -
          нам ведь надо нашего дождаться. у меня система сама скидывает сей флаг,
          так что на всякий случай... }

          Context.ContextFlags := CONTEXT_CONTROL;
          SetThreadContext(CurThread, Context);
        end;
      end;
    end;

    if not ContinueDebugEvent(Event.dwProcessId, Event.dwThreadId, dwContinueStatus) then
      break;
    { все. смело позволяем отлаживаемому процессу исполняться дальше }
  until
    False;
  { сюда мы попадем только при каком-нибудь сбое или завершении процесса.
  на всякий случай (по совету SleepyHead'а) проверим: а точно наш
  отлаживаемый процесс завершился? если нет - прибьем руками }
  if not ProcessFinished then
  begin
    repeat
      TerminateProcess(HProc, RetAddr);
      if not WaitForDebugEvent(Event, INFINITE) then
        break;
      if (Event.dwDebugEventCode = EXIT_PROCESS_DEBUG_EVENT) then
        break;
      if not ContinueDebugEvent(Event.dwProcessId, Event.dwThreadId, DBG_CONTINUE) then
        break;
    until
      False;
    ContinueDebugEvent(Event.dwProcessId, Event.dwThreadId, DBG_CONTINUE);
  end;
  { все. закончили :-) }
end;

{ а вот процедурка, которая устанавливает точку останова }
procedure ProcessDLLExport(PrcH, Base: DWORD);
var
  DLLName: string;
  ExpTbl: TExportHeader;
  N: DWORD;
begin
  if (BPAddr <> 0) then
    exit;
  { если уже установлена - не делать ничего }
  if not FindExportTable(PrcH, Base, ExpTbl) then
    exit;
  { если не смогли найти в DLL'ке таблицу экспорта (мало ли...) -
  тоже ничего не делать }
  DLLName := ANSILowerCase(GetASCIIZString(PrcH, ExpTbl.NameRVA + Base));
  { получили имя DLL'ки }
  if (DLLName <> 'kernel32.dll') then
    exit;
  { не наша? если да - снова не делаем ничего }
  N := FindExportIndexByName(PrcH, Base, 'AllocConsole', ExpTbl);
  N := FindExportByIndex(PrcH, Base, N, ExpTbl);
  { нашли по таблице экспорта точку входа (если не нашли -
  опять же ничего делать не надо }
  if (N = 0) then
    exit;
  { а если нашли - запомним необходимую информацию и установим останов }
  BPAddr := N;
  OrigByte := WriteInt3(PrcH, N);
  { WriteInt3 просто возвращает в качестве результата старый байтик,
  и на его место записывает код $CC - инструкция Int3. когда система
  встречает эту инструкцию, она генерирует исключение EXCEPTION_BREAKPOINT }
end;