Упаковка папок c помощью ZLib

Наверно все читали мою статью про упаковку файлов с помощью библиотеки ZLib в Delphi. В ней написано, как можно архивировать файлы почти с той же степенью сжатия, как и ZIP. Но я описал, как можно архивировать только единичные файлы. По многочисленным заявкам читателей я пишу ещё одну статью про архивирование целых папок.

Для того, что бы архивировать папку, давайте сначала научимся склеивать все файлы, находящиеся в некоторой папке. Давайте сначала разберёмся с форматом этого склеенного файла, а будут он примерно таким

Первые четыре байта будет составлять сигнатура, которая будет обозначать, что это файл нашего формата

Следующие четыре байта будут обозначать количество файлов в этом склеенном файле

Потом будет идти массив структур, который будет описывать все файлы в этом склеенном файле, каждая структура будет иметь вот такой формат

1. 2 байта - длина имени файла
2. Размер этого поля равен значению предыдущего поля - Полное имя файла, исключая путь к нашей папке, т.е. путь к файлу в нашей папке.
3. 4 байта - Размер файла
4. Размер этого поля равен значению предыдущего поля - Само содержание файла

В данной структуре максимальный размер одного файла может быть максимум 2^32 байт, т.е. 4 ГБ. Кстати, для повышения вышей образованности формат сохранения строки, который я использую, называется LS, т.е. сначала пишется длина стоки потом сама строка. Итак, приступим к кодингу. Сначала нам надо получить список всех файлов в папке. Напишем функцию, которой мы будем передавать путь к папке, а она нам будет возвращать объект TStringList в котором и будет лежать список всех файлов в папке.

function GetAllFiles (Filter, Folder: string):TFilesList;
  var
    sr: TSearchRec;
    sDirList,_FilesList,_LST: TStringList;
    i,j: Integer;
  begin
    j:=0;
    _FilesList:= TStringList.create;
    _FilesList.Clear;

В начале мы создаём объект результат , а потом мы ищем все файлы которые находятся в папке путь к которой был передан в качестве второго параметра. Я думаю здесь нет ничего сложного. Первые два найденных файла игнорируются потому что это папки . и .. при переходе на которых мы остаёмся в этой папке и переходим на один уровень вверх соответственно.

    if FindFirst (Folder + Filter,faAnyFile , sr) = 0 then
      repeat
      j:=j+1;
      if j 0;
      FindClose(sr);

Далее мы создаём объект, в котором будет храниться список подпапок, и вызываем для каждой подпапки саму себя. Здесь немного по-другому игнорируются первые два пункта я это сделал только лишь для разнообразия (кстати, так намного лучше, чем то что мы применяли при поиске файлов). После получения списка файлов в каждой подпапке мы копируем полученный список в список результат.

      sDirList := TStringList.Create;
      try
        GetSubDirs (Folder, sDirList);
        for i := 0 to sDirList.Count - 1 do
        if (sDirList[i] '.') and (sDirList[i] '..') then
          begin
            _LST:=GetAllFiles(Filter,IncludeTrailingPathDelimiter(Folder + sDirList[i]));
            for j:=0 to _LST.Count-1 do
              _FilesList.Add(_LST.Strings[j]);
            _LST.free;
          end;
      finally
        sDirList.Free;
      end;
    Result:= _FilesList;
  end;

В этой функции мы применяли способ вызова функции из самой себя, настоятельно не рекомендую использовать такой способ при выполнении операций требующих очень большого количества вызовов функции, так как это может вызвать переполнение стека. В Windows стек ограничен 1 МВ. Поэтому функция (если у неё один параметр) может вызвать себя только 131072 раз, вы скажете <столько раз вызвать саму себя невозможно>. А если у функции 5 параметров то 1048576/(6*4) = 34952. А это уже не очень много. Вы спросите, зачем нам нужен параметр, который задаёт фильтр, я отвечу <просто так>, мало ли что, может пригодиться. Ах да забыл привести процедуру получения списка подпапок. Лист с результатом можно было возвращать в качестве результата, но для разнообразия это тоже не помешает.

procedure GetSubDirs (Folder: string; sList: TStringList);
  var
    sr: TSearchRec;
  begin
    if FindFirst (Folder + '*.*', faDirectory, sr) = 0 then
    try
      repeat
        if (sr.Attr and faDirectory) = faDirectory then
        sList.Add (sr.Name);
      until FindNext(sr) 0;
    finally
      FindClose(sr);
    end;
  end;

Едем далее: после получения списка файлов нам надо все эти файлы склеить в один. Я специально пойду, не так как говорил в начале. Будем делать так: нашей функции будет передаваться функция которая будет делать с файлом некоторое действие которое нужно вам. Заголовок функции будет такой

type
  TActionFuntion = function(SourceFileName,DestFileName:string):boolean;

Результат функции будет обозначать успешность действия. Сейчас вам, конечно же, ничего не понятно, сейчас всё поймёте. Функции упаковки папки будет передаваться папка, файл результат и функция обратного вызова, которая будет вызываться для каждого файла в этой папке. В общем, вот код этой функции

function DoFolderAction(FolderPath, ArchivePath:string;
	ActionFunction :TActionFuntion):boolean;
  var
    ArchiveFile,CurrFile :THandle;
    Value,i,CurrFileSize,_readed,_writed:DWORD;
    _Files:TStringList;
    path_in_archive_file :string;
    pBuff:Pointer;
  begin
    Result:=false;
    if FolderPath[Length(FolderPath)]'\' then
    FolderPath:=FolderPath+'\';   _Files:=GetAllFiles('*.*',FolderPath);

    ArchiveFile := CreateFile(pchar(ArchivePath), GENERIC_READ+GENERIC_WRITE,
	FILE_SHARE_READ,0, CREATE_ALWAYS,0,0);

    Value:=ArchiveSignature;
    WriteFile(ArchiveFile,value,4,_writed,0); {пишем сигнатуру}
    Value:=_Files.Count;
    WriteFile(ArchiveFile,value,4,_writed,0); {пишем количество файлов}

    for i:=0 to value-1 do
      begin

