When any TGraphic descendant registering its own graphic file format with a class procedure TPicture.RegisterFileFormat(), they're all stored in Graphics.FileFormats global variable.
Too bad that FileFormats variable is not in the "interface" section of "Graphics.pas", so I can't access it. I need to read this variable to implement a special filter for my file-list control.
Can I get that list without manual fixing the Graphics.pas's source code?
You are working with a file-list control, and presumably thus a list of filenames. If you don't need to know the actual TGraphic class types that are registered, only whether a given file extension is registered or not (such as to check if a later call to TPicture.LoadFromFile() is likely to succeed), you can use the public GraphicFileMask() function to get a list of registered file extensions and then compare your filenames to that list. For example:
uses
SysUtils, Classes, Graphics, Masks;
function IsGraphicClassRegistered(const FileName: String): Boolean;
var
Ext: String;
List: TStringList;
I: Integer;
begin
Result := False;
Ext := ExtractFileExt(FileName);
List := TStringList.Create;
try
List.Delimiter := ';';
List.StrictDelimiter := True;
List.DelimitedText := GraphicFileMask(TGraphic);
for I := 0 to List.Count-1 do
begin
if MatchesMask(FileName, List[I]) then
begin
Result := True;
Exit;
end;
end;
finally
List.Free;
end;
end;
Or, you could simply load the file and see what happens:
uses
Graphics;
function GetRegisteredGraphicClass(const FileName: String): TGraphicClass;
var
Picture: TPicture;
begin
Result := nil;
try
Picture := TPicture.Create;
try
Picture.LoadFromFile(FileName);
Result := TGraphicClass(Picture.Graphic.ClassType);
finally
Picture.Free;
end;
except
end;
end;
Update: if you want to extract the extensions and descriptions, you can use TStringList.DelimitedText to parse the result of the GraphicFilter() function:
uses
SysUtils, Classes, Graphics;
function RPos(const ASub, AIn: String; AStart: Integer = -1): Integer;
var
i: Integer;
LStartPos: Integer;
LTokenLen: Integer;
begin
Result := 0;
LTokenLen := Length(ASub);
// Get starting position
if AStart < 0 then begin
AStart := Length(AIn);
end;
if AStart < (Length(AIn) - LTokenLen + 1) then begin
LStartPos := AStart;
end else begin
LStartPos := (Length(AIn) - LTokenLen + 1);
end;
// Search for the string
for i := LStartPos downto 1 do begin
if Copy(AIn, i, LTokenLen) = ASub then begin
Result := i;
Break;
end;
end;
end;
procedure GetRegisteredGraphicFormats(AFormats: TStrings);
var
List: TStringList;
i, j: Integer;
desc, ext: string;
begin
List := TStringList.Create;
try
List.Delimiter := '|';
List.StrictDelimiter := True;
List.DelimitedText := GraphicFilter(TGraphic);
i := 0;
if List.Count > 2 then
Inc(i, 2); // skip the "All" filter ...
while i <= List.Count-1 do
begin
desc := List[i];
ext := List[i+1];
j := RPos('(', desc);
if j > 0 then
desc := TrimRight(Copy(desc, 1, j-1)); // remove extension mask from description
AFormats.Add(ext + '=' + desc);
Inc(i, 2);
end;
finally
List.Free;
end;
end;
Update 2: if you are just interested in a list of registered graphic file extensions, then, assuming List is an already created TStrings descendant, use this:
ExtractStrings([';'], ['*', '.'], PChar(GraphicFileMask(TGraphic)), List);
The GlScene project has a unit PictureRegisteredFormats.pas that implements a hack for that.
Here's an alternative hack that might be safer then the GLScene solution. It's still a hack, because the desired structure is global but in the implementation section of the Graphics.pas unit, but my method uses a lot less "maigc constants" (hard-coded offsets into the code) and uses two distinct methods to detect the GetFileFormats function in Graphics.pas.
My code exploits the fact that both TPicture.RegisterFileFormat and TPicture.RegisterFileFormatRes need to call the Graphics.GetFileFormats function immediately. The code detects the relative-offset CALL opcode and registers the destination address for both. Only moves forward if both results are the same, and this adds a safety-factor. The other safety-factor is the detection method itself: even if the prologue generated by the compiler would change, as long as the first function called is GetFileFormats, this code finds it.
I'm not going to put the "Warning: This will crash when Graphics.pas is compiled with the 'Use Debug DCUs' option." at the top of the unit (as found in the GLScene code), because I've tested with both debug dcu's and no debug dcu's and it worked. Also tested with packages and it still worked.
This code only works for 32bit targets, hence the extensive use of Integer for pointer operations. I will attempt making this work for 64bit targets as soon as I'll get my Delphi XE2 compiler installed.
Update: A version supporting 64 bit can be found here: https://stackoverflow.com/a/35817804/505088
unit FindReigsteredPictureFileFormats;
interface
uses Classes, Contnrs;
// Extracts the file extension + the description; Returns True if the hack was successful,
// False if unsuccesful.
function GetListOfRegisteredPictureFileFormats(const List: TStrings): Boolean;
// This returns the list of TGraphicClass registered; True for successful hack, false
// for unsuccesful hach
function GetListOfRegisteredPictureTypes(const List:TClassList): Boolean;
implementation
uses Graphics;
type
TRelativeCallOpcode = packed record
OpCode: Byte;
Offset: Integer;
end;
PRelativeCallOpcode = ^TRelativeCallOpcode;
TLongAbsoluteJumpOpcode = packed record
OpCode: array[0..1] of Byte;
Destination: PInteger;
end;
PLongAbsoluteJumpOpcode = ^TLongAbsoluteJumpOpcode;
TMaxByteArray = array[0..System.MaxInt-1] of Byte;
PMaxByteArray = ^TMaxByteArray;
TReturnTList = function: TList;
// Structure copied from Graphics unit.
PFileFormat = ^TFileFormat;
TFileFormat = record
GraphicClass: TGraphicClass;
Extension: string;
Description: string;
DescResID: Integer;
end;
function FindFirstRelativeCallOpcode(const StartOffset:Integer): Integer;
var Ram: PMaxByteArray;
i: Integer;
PLongJump: PLongAbsoluteJumpOpcode;
begin
Ram := nil;
PLongJump := PLongAbsoluteJumpOpcode(@Ram[StartOffset]);
if (PLongJump^.OpCode[0] = $FF) and (PLongJump^.OpCode[1] = $25) then
Result := FindFirstRelativeCallOpcode(PLongJump^.Destination^)
else
begin
for i:=0 to 64 do
if PRelativeCallOpcode(@Ram[StartOffset+i])^.OpCode = $E8 then
Exit(StartOffset + i + PRelativeCallOpcode(@Ram[StartOffset+i])^.Offset + 5);
Result := 0;
end;
end;
procedure FindGetFileFormatsFunc(out ProcAddr: TReturnTList);
var Offset_from_RegisterFileFormat: Integer;
Offset_from_RegisterFileFormatRes: Integer;
begin
Offset_from_RegisterFileFormat := FindFirstRelativeCallOpcode(Integer(@TPicture.RegisterFileFormat));
Offset_from_RegisterFileFormatRes := FindFirstRelativeCallOpcode(Integer(@TPicture.RegisterFileFormatRes));
if (Offset_from_RegisterFileFormat = Offset_from_RegisterFileFormatRes) then
ProcAddr := TReturnTList(Pointer(Offset_from_RegisterFileFormat))
else
ProcAddr := nil;
end;
function GetListOfRegisteredPictureFileFormats(const List: TStrings): Boolean;
var GetListProc:TReturnTList;
L: TList;
i: Integer;
begin
FindGetFileFormatsFunc(GetListProc);
if Assigned(GetListProc) then
begin
Result := True;
L := GetListProc;
for i:=0 to L.Count-1 do
List.Add(PFileFormat(L[i])^.Extension + '=' + PFileFormat(L[i])^.Description);
end
else
Result := False;
end;
function GetListOfRegisteredPictureTypes(const List:TClassList): Boolean;
var GetListProc:TReturnTList;
L: TList;
i: Integer;
begin
FindGetFileFormatsFunc(GetListProc);
if Assigned(GetListProc) then
begin
Result := True;
L := GetListProc;
for i:=0 to L.Count-1 do
List.Add(PFileFormat(L[i])^.GraphicClass);
end
else
Result := False;
end;
end.
