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

    image

    Поиск бага


    Мучила меня долгое время бага, связанная с неадекватным поведением дельфийских контролов после длительного аптайма системы и интенсивной отладки. Списки переставали обновляться, кнопки нажиматься, поля ввода начинали терять фокус. И все было печально, и перезапуск 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 репортить нет, зная как оно фиксится. Но жить с этим как-то надо. Желающие могут выполнять код вышеприведенной тулзы при старте своего приложения. На мой взгляд это всяко лучше, чем дожидаться утекших атомов.
    Ну и в собственных разработках нужно стараться избегать глобальных атомов, ибо ОС не контролирует их утечки.

    Тулзы + исходники
    Метки:
    Поделиться публикацией
    Похожие публикации
    Комментарии 12
    • +1
      Вопрос автору (зная, что многие до сих пор пользуются 7 версией): какой версией Delphi Вы пользуетесь? Этот недочет точно актуален для последних версий? В любом случае большое спасибо за информацию и за решение.
      • +1
        Я проверял в Delphi 7, Delphi 2010, Delphi XE5. Я думаю что это есть во всех версиях делфи. Код VCL не менялся.
        • +1
          после длительного аптайма системы и интенсивной отладки. Списки переставали обновляться, кнопки нажиматься, поля ввода терять фокус. И все было печально, и перезапуск IDE не помогал. Более того, после перезапуска IDE — она сама начинала так же глючить.

          Сидишь работаешь и тут делфи начинает выбешивать своими глюками… ох как это знакомо.
          Кстати stackoverflow.com/questions/514812/which-bug-in-the-delphi-ide-vcl-do-you-despise-the-most
          • 0
            Хех, почитал. :)
            Это они еще в TLB редакторе дельфийском не работали. Вот где песня.
            • 0
              Меня настолько достали глюки tlb-редактора, что я сел и изучил idl. С тех пор не пользуюсб этим глюкаловом.
    • +2
      Интересно очень, спасибо. На QC все же лучше напишите. Кто ж знает, так хотя бы будет шанс, что исправят :)
    • 0
      Спасибо, очень полезно. А нет ли ресурса, где собраны подобные баги Delphi с их решением? Было бы не лишним провести системе профилактическое лечение.
    • 0
      >> Можно убедится что атомы текут запустив любой VCL проект, и прибив его через диспетчер задач.
      А если CTRL+F2 нажать, атомы тоже утекут?
      • 0
        Естественно утекут.
    • 0
      Пора переходить на FPC/Lazarus, там баги правятся в день обнаружения.
      • +1
        Там дебагер — плакать хочется. Пилю сейчас небольшой проектик на лазарусе.

    Только полноправные пользователи могут оставлять комментарии. Войдите, пожалуйста.