Сжатие DFM ресурсов в Delphi программах

Захотелось мне как-то попробовать сжать ресурсы dfm форм своего приложения, плюсы довольно спорные (сложные формы могут содержать много графических ресурсов которые в dfm файле хранятся как буфер с bmp, который можно неплохо сжать, так же защита от просмотра и редактирования ресурсов форм), но ведь есть несколько программ позволяющих такое делать, значит кому-то нужно.

Напишем приложение DFMCompressor, которое будет извлекать dfm ресурсы из exe файла, сжимать их и записывать обратно заменяя оригиналы.

Алгоритм работы компрессора

Компрессор находит dfm ресурсы и сжимает их. Всю его работу можно разложить на шаги:

• Извлечь все DFM ресурсы приложения
• Сжать их
• Удалить из приложения найденные ресурсы
• Записать сжатые ресурсы в приложение

Для единообразия дальнейшего кода реализации указанных шагов введем специальный тип, словарь, который будет содержать имя ресурса и его тело:

type
  //Словарь содержащий имена DFM ресурсов и их содержимое 
  TDFMByNameDict = TObjectDictionary<string, TMemoryStream>;

Большая часть компрессора завязана на работу с ресурсами exe файла. Windows API содержит функции для работы с ресурсами ^[1], нам понадобятся две основные функции:

• EnumResourceNames — получение имен ресурсов
• UpdateResource — добавление/удаление ресурсов

Так как мы будем работать с ресурсами только в контексте Delphi DFM ресурсов, то, чтобы упростить код, сделаем следующие допущения:

• Все операции относятся только к ресурсам типа RT_RCDATA
• LangId ресурсов всегда используется 0, так как именно такой LangId у dfm форм

Поиск DFM ресурсов

Алгоритм простой, пройдем по всем ресурсам из RT_RCDATA, и проверим являются ли они DFM ресурсами.

DFM ресурсы имеют сигнатуру, первые 4 байта содержат строку 'TPF0', напишем функцию чтобы проверять:

function IsDfmResource(Stream: TStream): Boolean;
const
  FilerSignature: array [1..4] of AnsiChar = AnsiString('TPF0');
var
  Signature: LongInt;
begin
  Stream.Position := 0;
  stream.Read(Signature, SizeOf(Signature));

  Result := Signature = LongInt(FilerSignature);
end;

Теперь, умея отличать DFM ресурсы от остальных напишем функцию получения их:

function LoadDFMs(const FileName: string): TDFMByNameDict;

  //Callback-функция для перечисления имен ресурсов
  //вызывается когда найден очередной ресурс указанного типа
  function EnumResNameProc(Module: THandle; ResType, ResName: PChar;
    lParam: TDFMByNameDict): BOOL; stdcall;
  var
    ResStream: TResourceStream;
  begin
    Result := True;

    //Откроем ресурс
    ResStream := TResourceStream.Create(Module, ResName, ResType);
    try
      //Если это не DFM выходим
      if not IsDfmResource(ResStream) then
        Exit;

      //Если DFM ресурс, то скопируем его тело в результирующий список
      lParam.Add(ResName, TMemoryStream.Create);
      lParam[ResName].CopyFrom(ResStream, 0);
    finally
      FreeAndNil(ResStream);
    end;
  end;

var
  DllHandle: THandle;
begin
  Result := TDFMByNameDict.Create([doOwnsValues]);
  try
    DllHandle := LoadLibraryEx(PChar(FileName), 0, LOAD_LIBRARY_AS_DATAFILE);
    Win32Check(DllHandle <> 0);
    try
      EnumResourceNamesW(DllHandle, RT_RCDATA, @EnumResNameProc, Integer(Result));
    finally
      FreeLibrary(DllHandle);
    end;
  except
    FreeAndNil(Result);
    raise;
  end;
end;

Cжимаем содержимое найденных ресурсов

Жать будем с помощью Zlib, вот такая функция сжимает TMemoryStream:

procedure ZCompressStream(Source: TMemoryStream);
var
  pOut: Pointer;
  outSize: Integer;
begin
  ZCompress(Source.Memory, Source.Size, pOut, outSize, zcMax);
  try
    Source.Size := outSize;
    Move(pOut^, Source.Memory^, outSize);
    Source.Position := 0;
  finally
    FreeMem(pOut);
  end;
end;

Теперь легко написать процедуру которая будет сжимать все ресурсы из нашего списка:

procedure CompressDFMs(DFMs: TDFMByNameDict);
var
  Stream: TMemoryStream;
begin
  for Stream in DFMs.Values do
    ZCompressStream(Stream);
end;

Удаление ресурсов

Чтобы удалить ресурс нужно вызвать функцию UpdateResource и передать в нее пустой указатель на данные. Но штука в том, что удаление ресурсов реализовано так, что оно не уменьшает exe файл, Windows просто удаляет запись о ресурсе из таблицы ресурсов, при этом место который занимал ресурс остается и никуда не перераспределяется. У нас цель не просто зашифровать dfm'ки, но и уменьшить на их сжатии общий размер программы, поэтому Win API не поможет. Благо есть решение, библиотека madBasic из madCollection ^[2] содержит модуль madRes.pas ^[3], в котором реализованы функции по работе с ресурсами, в том числе и удаление ресурсов, при этом авторы постарались и сделали вызов функций совместимым по синтаксису с Windows API, за что отдельное спасибо.

