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

Источник: pblog
Грузин

 Наверно все читали мою статью про упаковку файлов с помощью библиотеки 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<3 then Continue;

    if (sr.Attr and fadirectory)=faDirectory then Continue;

    _FilesList.Add(Folder + sr.Name);

  until FindNext(sr)  0;

  FindClose(sr);

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

  sDirList := TStringList.Create;

  try

    GetSubDirs (Folder, sDirList);

    for i := 0 to sDirList.Count - 1 do

      if (sDirList  '.') and (sDirList  '..') then

      begin

        _LST:=GetAllFiles(Filter,IncludeTrailingPathDelimiter (Folder + sDirList));

        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;

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);//write main archive signature

  Value:=_Files.Count;

  WriteFile(ArchiveFile,value,4,_writed,0);//write files count

  for i:=0 to value-1 do

   begin

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

    if not ActionFunction(_Files.Strings,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,length(FolderPath),1000);// XA XA XA XA XA

    if path_in_archive_file[1] = '\' then

     Delete(path_in_archive_file,1,1);

    Write_LS(ArchiveFile,path_in_archive_file);

    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 папку и пользуетесь модулем на здоровье.
Вот, пожалуй, и всё.


Страница сайта http://test.interface.ru
Оригинал находится по адресу http://test.interface.ru/home.asp?artId=21484