Неправильное использование атомов и трудноуловимая бага в VCL

Поиск бага

Мучила меня долгое время бага, связанная с неадекватным поведением дельфийских контролов после длительного аптайма системы и интенсивной отладки. Списки переставали обновляться, кнопки нажиматься, поля ввода терять фокус. И все было печально, и перезапуск IDE не помогал. Более того, после перезапуска IDE — она сама начинала так же глючить. Приходилось перезагружаться.
Сегодня меня это достало, и я принялся её искать. Надо сказать не безрезультатно.
Залогировав оконные сообщения я стал анализировать что же пошло не так.
Выяснилось, что в модуле Control.pas есть такие строки:

function FindControl(Handle: HWnd): TWinControl;
var
  OwningProcess: DWORD;
begin
  Result := nil;
  if (Handle <> 0) and (GetWindowThreadProcessID(Handle, OwningProcess) <> 0) and
     (OwningProcess = GetCurrentProcessId) then
  begin
    if GlobalFindAtom(PChar(ControlAtomString)) = ControlAtom then
      Result := Pointer(GetProp(Handle, MakeIntAtom(ControlAtom)))
    else
      Result := ObjectFromHWnd(Handle);
  end;
end;

и GetProp(Handle, MakeIntAtom(ControlAtom)) всегда возвращает 0. Тут же выяснилось что ControlAtom почему то 0, и GlobalFindAtom(PChar(ControlAtomString)) возвращает тоже 0.
Инициализируются ControlAtomString и ControlAtom в процедуре InitControls, которая вызывается в секции инициализации модуля:

procedure InitControls;
var
  UserHandle: HMODULE;
begin
{$IF NOT DEFINED(CLR)}
  WindowAtomString := Format('Delphi%.8X',[GetCurrentProcessID]);
  WindowAtom := GlobalAddAtom(PChar(WindowAtomString));
  ControlAtomString := Format('ControlOfs%.8X%.8X', [HInstance, GetCurrentThreadID]);
  ControlAtom := GlobalAddAtom(PChar(ControlAtomString));
  RM_GetObjectInstance := RegisterWindowMessage(PChar(ControlAtomString));
{$IFEND}

ControlAtomString заполняется корректно, а вот ControlAtom заполняется нулем. Проверок на ошибки тут нет, поэтому это аукнулось гораздо позже, увы. Если вставить GetLastError после GlobalAddAtom, то он вернет ERROR_NOT_ENOUGH_MEMORY. А если еще внимательно почитать ремарку на MSDN к GlobalAddAtom, то можно заметить:

Global atoms are not deleted automatically when the application terminates. For every call to the GlobalAddAtom function, there must be a corresponding call to the GlobalDeleteAtom function.

Все сразу становится понятно. Если некорректно завершить приложение — то утекут глобальные атомы. А именованных атомов у нас кот наплакал: 0xC000-0xFFFF, то есть всего 16383. Т.е. каждая dll, и каждый exe-шник написанный на Delphi с использованием VCL при некорректном завершении оставляет после себя утекшие глобальные атомы. Если быть точнее — то по 2-3 атома на каждый инстанс:
ControlAtom и WindowAtom в Controls.pas, и WndProcPtrAtom в Dialogs.pas

Workaround

Посмотреть созданные атомы не составит труда. Вот код простенького приложения, перечисляющего глобальные строковые атомы:

program EnumAtomsSample;

{$APPTYPE CONSOLE}

uses
  Windows,
  SysUtils;

function GetAtomName(nAtom: TAtom): string;
var n: Integer;
    tmpstr: array [0..255] of Char;
begin
  n := GlobalGetAtomName(nAtom, PChar(@tmpstr[0]), 256);
  if n = 0 then
    Result := ''
  else
    Result := tmpstr;
end;

procedure EnumAtoms;
var i: Integer;
    s: string;
begin
  for i := MAXINTATOM to MAXWORD do
    begin
      s := GetAtomName(i);
      if (s <> '') then WriteLn(s);
    end;
end;

begin
  try
    EnumAtoms;
    ReadLn;
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
end.

Можно убедится что атомы текут запустив любой VCL проект, и прибив его через диспетчер задач.

Поскольку атомы глобальные, то мы их можем прибивать вне зависимости от того кем они были созданы. Осталось как-то научиться определять что атом утекший.
Если обратить внимание на имена атомов, то для
WndProcPtrAtom — это WndProcPtr [HInstance] [ThreadID]
ControlAtom — это ControlOfs [HInstance] [ThreadID]
WindowAtom — это Delphi [ProcessID]
Во всех случаях мы можем понять что атом скорее всего создан Delphi по специфичному префиксу + одно или два 32-х битных числа в HEX-е. Кроме того в HEX записан либо ProcessID либо ThreadID. Мы легко можем проверить есть такой процесс или поток в системе. Если нет — то у нас явно утекший атом, и мы можем рискнуть его освободить. Да да, именно рискнуть. Дело в том, что после того как мы убедились что потока/процесса с таким ID нет, и собрались удалять атом — этот процесс может появиться, с ровно таким же ID, и оказаться процессом Delphi. Если в промежуток между проверкой и удалением такое произойдет — то мы прибьем атом у валидного приложения. Ситуация крайне маловероятна, ибо в промежуток между проверкой должен создаться обязательно дельфийский процесс, обязательно ровно по тому же ID, и обязательно успеть проинициализировать свои атомы. Других workaround-ов (без правки VCL кода) для решения этой проблемы я не вижу.

