Get the list of graphic classes registered in TPicture.RegisterFileFormat

The note describes how to use the debug memory manager in Delphi to determine all registered graphic classes.
Initially, a short introduction with a description of things known to the target audience. But since the introduction should be, then let it be.
In Delphi VCL there is a regular mechanism for supporting various image formats. There is a class TPicture, which can load pictures of different formats. The desired graphic class is determined by the file extension.
The graphic class is registered by calling TPicture.RegisterFileFormat where the file extension and the corresponding class are transferred to it (for example, TPicture.RegisterFileFormat ('PNG', 'Portable Network Graphics', TPNGObject); )
Further, when loading a picture into TPicture.LoadFromFile, the class registered for the extension of this file is searched. An instance of the found class is created and it already loads the image from the file.
The nuance is that you can register several classes for one extension. The last one will be used. But it is not always easy to determine which class is registered last. Even if all classes are traditionally registered in the initialization of their modules. The order of initialization of modules is not always obvious. And nothing prevents to call RegisterFileFormat after the modules are initialized somewhere in the code.
The mechanisms for working with the list of registered graphic classes in TPicture are hidden and there is no regular opportunity to find out which particular class is registered for a specific extension. Although the inverse problem is solved simply by calling GraphicExtension. You can also upload a picture of the format of interest to the TPicture instance and see what kind of class in TPicture.Graphic.

Picture.LoadFromFile('c:\bla\bla\image.png'); Picture.Graphic.ClassName; 

In principle, in practice it is enough for testing or debugging. But I was wondering how to get all the classes registered in RegisterFileFormat.
It turned out that this is possible and does not even require dirty hacks.
The project will need to connect FastMM4. And configure it to be more informative (enable FullDebugMode in FastMM4Options.inc). For more information, add to FastMM4 and add a function to the module interfaces

 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; 

Further, the demo code with comments, I hope understandable without additional descriptions. The essence of the solution is described in 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.