Зная все это процедура удаления ресурсов получилась такой:

procedure DeleteDFMs(const FileName: string; DFMs: TDFMByNameDict);
var
  ResName: string;
  Handle: THandle;
begin
  Handle := MadRes.BeginUpdateResourceW(PChar(FileName), False);
  Win32Check(Handle <> 0);
  try
    for ResName in DFMs.Keys do
      Win32Check(MadRes.UpdateResourceW(Handle, RT_RCDATA, PChar(ResName),
        0, nil, 0));
  finally
    Win32Check(MadRes.EndUpdateResourceW(Handle, False));
  end;
end;

Добавляем ресурсы в приложение

Добавить ресурсы не сложнее чем удалить, вот код:

//Добавление ресурсов в EXE файл
procedure AddDFMs(const FileName: string; DFMs: TDFMByNameDict);
var
  Handle: THandle;
  Item: TPair<string, TMemoryStream>;
begin
  Handle := BeginUpdateResource(PChar(FileName), False);
  Win32Check(Handle <> 0);
  try
    for Item in DFMs do
      Win32Check(UpdateResource(Handle, RT_RCDATA, PChar(Item.Key),
        0, Item.Value.Memory, Int64Rec(Item.Value.Size).Lo));
  finally
    Win32Check(EndUpdateResource(Handle, False));
  end;
end;

Я думаю код вопросов не вызовет. Мы разобрали и написали код для всех шагов нашего алгоритма, самое время собрать приложение реализующее нужный функционал.

Финальные штрихи компрессора

Напишем основную процедуру которая будет реализовывать все вышеописанные шаги вместе взятые:

//Основная рабочая процедура
procedure ExecuteApplication(const FileName: string);
var
  DFMs: TDFMByNameDict;
begin
  //Получим все DFM ресурсы из файла
  DFMs := LoadDFMs(FileName);
  try
    //Если таких не найдено, выходим
    if DFMs.Count = 0 then
      Exit;

    //Сожмем тело ресурсов
    CompressDFMs(DFMs);

    //Удалим найденные ресурсы из файла
    DeleteDFMs(FileName, DFMs);

    //Запишем вместо них новые, сжатые
    AddDFMs(FileName, DFMs);
  finally
    FreeAndNil(DFMs);
  end;
end;

Собственно уже вполне можно собрать приложение. Создадим в Delphi новый проект консольного приложения, сохраним его с именем dfmcompressor.dpr и сделаем программу:

program dfmcompressor;

{$APPTYPE CONSOLE}

uses
  Windows, SysUtils, Classes, Generics.Collections, ZLib,

  madRes;

  //
  // Тут должны располагаться все вышенаписанные процедуры
  //

begin
  try
    ExecuteApplication(ParamStr(1));
    Writeln('Done.')
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
end.

Собираем, натравливаем на какое-нить vcl приложение, и оно работает!

Ресурсы сжались, но программа теперь вылетает, не мудрено, ведь vcl не знает что ресурсы теперь сжаты.

Учим программу использовать сжатые DFM ресурсы

Пора создать тестовое приложение, на котором и будут проводится эксперименты. Создадим новый пустой VCL проект, в свойствах проекта пропишем чтобы он после компиляции обрабатывался dfmcompressor'ом, так же, чтобы можно было отлаживать модули delphi, нужно включить в свойствах проекта использование отладочных dcu.

Запускаем, умираем с исключением, и можем по стеку изучить как дошло управление до загрузки формы.

Собственно по стэку видно что вызывалась процедура classes.InternalReadComponentRes в которой и происходит загрузка ресурсов:

function InternalReadComponentRes(const ResName: UnicodeString; HInst: THandle; var Instance: TComponent): Boolean; overload;
var
  HRsrc: THandle;
begin                   { avoid possible EResNotFound exception }
  if HInst = 0 then HInst := HInstance;
  HRsrc := FindResourceW(HInst, PWideChar(ResName), PWideChar(RT_RCDATA));
  Result := HRsrc <> 0;
  if not Result then Exit;
  with TResourceStream.Create(HInst, ResName, RT_RCDATA) do
  try
    Instance := ReadComponent(Instance);
  finally
    Free;
  end;
  Result := True;
end;

Что же, попробуем внести изменения. Для этого скопируем classes.pas в каталог с нашим тестовым приложением (чтобы при компиляции подхватывался измененный файл), и модифицируем указанною процедуру так, чтобы происходила распаковка файла:

function InternalReadComponentRes(const ResName: UnicodeString; HInst: THandle; var Instance: TComponent): Boolean; overload;
var
  Signature: Longint;
  ResStream: TResourceStream;
  DecompressStream: TDecompressionStream;
