...

воскресенье, 8 сентября 2013 г.

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


This entry passed through the Full-Text RSS service — if this is your content and you're reading it on someone else's site, please read the FAQ at fivefilters.org/content-only/faq.php#publishers. Five Filters recommends:



Комментариев нет:

Отправить комментарий