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