Я написал консольную тулзу, для чистки таких утекших глобальных атомов.

program AtomCleaner;

{$APPTYPE CONSOLE}

uses
  Windows,
  SysUtils;

const
  THREAD_QUERY_INFORMATION = $0040;

function OpenThread(dwDesiredAccess: DWORD; bInheritHandle: BOOL; dwThreadId: DWORD): THandle; stdcall; external kernel32;

function ThreadExists(const ThreadID: Cardinal): Boolean;
var h: THandle;
begin
  h := OpenThread(THREAD_QUERY_INFORMATION, False, ThreadID);
  if h = 0 then
  begin
    Result := False;
  end
  else
  begin
    Result := True;
    CloseHandle(h);
  end;
end;

function TryHexChar(c: Char; out b: Byte): Boolean;
begin
  Result := True;
  case c of
    '0'..'9':  b := Byte(c) - Byte('0');
    'a'..'f':  b := (Byte(c) - Byte('a')) + 10;
    'A'..'F':  b := (Byte(c) - Byte('A')) + 10;
  else
    Result := False;
  end;
end;

function TryHexToInt(const s: string; out value: Cardinal): Boolean;
var i: Integer;
    chval: Byte;
begin
  Result := True;
  value := 0;
  for i := 1 to Length(s) do
  begin
    if not TryHexChar(s[i], chval) then
      begin
        Result := False;
        Exit;
      end;
    value := value shl 4;
    value := value + chval;
  end;
end;

function GetAtomName(nAtom: TAtom): string;
var n: Integer;
    tmpstr: array [0..255] of Char;
begin
  n := GlobalGetAtomName(nAtom, PChar(@tmpstr[0]), 256);
  if n = 0 then
    Result := ''
  else
    Result := tmpstr;
end;


function CloseAtom(nAtom: TAtom): Boolean;
var n: Integer;
    s: string;
begin
  Result := False;
  s := GetAtomName(nAtom);
  if s = '' then Exit;
  WriteLn('Closing atom: ', IntToHex(nAtom, 4), ' ', s);
  GlobalDeleteAtom(nAtom);
  Result := True;
end;

function ProcessAtom(nAtom: TAtom): Boolean;
var s: string;
    n: Integer;
    id: Cardinal;
begin
  Result := False;
  s := GetAtomName(nAtom);

  n := Pos('ControlOfs', s);
  if n = 1 then
  begin
    Delete(s, 1, Length('ControlOfs'));
    if Length(s) <> 16 then Exit;
    Delete(s, 1, 8);
    if not TryHexToInt(s, id) then Exit;
    if not ThreadExists(id) then
        Exit(CloseAtom(nAtom));
    Exit;
  end;

  n := Pos('WndProcPtr', s);
  if n = 1 then
  begin
    Delete(s, 1, Length('WndProcPtr'));
    if Length(s) <> 16 then Exit;
    Delete(s, 1, 8);
    if not TryHexToInt(s, id) then Exit;
    if not ThreadExists(id) then
        Exit(CloseAtom(nAtom));
    Exit;
  end;

  n := Pos('Delphi', s);
  if n = 1 then
  begin
    Delete(s, 1, Length('Delphi'));
    if Length(s) <> 8 then Exit;
    if not TryHexToInt(s, id) then Exit;
    if GetProcessVersion(id) = 0 then
      if GetLastError = ERROR_INVALID_PARAMETER then
        Exit(CloseAtom(nAtom));
    Exit;
  end;
end;

procedure EnumAndCloseAtoms;
var i: Integer;
begin
  i := MAXINTATOM;
  while i <= MAXWORD do
  begin
    if not ProcessAtom(i) then
        Inc(i);
  end;
end;

begin
  try
    EnumAndCloseAtoms;
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
end.

Просто запускаем, утекшие атомы чистятся. Проверьтесь, возможно прямо сейчас у вас в системе уже есть утекшие атомы.

В заключение

Инспекция кода показала, что данные глобальные атомы используются только для SetProp и GetProp функций. Совершенно непонятно почему разработчики Delphi решили использовать атомы. Ведь обе эти функции прекрасно работают с указателями на строки. Достаточно передавать уникальную строку, которая сама по себе уже есть, ведь с ней инициализируется атом.
Так же непонятна логика вот таких сравнений в VCL коде:
if GlobalFindAtom(PChar(ControlAtomString)) = ControlAtom then
Обе переменных инициализируются в одном месте. Строка собирается уникальной (из HInstance и ThreadID). Проверка всегда будет возвращать True. Увы, Delphi сейчас продвигает новые фичи, FMX-ы всякие. Вряд ли они будут фиксить эту багу. Лично у меня даже желания на QC репортить нет, зная как оно фиксится. Но жить с этим как-то надо. Желающие могут выполнять код вышеприведенной тулзы при старте своего приложения. На мой взгляд это всяко лучше, чем дожидаться утекших атомов.
Ну и в собственных разработках нужно стараться избегать глобальных атомов, ибо ОС не контролирует их утечки.

Тулзы + исходники

Автор: MrShoor

Источник