Далее мы вызываем функцию обратного вызова, которой передаём файл источник и файл результат, файл-результат это всего лишь промежуточный файл, потом мы его удалим. Переменную bkpFile можно объявить как константу.

      if not ActionFunction(_Files.Strings[i],bkpFile) then
        begin
          {если функция обратного вызова завершилась неудачно, выходим из функции,
           если это не нужно то можно этот код закоментарить, но тогда наша
           функция будет завершаться удачно даже если какой то файл не был обработан }
          CloseHandle(ArchiveFile);
          exit;
        end;
      CurrFile := CreateFile(pchar(bkpFile),GENERIC_READ, FILE_SHARE_READ,0,OPEN_EXISTING,0,0);
      CurrFileSize := GetFileSize(CurrFile,nil);
      {получаем "путь файла в папке"}
      path_in_archive_file :=copy(Files.Strings[i], length(FolderPath),1000);
      if path_in_archive_file[1] = '\' then
      Delete(path_in_archive_file,1,1);     
      Write_LS(ArchiveFile,path_in_archive_file); {записываем имя файла}
      {Функция Write_LS пишет в файл стоку в формате LS,короче смотрите исходник}
      WriteFile(ArchiveFile,currFileSize,4,_writed,0); {пишем размер файла}
      {резервируем место под буфер}
      pBuff := VirtualAlloc(0,MainBufferSize, MEM_COMMIT+MEM_RESERVE,PAGE_READWRITE); 

      repeat
        ReadFile(CurrFile,pBuff^,MainBufferSize,_readed,0);
        WriteFile(ArchiveFile,pBuff^,_readed,_writed,0);
      until _writed < MainBufferSize; {<приклеиваем> файл}

      VirtualFree(pBuff,MEM_RELEASE,0); {освобождаем буфер}

      CloseHandle(CurrFile);
      DeleteFile(bkpFile);
    end;

    CloseHandle(ArchiveFile);
    Result:=True;
  end;

Теперь приведу функцию, которая распаковывает всё это дело. Полный код функции смотрите в исходнике.

function De_DoFolderAction (FolderPath, ArchivePath :string;
  DeActionFunction :TActionFuntion) :boolean;
  var
  ...
  begin
    ArchiveFile := CreateFile(pchar(ArchivePath),GENERIC_READ+GENERIC_WRITE,
     FILE_SHARE_READ,0,OPEN_EXISTING,0,0);
    ReadFile(ArchiveFile,value,4,_readed,0); {проверяем наш ли это формат}
    if Value ArchiveSignature then
    begin
    ...
    end;

  ReadFile(ArchiveFile,_Count,4,_readed,0); {получаем количество файлов}

  for i:=1 to _Count do
    begin
      path_in_archive_file := Read_LS(ArchiveFile);
      ReadFile(ArchiveFile,CurrFileSize,4,_readed,0);
      ...
      for j:=1 to CurrFileSize div MainBufferSize do
      begin
        ReadFile(ArchiveFile,pBuff^,MainBufferSize,_readed,0);
        WriteFile(CurrFile,pBuff^,_readed,_writed,0);
      end;

      ReadFile(ArchiveFile,pBuff^,CurrFileSize mod MainBufferSize,_readed,0);
      WriteFile(CurrFile,pBuff^,_readed,_writed,0);
      ...
      if FolderPath[Length(FolderPath)]'\' then
        Delete(FolderPath,Length(FolderPath),1);
      if path_in_archive_file[1]'\' then
        path_in_archive_file := '\' + path_in_archive_file;
      path_in_archive_file :=FolderPath+path_in_archive_file;
      makedir(ExtractFileDir(path_in_archive_file));
      {код этой функции тоже смотрите в исходнике}

      if not DeActionFunction(bkpfile,path_in_archive_file) then
        begin
          ...
        end;

      ...
      end;
    ...
    end;

Теперь для того чтобы просто склеить все файлы в папке в один файл надо сделать это:

function DODO(fl1,fl2:string):boolean;
  begin
    Result:=CopyFile(pchar(fl1),pchar(fl2),false);
  end;

procedure TForm1.Button1Click(Sender: TObject);
  begin
    DoFolderAction('F:\111?,'F:\arch.dat',DODO);
    De_DoFolderAction('F:\112?,'F:\arch.dat',DODO);
  end

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

function DODO2(fl1,fl2:string):boolean;
  begin
    Result:=ZLATCompressFile(fl1,fl2,2,false,true,nil,0,0)0;
  end;

function DODO3(fl1,fl2:string):boolean;
  begin
    Result:=ZLATdecompressfile(fl1,fl2,false,true,nil,0,0);
  end;

procedure TForm1.Button1Click(Sender: TObject);
  begin
    DoFolderAction('F:\111?,'F:\arch.dat',DODO2);
    De_DoFolderAction('F:\112?,'F:\arch.dat',DODO3)
  end;

Конечно, можно было сначала склеить все файлы, потом сжать склеенный файл, а для распаковки сначала распаковать и потом расклеить. С тем же успехом можно шифровать целые папки, используя технологию шифровки которые я описал в своих предыдущих статье и статье. Короче кидаете файл FolderActions.pas в расшаренную для Delphi папку и пользуетесь модулем на здоровье.

Вот, пожалуй, и всё.

Модуль для упаковки папок