Получаем список графических классов зарегистрированных в 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:blablaimage.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.

Автор: vpbar

Источник