Получаем список графических классов зарегистрированных в TPicture.RegisterFileFormat

    В заметке описано, как можно использовать отладочный менеджер памяти в Delphi, чтобы определить все зарегистрированные графические классы.
    Вначале короткое вступление с описанием вещей известных целевой аудитории. Но поскольку вступление должно быть, то пусть будет такое.
    В Delphi VCL есть штатный механизм поддержки разных форматов изображений. Есть класс TPicture, который может грузить картинки разных форматов. Нужный графический класс определяется по расширению файла.
    Графический класс регистрируется вызовом TPicture.RegisterFileFormat куда передается расширение файла и класс ему соответствующий (например TPicture.RegisterFileFormat('PNG', 'Portable Network Graphics', TPNGObject);)
    Далее при загрузке картинки в TPicture.LoadFromFile ищется класс, зарегистрированный для расширения этого файла. Создается экземпляр найденного класса и уже он грузит картинку из файла.
    Нюанс в том, что можно регистрировать несколько классов на одно расширение. Использоваться будет последний. Но определить какой именно класс зарегистрирован последним не всегда просто. Даже если все классы традиционно зарегистрированы в initialization своих модулей. Порядок инициализации модулей не всегда очевиден. И ничто не мешает вызвать RegisterFileFormat уже после инициализации модулей где-то в коде.
    Механизмы работы с списком зарегистрированных графических классов в TPicture скрыты и нет штатной возможности узнать какой именно класс зарегистрирован для определенного расширения. Хотя обратная задача решается элементарно вызовом GraphicExtension. Так же можно загрузить картинку интересующего формата в экземпляр TPicture и посмотреть что за класс в TPicture.Graphic.
    Picture.LoadFromFile('c:\bla\bla\image.png');
    Picture.Graphic.ClassName;
    
    В принципе, на практике для тестирования или отладки этого достаточно.Но мне стало интересно, как можно получить все классы зарегистрированные в RegisterFileFormat.
    Оказалось, что это возможно и в даже не требует грязных хаков.
    К проекту потребуется подключить FastMM4. И настроить его для большей информативности (включить FullDebugMode в FastMM4Options.inc).Для получения детальной информации добавить в FastMM4 и вынести в интерфейсы модуля функцию
    function GetStackTraceAsText(AReturnAddresses: PNativeUInt): string;
    var
      LErrorMessage: array[0..32767] of AnsiChar;
      LMsgPtr: PAnsiChar;
    begin
      LMsgPtr := LogStackTrace(AReturnAddresses, StackTraceDepth, @LErrorMessage[0]);
      inc(LMsgPtr);
      LMsgPtr^ := #0;
      Result := LErrorMessage;
    end;
    
    Далее код демки с комментариями, надеюсь понятный без дополнительных описаний. Суть решения описана в GetGraphClasses.
    program LogRegisterFileFormat;
    {$APPTYPE CONSOLE}
    uses
      FastMM4, {в FastMM4Options.inc надо включить FullDebugModeCallBacks и FullDebugMode}
      SysUtils, Classes, Graphics, Jpeg, pngimage;
    
    var
      LastClassName: string;
      
    function GetClassCreateLine(AStack: string): string;
    {Находит в логе стека вызовов строку с вызовом конструктора}
    var
      P: Integer;
      L: Integer;
      R: Integer;
    begin
      P := Pos('.Create]', AStack);
      if P > 0 then
      begin
        L := P;
        while (L > 1) and (AStack[L] > #32) do
          dec(L);
        inc(L);
        R := P;
        while (R < Length(AStack)) and (AStack[R] > #32) do
          inc(R);
        Result :=  Copy(AStack, L, R - L);
      end
      else
        Result := AStack;
    end;
    
    procedure DoCustomMemFree(APHeaderFreedBlock: PFullDebugBlockHeader; AResult: Integer);
    {Вызывается при освобождении памяти}
    var
      LClass: TClass;
    begin
      {Определяет что освобождается память объекта}
      LClass := DetectClassInstance(@APHeaderFreedBlock.PreviouslyUsedByClass);
      if LClass <> nil then
      begin
        {Для наследников TGraphic сохраняет в LastClassName имя класса и строку из стека вызовов}
        if LClass.InheritsFrom(TGraphic) then
        begin
          LastClassName := LClass.ClassName;
          {Если есть данные о стеке вызовов, то добавить данные по вызову конструктора}
          if APHeaderFreedBlock.AllocationStackTrace[0] <> 0 then
            LastClassName := LastClassName + ' ' + GetClassCreateLine(GetStackTraceAsText(@APHeaderFreedBlock.AllocationStackTrace));
        end;
      end;
    end;
    
    function Fetch(var Value: string; const Delimiter: string): string;
    {Отрезает часть строки от Value до разделителя и возвращает ее в результат. Копипаста из Synapse, используемая для перебора подстрок по разделителю}
    var
      P: Integer;
    begin
      P := Pos(Delimiter, Value);
      if P < 1 then
      begin
        Result := Value;
        Value := '';
      end
      else
      begin
        Result := Copy(Value, 1, P - 1);
        Delete(Value, 1, P + Length(Delimiter));
      end;
      Result := Trim(Result);
      Value := Trim(Value);
    end;
    
    procedure GetGraphClasses(const AStrings: TStrings);
    var
      Filters: string;
      FileMask: string;
      FileExt: string;
      Pic: TPicture;
    begin
      {Получаем список зарегистрированных расширений вида '*.png;*.jpg'}
      Filters := GraphicFileMask(TGraphicClass(TObject));
      {Цикл для каждой отдельной маски файла}
      FileMask := Fetch(Filters, ';');
      while Length(FileMask) > 0 do
      begin
        Pic := TPicture.Create;
        FileExt :=  ExtractFileExt(FileMask);
        try
          try
            LastClassName := '';
            {Вешаем обработчик на освобождение памяти}
            FastMM4.OnDebugFreeMemFinish := DoCustomMemFree;
            {Грузим несуществующий файл с данным расширеним
            Будет найден класс для этого расширения и создан его экземпляр.
            Вызван его метод LoadFromFile, который для пустого имени файла должен кинуть исключение.
            При этом экземпляр будет освобожден и в обработчике DoCustomMemFree будет определено какой это класс}
            Pic.LoadFromFile(FileExt);
            {На случай если какой-то класс не кидает исключение, а создаст, например, пустую картинку}
            if Pic.Graphic <> nil then
              AStrings.Add(FileMask + ' = ' + Pic.Graphic.ClassName);
          except
            {На это момент графический класс будет освобожден. И в LastClassName будет требуемая информация.}
            AStrings.Add(FileMask + ' = ' + LastClassName);
            LastClassName := '';
          end;
        finally
          FreeAndNil(Pic);
          FastMM4.OnDebugFreeMemFinish := nil;
        end;
        {Продолжаем цикл по оставшимся маскам файла из Filters}
        FileMask := Fetch(Filters, ';');
      end;
    end;
    
    var
      Log: TStringList;
    begin
      Log := TStringList.Create;
      GetGraphClasses(Log);
      Log.SaveToFile(ParamStr(0) + '.log');
      Log.Free;
    end.
    

    Similar posts

    AdBlock has stolen the banner, but banners are not teeth — they will be back

    More
    Ads

    Comments 2

      0
      Я бы не назвал это «без грязных хаков». Если вам так нужно получить наследников TGraphic, то гораздо лучше просто внести правки в VCL и подключить измененый модуль к проекту. А это все более чем грязный хак, я уж умалчиваю о том, на сколько медленно он будет работать. На сколько я понимаю вы каждый удаляемый объект проверяете на причастность к TGraphic, а значит тяжесть алгоритма линейно растет с ростом программы, что для такой простой задачи совершенно неприемлимо.
      Я уж молчу про то, что вы отлавливаете объекты на их удалении, что поднимает вопрос о том, а в какой момент полный список будет вообще доступен? Будет ли он доступен в консольном приложении?
        0
        Для начала отвечу на вопрос. Да будет. Демка это как раз консольное приложение.

        Не каждый удаляемый объект проверяется на причастность к TGraphic. Только пока висит обработчик OnDebugFreeMemFinish. После получения списка он обнуляется и все работает как обычно с включенной отладкой в FastMM. Соответственно далее работать будет не медленнее чем обычно работает с отладкой памяти в FastMM.

      Only users with full accounts can post comments. Log in, please.