begin
  Result := True;

  if HInst = 0 then
    HInst := HInstance;

  if FindResource(HInst, PChar(ResName), PChar(RT_RCDATA)) = 0 then
    Exit(False);

  ResStream := TResourceStream.Create(HInst, ResName, RT_RCDATA);
  try
    //Проверим, сжат ли стрим
    //Если есть стандартная DFM сигнатура, значит он не сжат
    ResStream.Read(Signature, SizeOf(Signature));

    //Восстановим указатель
    ResStream.Position := 0;

    //Если есть сигнатура, значит считем что поток не сжат
    if Signature = Longint(FilerSignature) then
      Instance := ResStream.ReadComponent(Instance)
    else
      begin
        //Ну а если нет сигнатуры, то распакуем DFM
        DecompressStream := TDecompressionStream.Create(ResStream);
        try
          Instance := DecompressStream.ReadComponent(Instance);
        finally
          FreeAndNil(DecompressStream);
        end;
      end;
  finally
    FreeAndNil(ResStream);
  end;
end;

Так же нужно не забыть добавить модуль Zlib в раздел uses секции implementation
Собираем, запускаем — все работает!

Развиваем идею

Вроде все работает — но таскать с приложением измененный classes.pas это крайняя мера, попробуем что-нибудь сделать. В идеале бы поставить хук на функцию InternalReadComponentRes и перенаправлять ее вызов на свою реализацию.

Хук делается очень просто формированием команды длинного jump'а на свою функцию, и вставкой его в начало InternalReadComponentRes. Да, таким подходом vcl не сможет больше вызвать  свой InternalReadComponentRes, но нам этого и не надо. Пишем функцию установки перехвата:

type
  PJump = ^TJump;
  TJump = packed record
    OpCode: Byte;
    Distance: Pointer;
  end;

procedure ReplaceProcedure(ASource, ADestination: Pointer);
var
  NewJump: PJump;
  OldProtect: Cardinal;
begin
  if VirtualProtect(ASource, SizeOf(TJump), PAGE_EXECUTE_READWRITE, @OldProtect) then
  try
    NewJump := PJump(ASource);
    NewJump.OpCode := $E9;
    NewJump.Distance := Pointer(Integer(ADestination) - Integer(ASource) - 5);

    FlushInstructionCache(GetCurrentProcess, ASource, SizeOf(TJump));
  finally
    VirtualProtect(ASource, SizeOf(TJump), OldProtect, @OldProtect);
  end;
end;

Вот только не получится так, ведь определение процедуры InternalReadComponentRes отсутствует в интерфейсной секции, а значит узнать указатель на нее мы не можем.

Вернувшись к стеку загрузки формы и изучив его, видно что InternalReadComponentRes вызвана из InitInheritedComponent, которая является публичной функцией, и на которую можно поставить перехват. Так же играет на руку то, что InitInheritedComponent не вызывает ни одной приватной функции из classes.pas (разумеется кроме той что мы меняем), а значит дублирование кода будет минимальным.

Реализуем все в модуле, подключив который к проекту программа научится читать сжатые ресурсы:

{
  Модуль добавляет поддержку сжатых DFM ресурсов в приложение
}
unit DFMCompressorSupportUnit;

interface

uses
  Windows, SysUtils, Classes, ZLib;

implementation

const
  //Скопировано из classes.pas
  FilerSignature: array[1..4] of AnsiChar = AnsiString('TPF0');


  //
  // Тут должны распологаться вышенаписанные ReplaceProcedure и 
  // наша реализация InternalReadComponentRes
  //

//Скопировано из classes.pas
function InitInheritedComponent(Instance: TComponent; RootAncestor: TClass): Boolean;

  function InitComponent(ClassType: TClass): Boolean;
  begin
    Result := False;
    if (ClassType = TComponent) or (ClassType = RootAncestor) then Exit;
    Result := InitComponent(ClassType.ClassParent);
    Result := InternalReadComponentRes(ClassType.ClassName,
      FindResourceHInstance(FindClassHInstance(ClassType)), Instance) or Result;
  end;

var
  LocalizeLoading: Boolean;
begin
  GlobalNameSpace.BeginWrite;  // hold lock across all ancestor loads (performance)
  try
    LocalizeLoading := (Instance.ComponentState * [csInline, csLoading]) = [];
    if LocalizeLoading then BeginGlobalLoading;  // push new loadlist onto stack
    try
      Result := InitComponent(Instance.ClassType);
      if LocalizeLoading then NotifyGlobalLoading;  // call Loaded
    finally
      if LocalizeLoading then EndGlobalLoading;  // pop loadlist off stack
    end;
  finally
    GlobalNameSpace.EndWrite;
  end;
end;

initialization
  ReplaceProcedure(@Classes.InitInheritedComponent, @InitInheritedComponent);
end.

Заключение

Все это работает и тестировалось на Delphi 2010, как будет работать на других версиях я не знаю, но думаю имея это руководство адаптировать не составит проблем.

Автор: vic85

Источник ^[4]