2059 lines
82 KiB
ObjectPascal
2059 lines
82 KiB
ObjectPascal
////////////////////////////////////////////////////////////////////////////////
|
||
//
|
||
// ****************************************************************************
|
||
// * Project : FWZip
|
||
// * Unit Name : FWZipWriter
|
||
// * Purpose : Класс для создания ZIP архива
|
||
// * Author : Александр (Rouse_) Багель
|
||
// * Copyright : © Fangorn Wizards Lab 1998 - 2023.
|
||
// * Version : 2.0.1
|
||
// * Home Page : http://rouse.drkb.ru
|
||
// * Home Blog : http://alexander-bagel.blogspot.ru
|
||
// ****************************************************************************
|
||
// * Stable Release : http://rouse.drkb.ru/components.php#fwzip
|
||
// * Latest Source : https://github.com/AlexanderBagel/FWZip
|
||
// ****************************************************************************
|
||
//
|
||
// Используемые источники:
|
||
// ftp://ftp.info-zip.org/pub/infozip/doc/appnote-iz-latest.zip
|
||
// https://zlib.net/zlib-1.2.13.tar.gz
|
||
// http://www.base2ti.com/
|
||
//
|
||
|
||
unit FWZipWriter;
|
||
|
||
{$IFDEF FPC}
|
||
{$MODE Delphi}
|
||
{$H+}
|
||
{$ENDIF}
|
||
|
||
interface
|
||
|
||
{$I fwzip.inc}
|
||
|
||
uses
|
||
SysUtils,
|
||
Classes,
|
||
Contnrs,
|
||
Masks,
|
||
FWZipConsts,
|
||
FWZipCrc32,
|
||
FWZipCrypt,
|
||
FWZipStream,
|
||
FWZipZLib,
|
||
FWZipUtils;
|
||
|
||
type
|
||
TFWZipWriter = class;
|
||
|
||
TFWZipWriterItem = class
|
||
private
|
||
FOwner: TFWZipWriter;
|
||
FComment: string; // коментарий к элементу
|
||
FFilePath: string; // путь к внешнему файлу (или см. TFWZipWriterItemEx.Data)
|
||
FFileName: string; // имя элемента в архиве - не может быть пустым
|
||
FPassword: string; // пароль
|
||
FCmpLevel: TCompressionLevel; // уровень сжатия
|
||
FNeedDescriptor: Boolean; // флаг определяет способ хранения данных
|
||
// о элементе, (дескриптор или локальный заголовок)
|
||
FSize: Int64;
|
||
FData: TStream; // Данные элемента в случае если файл
|
||
// отсутствует на диске
|
||
FAttributes: TFileAttributeData; // Внешние аттрибуты файла
|
||
|
||
FTag: Integer;
|
||
FUseUTF8String: Boolean;
|
||
FUseExternalData: Boolean; // Флаг указывающий на то что данные будут передаваться снаружи
|
||
procedure SetBool(const Value: Boolean);
|
||
procedure SetCmpLevel(const Value: TCompressionLevel);
|
||
procedure SetString(const Index: Integer; const Value: string);
|
||
protected
|
||
property Data: TStream read FData;
|
||
property UseExternalData: Boolean read FUseExternalData write FUseExternalData;
|
||
public
|
||
constructor Create(Owner: TFWZipWriter;
|
||
const InitFilePath: string;
|
||
InitAttributes: TFileAttributeData;
|
||
const InitFileName: string = ''); virtual;
|
||
destructor Destroy; override;
|
||
procedure ChangeDataStream(Value: TStream;
|
||
AOwnerShip: TStreamOwnership = soReference);
|
||
procedure ChangeAttributes(Value: TFileAttributeData);
|
||
function IsFolder: Boolean;
|
||
property Comment: string index 0 read FComment write SetString;
|
||
property FilePath: string index 1 read FFilePath write SetString;
|
||
property FileName: string index 2 read FFileName write SetString;
|
||
property Password: string index 3 read FPassword write SetString;
|
||
property CompressionLevel: TCompressionLevel read FCmpLevel write SetCmpLevel;
|
||
property NeedDescriptor: Boolean read FNeedDescriptor write SetBool;
|
||
property Size: Int64 read FSize;
|
||
property Attributes: TFileAttributeData read FAttributes;
|
||
property Tag: Integer read FTag write FTag;
|
||
property UseUTF8String: Boolean read FUseUTF8String write FUseUTF8String;
|
||
end;
|
||
|
||
TFWZipWriterItemClass = class of TFWZipWriterItem;
|
||
|
||
// Результат создания архива
|
||
TBuildZipResult =
|
||
(
|
||
brDone, // архив создан успешно
|
||
brFailed, // ошибка создания архива
|
||
brAborted, // создание архива отменено пользователем
|
||
brPartialBuild // некоторые элементы пропущены из-за возникших ошибок
|
||
);
|
||
|
||
{ TFWZipWriter }
|
||
|
||
TFWZipWriter = class
|
||
private
|
||
FDefaultDescryptorState: Boolean;
|
||
FDefaultCompressionLevel: TCompressionLevel;
|
||
FDefaultPassword: string;
|
||
FItems: TObjectList;
|
||
FCD: array of TCentralDirectoryFileHeaderEx;
|
||
FVersionToExtract: Word;
|
||
FcdfhOffset, FTotalProgress, FTotalSizeCount,
|
||
FTotalProcessedCount, FSizeOfCentralDir: Int64;
|
||
FCompressedStream: TStream;
|
||
FProcessedItemIndex, FcdfhDiskNumber, FcdfhRecordOnDisk: Integer;
|
||
FComment: string;
|
||
FOnProgress: TZipProgressEvent;
|
||
FBuildState: Boolean;
|
||
FSaveExData: TZipSaveExDataEvent;
|
||
FExceptionCount: Integer;
|
||
FBuidException: TZipBuildExceptionEvent;
|
||
FTrimPackedStreamSize: Boolean;
|
||
FAlwaysAddEmptyFolder: Boolean;
|
||
FUseUTF8String: Boolean;
|
||
function GetItem(Index: Integer): TFWZipWriterItem;
|
||
protected
|
||
function GetItemClass: TFWZipWriterItemClass; virtual;
|
||
function AddNewItem(Value: TFWZipWriterItem): Integer;
|
||
function IsMultiPartZip(AStream: TStream): Boolean;
|
||
procedure FillItemCDFHeader(CurrentItem: TFWZipWriterItem;
|
||
var Value: TCentralDirectoryFileHeaderEx); virtual;
|
||
procedure CompressItem(CurrentItem: TFWZipWriterItem;
|
||
Index: Integer; StreamSizeBeforeCompress: Int64; Stream: TStream); virtual;
|
||
procedure FillExData(Stream: TStream; Index: Integer); virtual;
|
||
protected
|
||
procedure DoProgress(ProgressState: TProgressState);
|
||
procedure CompressorOnProcess(Sender: TObject);
|
||
protected
|
||
function CheckFileNameSlashes(const Value: string): string;
|
||
function CreateItemFromStream(const FileName: string;
|
||
Value: TStream; AOwnerShip: TStreamOwnership): TFWZipWriterItem;
|
||
function GetVersionToExtract(Index: Integer): Word;
|
||
function GetCurrentFileTime: TFileTime;
|
||
procedure SaveItemToStream(Stream: TStream; Index: Integer); virtual;
|
||
procedure SaveCentralDirectory(Stream: TStream);
|
||
procedure SaveEndOfCentralDirectory(Stream: TStream);
|
||
procedure SaveString(Stream: TStream; const Value: string;
|
||
AUseUTF8String: Boolean);
|
||
procedure UpdateLocalHeaders(Stream: TStream);
|
||
property BuildState: Boolean read FBuildState;
|
||
function StringLength(const Value: string; AUseUTF8String: Boolean): Integer;
|
||
public
|
||
constructor Create; overload;
|
||
constructor Create(CompressionLevel: TCompressionLevel); overload;
|
||
constructor Create(UseDescryptors: Boolean;
|
||
CompressionLevel: TCompressionLevel;
|
||
const DefaultPassword: string); overload;
|
||
destructor Destroy; override;
|
||
function AddEmptyFolder(const FolderRelativeName: string): Integer; overload;
|
||
function AddEmptyFolder(const FolderRelativeName: string;
|
||
Attributes: TFileAttributeData): Integer; overload;
|
||
function AddFile(const FilePath: string;
|
||
const FileName: string = ''): Integer; overload;
|
||
function AddFile(const FilePath: string;
|
||
Attributes: TFileAttributeData;
|
||
const FileName: string = ''): Integer; overload;
|
||
function AddStream(const FileName: string; Value: TStream;
|
||
AOwnerShip: TStreamOwnership = soReference): Integer;
|
||
function AddFiles(Value: TStringList): Integer;
|
||
function AddFilesAndFolders(Value: TStringList; SubFolders: Boolean = True): Integer;
|
||
function AddFolder(const Path: string;
|
||
SubFolders: Boolean = True): Integer; overload;
|
||
function AddFolder(const RelativePath, Path, Mask: string;
|
||
SubFolders: Boolean = True): Integer; overload;
|
||
function BuildZip(ZipFilePath: string): TBuildZipResult; overload;
|
||
function BuildZip(Stream: TStream): TBuildZipResult; overload;
|
||
function Count: Integer;
|
||
procedure Clear;
|
||
procedure DeleteItem(Index: Integer);
|
||
|
||
/// <summary>
|
||
/// Функция ищет запись об элементе по имени
|
||
/// </summary>
|
||
function Find(const Value: string; out AItem: TFWZipWriterItem;
|
||
IgnoreCase: Boolean = True): Boolean; overload;
|
||
|
||
function InsertStream(const FileName: string; Index: Integer;
|
||
Value: TStream; AOwnerShip: TStreamOwnership = soReference): Integer;
|
||
|
||
// Свойство отвечает за добавление папки в виде TFWZipWriterItem
|
||
// непосредственно перед добавлением данных из указаной папки
|
||
property AlwaysAddEmptyFolder: Boolean read FAlwaysAddEmptyFolder
|
||
write FAlwaysAddEmptyFolder;
|
||
|
||
property Item[Index: Integer]: TFWZipWriterItem read GetItem; default;
|
||
property Comment: string read FComment write FComment;
|
||
|
||
// Свойство работает только при включенной директиве USE_AUTOGENERATED_ZLIB_HEADER
|
||
// В остальных случаях не влияет на архив и оставлено для совместимости
|
||
property TrimPackedStreamSize: Boolean read FTrimPackedStreamSize
|
||
write FTrimPackedStreamSize; // deprecated;
|
||
|
||
property OnException: TZipBuildExceptionEvent read FBuidException write FBuidException;
|
||
property OnProgress: TZipProgressEvent read FOnProgress write FOnProgress;
|
||
property OnSaveExData: TZipSaveExDataEvent read FSaveExData write FSaveExData;
|
||
// Свойство для автоматического выставления кодировки у добавляемых элементов
|
||
// Не влияет на кодировку коментария к архиву (он всегда Ansi)
|
||
property UseUTF8String: Boolean read FUseUTF8String write FUseUTF8String;
|
||
end;
|
||
|
||
EZipWriterItem = class(Exception);
|
||
EZipWriter = class(Exception);
|
||
EZipWriterWrite = class(Exception);
|
||
|
||
implementation
|
||
|
||
{ TFWZipWriterItem }
|
||
|
||
//
|
||
// Процедура изменяет аттрибуты элемента архива
|
||
// =============================================================================
|
||
procedure TFWZipWriterItem.ChangeAttributes(Value: TFileAttributeData);
|
||
begin
|
||
if not FOwner.BuildState then
|
||
FAttributes := Value;
|
||
end;
|
||
|
||
//
|
||
// Процедура изменяет блок данных об элементе. Автоматически чистится имя к файлу.
|
||
// Данные при сжатии будут браться из поля FData
|
||
// =============================================================================
|
||
procedure TFWZipWriterItem.ChangeDataStream(Value: TStream;
|
||
AOwnership: TStreamOwnership);
|
||
begin
|
||
if not FOwner.BuildState then
|
||
if Value.Size <> 0 then
|
||
begin
|
||
FreeAndNil(FData);
|
||
if AOwnership = soOwned then
|
||
FData := Value
|
||
else
|
||
begin
|
||
FData := TMemoryStream.Create;
|
||
FData.CopyFrom(Value, 0);
|
||
end;
|
||
FSize := FData.Size;
|
||
FFilePath := '';
|
||
end;
|
||
end;
|
||
|
||
//
|
||
// Стандартный конструктор класса
|
||
// =============================================================================
|
||
constructor TFWZipWriterItem.Create(Owner: TFWZipWriter;
|
||
const InitFilePath: string;
|
||
InitAttributes: TFileAttributeData; const InitFileName: string);
|
||
begin
|
||
inherited Create;
|
||
FData := nil;
|
||
FOwner := Owner;
|
||
FFilePath := InitFilePath;
|
||
FAttributes := InitAttributes;
|
||
FSize :=
|
||
FileSizeToInt64(FAttributes.nFileSizeLow, FAttributes.nFileSizeHigh);
|
||
FFileName := InitFileName;
|
||
UseUTF8String := Owner.UseUTF8String;
|
||
end;
|
||
|
||
//
|
||
// Стандартный деструктор класса
|
||
// =============================================================================
|
||
destructor TFWZipWriterItem.Destroy;
|
||
begin
|
||
FData.Free;
|
||
inherited;
|
||
end;
|
||
|
||
//
|
||
// Функция проверяет - является ли элемент папкой?
|
||
// =============================================================================
|
||
function TFWZipWriterItem.IsFolder: Boolean;
|
||
begin
|
||
Result := Attributes.dwFileAttributes and faDirectory <> 0;
|
||
if not Result then
|
||
Result := FileName[Length(FileName)] = ZIP_SLASH;
|
||
end;
|
||
|
||
//
|
||
// Процедура изменяет флаг дескриптора элемента
|
||
// =============================================================================
|
||
procedure TFWZipWriterItem.SetBool(const Value: Boolean);
|
||
begin
|
||
if not FOwner.BuildState then
|
||
FNeedDescriptor := Value;
|
||
end;
|
||
|
||
//
|
||
// Процедура изменяет степень сжатия элемента
|
||
// =============================================================================
|
||
procedure TFWZipWriterItem.SetCmpLevel(const Value: TCompressionLevel);
|
||
begin
|
||
if not FOwner.BuildState then
|
||
FCmpLevel := Value;
|
||
end;
|
||
|
||
//
|
||
// Процедура изменяет строковые свойства элемента.
|
||
// При изменении пути к файлу, автоматически рассчитываются
|
||
// новые аттрибуты файла и очишается стрим FData за ненадобностью
|
||
// =============================================================================
|
||
procedure TFWZipWriterItem.SetString(const Index: Integer;
|
||
const Value: string);
|
||
var
|
||
Attributes: TFileAttributeData;
|
||
begin
|
||
if not FOwner.BuildState then
|
||
case Index of
|
||
0: FComment := Value;
|
||
1:
|
||
begin
|
||
if FileExists(Value) then
|
||
begin
|
||
// Изменяем только в том случае если объект доступен
|
||
// и мы смогли снять его аттрибуты
|
||
if GetFileAttributes(Value, Attributes) then
|
||
begin
|
||
FAttributes := Attributes;
|
||
FSize :=
|
||
FileSizeToInt64(Attributes.nFileSizeLow, Attributes.nFileSizeHigh);
|
||
FFilePath := Value;
|
||
FreeAndNil(FData);
|
||
end;
|
||
end;
|
||
end;
|
||
2:
|
||
// Rouse_ 20.12.2019
|
||
// Даем возможность работы с длинными путями
|
||
// if Length(Value) >= MAX_PATH then
|
||
// raise EZipWriterItem.Create('Слишком длинный путь.')
|
||
// else
|
||
FFileName := Value;
|
||
3: FPassword := Value;
|
||
end;
|
||
end;
|
||
|
||
{ TFWZipWriter }
|
||
|
||
//
|
||
// Функция добавляет очередной файл в список.
|
||
// В качестве результата возвращает индекс элемента в списке.
|
||
// Параметры:
|
||
// FilePath - путь к файлу
|
||
// FileName - наименование файла в архиве
|
||
// (включая относительный путь от корня архива)
|
||
// =============================================================================
|
||
function TFWZipWriter.AddFile(const FilePath: string; const FileName: string
|
||
): Integer;
|
||
var
|
||
Attributes: TFileAttributeData;
|
||
FullFilePath: string;
|
||
begin
|
||
Result := -1;
|
||
FullFilePath := PathCanonicalize(FilePath);
|
||
// Добавляем только в том случае если объект доступен
|
||
// и мы смогли снять его аттрибуты
|
||
if GetFileAttributes(FullFilePath, Attributes) then
|
||
Result := AddFile(FullFilePath, Attributes, FileName);
|
||
end;
|
||
|
||
//
|
||
// Функция добавляет пустую папку в список.
|
||
// В качестве результата возвращает индекс элемента в списке.
|
||
// Параметры:
|
||
// FolderRelativeName - наименование папки в архиве
|
||
// (включая относительный путь от корня архива)
|
||
// =============================================================================
|
||
function TFWZipWriter.AddEmptyFolder(const FolderRelativeName: string): Integer;
|
||
var
|
||
Attributes: TFileAttributeData;
|
||
begin
|
||
ZeroMemory(@Attributes, SizeOf(TFileAttributeData));
|
||
Attributes.dwFileAttributes := faDirectory;
|
||
Result := AddEmptyFolder(FolderRelativeName, Attributes);
|
||
end;
|
||
|
||
//
|
||
// Функция добавляет пустую папку в список.
|
||
// В качестве результата возвращает индекс элемента в списке.
|
||
// Параметры:
|
||
// FolderRelativeName - наименование папки в архиве
|
||
// (включая относительный путь от корня архива)
|
||
// Attributes - аттрибуты папки
|
||
// =============================================================================
|
||
function TFWZipWriter.AddEmptyFolder(const FolderRelativeName: string;
|
||
Attributes: TFileAttributeData): Integer;
|
||
var
|
||
FolderPath: string;
|
||
Item: TFWZipWriterItem;
|
||
begin
|
||
Result := -1;
|
||
if FolderRelativeName = '' then Exit;
|
||
FolderPath := CheckFileNameSlashes(FolderRelativeName);
|
||
if FolderPath[Length(FolderPath)] <> ZIP_SLASH then
|
||
FolderPath := FolderPath + ZIP_SLASH;
|
||
Item := GetItemClass.Create(Self, FolderPath, Attributes, FolderPath);
|
||
Result := AddNewItem(Item);
|
||
end;
|
||
|
||
//
|
||
// Функция добавляет очередной файл в список.
|
||
// В качестве результата возвращает индекс элемента в списке.
|
||
// Параметры:
|
||
// FilePath - путь к файлу
|
||
// Attributes - аттрибуты файла
|
||
// FileName - наименование файла в архиве
|
||
// (включая относительный путь от корня архива)
|
||
// =============================================================================
|
||
function TFWZipWriter.AddFile(const FilePath: string;
|
||
Attributes: TFileAttributeData; const FileName: string): Integer;
|
||
var
|
||
Item: TFWZipWriterItem;
|
||
InitFileName, FullFilePath: string;
|
||
begin
|
||
// Проверка что нам передали. папку или файл?
|
||
Result := -1;
|
||
FullFilePath := PathCanonicalize(FilePath);
|
||
if not FileExists(FullFilePath) then Exit;
|
||
if FileName = '' then
|
||
InitFileName := ExtractFileName(ExcludeTrailingPathDelimiter(FullFilePath))
|
||
else
|
||
InitFileName := CheckFileNameSlashes(FileName);
|
||
|
||
Item := GetItemClass.Create(Self, FullFilePath, Attributes, InitFileName);
|
||
Item.CompressionLevel := FDefaultCompressionLevel;
|
||
Item.Password := FDefaultPassword;
|
||
|
||
// в случае наличия дескриптора мы можем
|
||
// производить расчет контрольной суммы на лету, т.к. при включенном
|
||
// режиме шифрования она не участвует в генерации заголовка инициализации
|
||
Item.NeedDescriptor := FDefaultDescryptorState;
|
||
|
||
Result := AddNewItem(Item);
|
||
end;
|
||
|
||
//
|
||
// Функция добавляет набор файлов в список.
|
||
// В качестве результата возвращает количество успешно добавленных элементов.
|
||
// Параметры:
|
||
// Value - пути к файлам
|
||
// Value.ValueFromIndex[I] содержит полный путь к файлу
|
||
// Value.Names[I] содержит имя файла с которым он будет
|
||
// помещен в архив (необязательный параметр)
|
||
// =============================================================================
|
||
function TFWZipWriter.AddFiles(Value: TStringList): Integer;
|
||
var
|
||
I: Integer;
|
||
begin
|
||
Result := 0;
|
||
for I := 0 to Value.Count - 1 do
|
||
if AddFile(Value.ValueFromIndex[I], Value.Names[I]) >= 0 then
|
||
Inc(Result);
|
||
end;
|
||
|
||
//
|
||
// Функция добавляет набор файлов и папок в список.
|
||
// В качестве результата возвращает количество успешно добавленных элементов.
|
||
// Параметры:
|
||
// Value - пути к файлам и папкам из которых будут добавляться данные
|
||
// Value.ValueFromIndex[I] для папки содержит полный путь к папке
|
||
// Value.Names[I] для папки содержит путь относительно корня архива
|
||
// (необязательный параметр)
|
||
// Value.ValueFromIndex[I] для файла содержит полный путь к файлу
|
||
// Value.Names[I] для файла содержит имя файла с которым он будет
|
||
// помещен в архив (необязательный параметр)
|
||
// SubFolders - добавлять данные из подпапок или нет.
|
||
// =============================================================================
|
||
function TFWZipWriter.AddFilesAndFolders(Value: TStringList;
|
||
SubFolders: Boolean): Integer;
|
||
var
|
||
I: Integer;
|
||
Path: string;
|
||
begin
|
||
Result := 0;
|
||
for I := 0 to Value.Count - 1 do
|
||
begin
|
||
Path := PathCanonicalize(Value.ValueFromIndex[I]);
|
||
if DirectoryExists(Path) then
|
||
Inc(Result, AddFolder(Value.Names[I], Path, '', SubFolders))
|
||
else
|
||
if AddFile(Path, Value.Names[I]) >= 0 then
|
||
Inc(Result);
|
||
end;
|
||
end;
|
||
|
||
//
|
||
// Функция добавляет файлы из указаной папки
|
||
// В качестве результата возвращает количество успешно добавленных элементов.
|
||
// Параметры:
|
||
// Path - путь к папке из которой будут добавляться данные
|
||
// SubFolders - добавлять данные из подпапок или нет.
|
||
// =============================================================================
|
||
function TFWZipWriter.AddFolder(const Path: string; SubFolders: Boolean): Integer;
|
||
begin
|
||
Result := AddFolder(ExtractFileName(
|
||
ExcludeTrailingPathDelimiter(PathCanonicalize(Path))),
|
||
Path, EmptyStr, SubFolders);
|
||
end;
|
||
|
||
//
|
||
// Расширенный вариант AddFolder
|
||
// Функция добавляет файлы из указаной папки
|
||
// В качестве результата возвращает количество успешно добавленных элементов.
|
||
// Параметры:
|
||
// RelativePath - путь к элементу в архиве относительно корня.
|
||
// Path - путь к папке из которой будут добавляться данные
|
||
// Mask - маска отбора файлов (через точку с запятой). Например "*.txt;*.bin;12???6.dat"
|
||
// SubFolders - добавлять данные из подпапок или нет.
|
||
// =============================================================================
|
||
function TFWZipWriter.AddFolder(const RelativePath, Path, Mask: string;
|
||
SubFolders: Boolean): Integer;
|
||
const
|
||
AllDataMask = '*';
|
||
var
|
||
SR: TSearchRec;
|
||
TrailingPath, TrailingRelativePath, ResultMask: string;
|
||
Attributes: TFileAttributeData;
|
||
Masks: TStringList;
|
||
I: Integer;
|
||
Matched: Boolean;
|
||
begin
|
||
Result := 0;
|
||
// обычное рекурсивное сканирование папки
|
||
// единственный нюанс - параметр RelativePath
|
||
// в котором передается путь к файлу или папке относительно корневой папки
|
||
if RelativePath = '' then
|
||
TrailingRelativePath := ''
|
||
else
|
||
TrailingRelativePath := IncludeTrailingPathDelimiter(RelativePath);
|
||
TrailingPath := IncludeTrailingPathDelimiter(PathCanonicalize(Path));
|
||
|
||
Masks := nil;
|
||
if Mask = EmptyStr then
|
||
ResultMask := AllDataMask
|
||
else
|
||
ResultMask := AnsiLowerCase(Mask);
|
||
|
||
if ResultMask <> AllDataMask then
|
||
begin
|
||
Masks := TStringList.Create;
|
||
Masks.Delimiter := ';';
|
||
Masks.DelimitedText := ResultMask;
|
||
end;
|
||
|
||
try
|
||
if FindFirst(TrailingPath + AllDataMask, faAnyFile, SR) = 0 then
|
||
try
|
||
repeat
|
||
|
||
if SR.Name = '..' then Continue;
|
||
|
||
{$IFDEF LINUX}
|
||
GetFileAttributes(TrailingPath + SR.Name, Attributes);
|
||
{$ELSE}
|
||
{$WARN SYMBOL_PLATFORM OFF}
|
||
Attributes.dwFileAttributes := SR.FindData.dwFileAttributes;
|
||
Attributes.ftCreationTime := SR.FindData.ftCreationTime;
|
||
Attributes.ftLastAccessTime := SR.FindData.ftLastAccessTime;
|
||
Attributes.ftLastWriteTime := SR.FindData.ftLastWriteTime;
|
||
Attributes.nFileSizeHigh := SR.FindData.nFileSizeHigh;
|
||
Attributes.nFileSizeLow := SR.FindData.nFileSizeLow;
|
||
{$WARN SYMBOL_PLATFORM ON}
|
||
{$ENDIF}
|
||
|
||
if SR.Name = '.' then
|
||
begin
|
||
// Rouse_ 14.02.2013
|
||
// Если включено добавление пустых папок, то добавляем сначала требуемую запись
|
||
if AlwaysAddEmptyFolder then
|
||
AddEmptyFolder(TrailingRelativePath, Attributes);
|
||
Continue;
|
||
end;
|
||
|
||
if SR.Attr and faDirectory <> 0 then
|
||
begin
|
||
if SubFolders then
|
||
Inc(Result, AddFolder(TrailingRelativePath + SR.Name,
|
||
TrailingPath + SR.Name, ResultMask, SubFolders));
|
||
end
|
||
else
|
||
begin
|
||
if Assigned(Masks) then
|
||
begin
|
||
Matched := False;
|
||
for I := 0 to Masks.Count - 1 do
|
||
if MatchesMask(SR.Name, Masks[I]) then
|
||
begin
|
||
Matched := True;
|
||
Break;
|
||
end;
|
||
end
|
||
else
|
||
Matched := True;
|
||
|
||
if not Matched then Continue;
|
||
|
||
if AddFile(TrailingPath + SR.Name, Attributes,
|
||
TrailingRelativePath + SR.Name) >= 0 then
|
||
Inc(Result);
|
||
end;
|
||
until FindNext(SR) <> 0;
|
||
finally
|
||
FindClose(SR);
|
||
end;
|
||
finally
|
||
Masks.Free;
|
||
end;
|
||
end;
|
||
|
||
//
|
||
// Функция добавляет в архив данные из переданного стрима.
|
||
// В качестве результата возвращает индекс элемента в списке
|
||
// =============================================================================
|
||
function TFWZipWriter.AddStream(const FileName: string;
|
||
Value: TStream; AOwnerShip: TStreamOwnership): Integer;
|
||
var
|
||
Item: TFWZipWriterItem;
|
||
begin
|
||
Item := CreateItemFromStream(FileName, Value, AOwnerShip);
|
||
Result := AddNewItem(Item);
|
||
end;
|
||
|
||
//
|
||
// Вспомогательная функция для доступа к листу из наследников
|
||
// =============================================================================
|
||
function TFWZipWriter.AddNewItem(Value: TFWZipWriterItem): Integer;
|
||
begin
|
||
Result := FItems.Add(Value);
|
||
end;
|
||
|
||
//
|
||
// Процедура формирует архив и сохраняет его в указанный стрим.
|
||
// =============================================================================
|
||
function TFWZipWriter.BuildZip(Stream: TStream): TBuildZipResult;
|
||
var
|
||
I, TotalCount: Integer;
|
||
BeforeExceptPosition: Int64;
|
||
ExceptAction: TExceptionAction;
|
||
OldPathName, NewFilePath: string;
|
||
NewFileData: TMemoryStream;
|
||
DeletePackedFile: Boolean;
|
||
begin
|
||
FVersionToExtract := 0;
|
||
FTotalProgress := 0;
|
||
FBuildState := True;
|
||
try
|
||
Result := brFailed;
|
||
if Count > 0 then
|
||
begin
|
||
|
||
// Согластно спецификации в самый первый том многотомного архива
|
||
// первой добавляется SPAN_DESCRIPTOR_SIGNATURE
|
||
// см. zip_format.txt 8.5.4
|
||
if IsMultiPartZip(Stream) then
|
||
begin
|
||
I := SPAN_DESCRIPTOR_SIGNATURE;
|
||
Stream.WriteBuffer(I, 4);
|
||
end;
|
||
|
||
// Выставляем размеры CentralDirectory
|
||
SetLength(FCD, Count);
|
||
|
||
// Рассчитываем общий размер элементов для отображения прогресса
|
||
FTotalSizeCount := 0;
|
||
FTotalProcessedCount := 0;
|
||
for I := 0 to Count - 1 do
|
||
begin
|
||
Inc(FTotalSizeCount, Item[I].Size);
|
||
// Rouse_ 12.05.2020
|
||
// Не забываем скинуть флаг ошибки с предыдущей сборки архива
|
||
FCD[I].ExceptOnWrite := False;
|
||
end;
|
||
|
||
// Сжимаем все файлы архива и помещаем их в финальный стрим
|
||
// при этом резервируется место под LocalHeader и DataDescryptor
|
||
// т.к. размер запакованного файла будет известен только после этапа
|
||
// архивации и не понятно куда помещать значение:
|
||
// в LocalHeader, DataDescryptor или в ZIP64 блок данных в CentralDirectory
|
||
FExceptionCount := 0;
|
||
BeforeExceptPosition := 0;
|
||
TotalCount := 0;
|
||
Result := brDone;
|
||
I := 0;
|
||
DeletePackedFile := False;
|
||
OldPathName := '';
|
||
while I < Count do
|
||
begin
|
||
try
|
||
|
||
BeforeExceptPosition := Stream.Position;
|
||
SaveItemToStream(Stream, I);
|
||
Inc(TotalCount);
|
||
Inc(I);
|
||
|
||
// в случае если это повторная попытка сжатия и был применен
|
||
// аттрибут acUseNewFilePathAndDel, то необходимо удалить файл.
|
||
if DeletePackedFile then
|
||
begin
|
||
DeletePackedFile := False;
|
||
NewFilePath := Item[I - 1].FilePath;
|
||
SetNormalFileAttributes(NewFilePath);
|
||
DeleteFile(NewFilePath);
|
||
end;
|
||
|
||
// если путь к файлу был временно изменен из-за применения аттрибутов
|
||
// acUseNewFilePath или acUseNewFilePathAndDel,
|
||
// необходимо восстановить старое значение
|
||
if OldPathName <> '' then
|
||
begin
|
||
FBuildState := False;
|
||
try
|
||
Item[I - 1].FilePath := OldPathName;
|
||
finally
|
||
OldPathName := '';
|
||
FBuildState := True;
|
||
end;
|
||
end;
|
||
|
||
except
|
||
|
||
// Если пользователь отменил создание архива, выходим из цикла
|
||
on E: EAbort do
|
||
begin
|
||
Result := brAborted;
|
||
Exit;
|
||
end;
|
||
|
||
on E: Exception do
|
||
begin
|
||
// возвращаем позицию в стриме на старое место
|
||
Stream.Position := BeforeExceptPosition;
|
||
|
||
// если элемент использовал кастомные данные,
|
||
// то снимаем этот вариант заполнения и пусть извне решают
|
||
// что делать в этом случае
|
||
Item[I].UseExternalData := False;
|
||
|
||
// запрашиваем пользователя, что делать с исключением?
|
||
ExceptAction := eaSkip;
|
||
NewFilePath := '';
|
||
|
||
NewFileData := TMemoryStream.Create;
|
||
try
|
||
|
||
if Assigned(FBuidException) then
|
||
FBuidException(Self, E, I, ExceptAction,
|
||
NewFilePath, NewFileData);
|
||
|
||
// обрабатываем выбор польтзователя
|
||
case ExceptAction of
|
||
|
||
// повторить попытку
|
||
eaRetry:
|
||
Continue;
|
||
|
||
// пропустить элемент
|
||
eaSkip:
|
||
begin
|
||
// то помечаем элемент центральной директории.
|
||
// Он не будет обрабатываться при сохранениии.
|
||
FCD[I].ExceptOnWrite := True;
|
||
// Также увеличим число исключений, для правильной записи
|
||
// количества элементов архива в корневой директории
|
||
Inc(FExceptionCount);
|
||
Inc(I);
|
||
Result := brPartialBuild;
|
||
end;
|
||
|
||
// остановить создание архива
|
||
eaAbort:
|
||
begin
|
||
Result := brAborted;
|
||
Exit;
|
||
end;
|
||
|
||
// использовать данные из другого файла
|
||
eaUseNewFilePath, eaUseNewFilePathAndDel:
|
||
begin
|
||
// запоминаем текущий путь к файлу,
|
||
// для последующего восстановления
|
||
OldPathName := Item[I].FilePath;
|
||
FBuildState := False;
|
||
try
|
||
Item[I].FilePath := NewFilePath;
|
||
finally
|
||
FBuildState := True;
|
||
end;
|
||
// выставляем флаг, что при завершени сжатия,
|
||
// файл слудет удалить
|
||
DeletePackedFile := ExceptAction = eaUseNewFilePathAndDel;
|
||
Continue;
|
||
end;
|
||
|
||
// использовать данные из стрима
|
||
eaUseNewFileData:
|
||
begin
|
||
FBuildState := False;
|
||
try
|
||
Item[I].ChangeDataStream(NewFileData);
|
||
finally
|
||
FBuildState := True;
|
||
end;
|
||
Continue;
|
||
end;
|
||
end;
|
||
|
||
finally
|
||
NewFileData.Free;
|
||
end;
|
||
end;
|
||
|
||
end;
|
||
end;
|
||
|
||
// Если в архив не добавлен ни один из элементов,
|
||
// то возвращаем размер стрима на прежнее значение и выходим с ошибкой
|
||
if TotalCount = 0 then
|
||
begin
|
||
Stream.Size := Stream.Position;
|
||
Result := brFailed;
|
||
Exit;
|
||
end;
|
||
|
||
// Теперь размеры сжатых файлов известны,
|
||
// обновляем LocalHeader и DataDescryptor
|
||
UpdateLocalHeaders(Stream);
|
||
|
||
// Записываем CentralDirectory
|
||
SaveCentralDirectory(Stream);
|
||
|
||
// Пишем структуру EndOfCentralDirectory при этом при необходимости
|
||
// формируются и пишутся также структуры Zip64EOFCentralDirectoryRecord
|
||
// и Zip64EOFCentralDirectoryLocator
|
||
SaveEndOfCentralDirectory(Stream);
|
||
end;
|
||
finally
|
||
FBuildState := False;
|
||
end;
|
||
end;
|
||
|
||
//
|
||
// Процедура формирует архив и сохраняет его в указанный файл.
|
||
// =============================================================================
|
||
function TFWZipWriter.BuildZip(ZipFilePath: string): TBuildZipResult;
|
||
var
|
||
ZIP: TFileStream;
|
||
begin
|
||
Result := brFailed;
|
||
if Count = 0 then Exit;
|
||
ZipFilePath := PathCanonicalize(ZipFilePath);
|
||
ForceDirectoriesEx(ExtractFilePath(ZipFilePath));
|
||
ZIP := TFileStream.Create(ZipFilepath, fmCreate);
|
||
try
|
||
Result := BuildZip(ZIP);
|
||
FinallyFileBuffers(ZIP.Handle);
|
||
finally
|
||
ZIP.Free;
|
||
end;
|
||
if Result in [brFailed, brAborted] then
|
||
DeleteFile(ZipFilePath);
|
||
end;
|
||
|
||
//
|
||
// Функция проводит проверку правильности наименования файла в архиве
|
||
// =============================================================================
|
||
function TFWZipWriter.CheckFileNameSlashes(const Value: string): string;
|
||
begin
|
||
{
|
||
The name of the file, with optional relative path.
|
||
The path stored should not contain a drive or
|
||
device letter, or a leading slash. All slashes
|
||
should be forward slashes '/' as opposed to
|
||
backwards slashes '\' for compatibility with Amiga
|
||
and Unix file systems etc.
|
||
}
|
||
|
||
Result := StringReplace(Value, '\', ZIP_SLASH, [rfReplaceAll]);
|
||
end;
|
||
|
||
//
|
||
// Очищаем все добавленные в архив элементы
|
||
// =============================================================================
|
||
procedure TFWZipWriter.Clear;
|
||
begin
|
||
FItems.Clear;
|
||
end;
|
||
|
||
//
|
||
// Процедура сжимет данные
|
||
// =============================================================================
|
||
procedure TFWZipWriter.CompressItem(CurrentItem: TFWZipWriterItem;
|
||
Index: Integer; StreamSizeBeforeCompress: Int64; Stream: TStream);
|
||
|
||
|
||
function CopyWithProgress(Src, Dst: TStream;
|
||
Cryptor: TFWZipCryptor): Cardinal;
|
||
var
|
||
Buff: Pointer;
|
||
Size, TotalSize: Integer;
|
||
begin
|
||
Result := $FFFFFFFF;
|
||
GetMem(Buff, MAXWORD);
|
||
try
|
||
Src.Position := 0;
|
||
FCompressedStream := Src;
|
||
DoProgress(psInitialization);
|
||
try
|
||
TotalSize := 0;
|
||
while True do
|
||
begin
|
||
Size := Src.Read(Buff^, MAXWORD);
|
||
Result := CRC32Calc(Result, Buff, Size);
|
||
if Size <> 0 then
|
||
begin
|
||
Inc(TotalSize, Size);
|
||
if Cryptor <> nil then
|
||
Cryptor.EncryptBuffer(Buff, Size);
|
||
Dst.WriteBuffer(Buff^, Size);
|
||
DoProgress(psInProgress);
|
||
end
|
||
else
|
||
Break;
|
||
end;
|
||
if TotalSize <> Src.Size then
|
||
raise EZipWriterWrite.CreateFmt(
|
||
'Ошибка записи данных элемента №%d "%s".', [Index, Item[Index].FileName]);
|
||
except
|
||
DoProgress(psException);
|
||
raise;
|
||
end;
|
||
DoProgress(psFinalization);
|
||
finally
|
||
FreeMem(Buff);
|
||
end;
|
||
Result := Result xor $FFFFFFFF;
|
||
end;
|
||
|
||
var
|
||
F: TFileStream;
|
||
Compressor: TZCompressionStream;
|
||
Cryptor: TFWZipCryptor;
|
||
ZipItemStream: TFWZipItemStream;
|
||
CRC32Stream: TFWZipCRC32Stream;
|
||
EncryptedHeaderStream: TMemoryStream;
|
||
begin
|
||
Cryptor := nil;
|
||
try
|
||
EncryptedHeaderStream := TMemoryStream.Create;
|
||
try
|
||
if CurrentItem.Password <> '' then
|
||
begin
|
||
Cryptor := TFWZipCryptor.Create(AnsiString(CurrentItem.Password));
|
||
Cryptor.GenerateEncryptionHeader(EncryptedHeaderStream,
|
||
CurrentItem.NeedDescriptor,
|
||
FCD[Index].Header.Crc32,
|
||
FCD[Index].Header.LastModFileTimeTime +
|
||
FCD[Index].Header.LastModFileTimeDate shl 16);
|
||
// резервируем место под EncryptedHeaderStream
|
||
Stream.Size := StreamSizeBeforeCompress + EncryptedHeaderSize;
|
||
Stream.Position := Stream.Size;
|
||
end;
|
||
|
||
// пишем сам сжатый файл
|
||
case FCD[Index].Header.CompressionMethod of
|
||
Z_NO_COMPRESSION:
|
||
begin
|
||
if CurrentItem.Data <> nil then
|
||
FCD[Index].Header.Crc32 :=
|
||
CopyWithProgress(CurrentItem.Data, Stream, Cryptor)
|
||
else
|
||
begin
|
||
try
|
||
F := TFileStream.Create(CurrentItem.FilePath,
|
||
fmOpenRead or fmShareDenyWrite);
|
||
try
|
||
FCD[Index].Header.Crc32 :=
|
||
CopyWithProgress(F, Stream, Cryptor)
|
||
finally
|
||
F.Free;
|
||
end;
|
||
except
|
||
on E: Exception do
|
||
raise EZipWriterWrite.CreateFmt(string(
|
||
'Ошибка доступа к данным элемента №%d "%s".' +
|
||
sLineBreak) + ExceptionMessage(E),
|
||
[Index, CurrentItem.FileName]);
|
||
end;
|
||
end;
|
||
// Получаем размер сжатых данных
|
||
// В случае если использовалось шифрование в размере срузу будет
|
||
// учтен 12-ти байтный заголовок инициализации ключа расшифровки
|
||
FCD[Index].CompressedSize := Stream.Size - StreamSizeBeforeCompress;
|
||
end;
|
||
Z_DEFLATED:
|
||
begin
|
||
{$IFDEF USE_AUTOGENERATED_ZLIB_HEADER}
|
||
// позицию сдвигаем на два байта влево,
|
||
// таким образом мы затрем ненужный нам заголовок ZLib
|
||
Stream.Position := Stream.Position - 2;
|
||
{$ENDIF}
|
||
if CurrentItem.Data <> nil then
|
||
begin
|
||
// сохраняем ссылку на стрим с данными для рассчета прогресса
|
||
FCompressedStream := CurrentItem.Data;
|
||
ZipItemStream := TFWZipItemStream.Create(Stream, Cryptor, nil,
|
||
0, CurrentItem.Size);
|
||
try
|
||
Compressor := TZCompressionStream.Create(
|
||
ZipItemStream, CurrentItem.CompressionLevel,
|
||
defaultWindowBits, 8, zsDefault);
|
||
try
|
||
Compressor.OnProgress := CompressorOnProcess;
|
||
DoProgress(psInitialization);
|
||
try
|
||
CRC32Stream := TFWZipCRC32Stream.Create(CurrentItem.Data);
|
||
try
|
||
Compressor.CopyFrom(CRC32Stream, 0);
|
||
FCD[Index].Header.Crc32 := CRC32Stream.CRC32;
|
||
finally
|
||
CRC32Stream.Free;
|
||
end;
|
||
except
|
||
DoProgress(psException);
|
||
raise;
|
||
end;
|
||
DoProgress(psFinalization);
|
||
finally
|
||
Compressor.Free;
|
||
end;
|
||
finally
|
||
ZipItemStream.Free;
|
||
end;
|
||
end
|
||
else
|
||
begin
|
||
// TFWZipItemStream выступает как посредник между результирующим
|
||
// стримом и TCompressionStream.
|
||
// Его задача зашифровать все проходящие через нешго данные
|
||
ZipItemStream := TFWZipItemStream.Create(Stream, Cryptor, nil,
|
||
0, CurrentItem.Size);
|
||
try
|
||
Compressor := TZCompressionStream.Create(
|
||
ZipItemStream, CurrentItem.CompressionLevel,
|
||
defaultWindowBits, 8, zsDefault);
|
||
try
|
||
try
|
||
F := TFileStream.Create(CurrentItem.FilePath,
|
||
fmOpenRead or fmShareDenyWrite);
|
||
try
|
||
// сохраняем ссылку на стрим с данными для рассчета прогресса
|
||
FCompressedStream := F;
|
||
F.Position := 0;
|
||
Compressor.OnProgress := CompressorOnProcess;
|
||
// TFWZipCRC32Stream выступает как посредник между
|
||
// нераспакованными данными и TCompressionStream,
|
||
// в котором происходит сжатие данных.
|
||
// Его задача отследить все переданные через него
|
||
// блоки данных и рассчитать их контрольную сумму
|
||
// до того как они будут сжаты
|
||
DoProgress(psInitialization);
|
||
try
|
||
CRC32Stream := TFWZipCRC32Stream.Create(F);
|
||
try
|
||
Compressor.CopyFrom(CRC32Stream, 0);
|
||
FCD[Index].Header.Crc32 := CRC32Stream.CRC32;
|
||
finally
|
||
CRC32Stream.Free;
|
||
end;
|
||
except
|
||
DoProgress(psException);
|
||
raise;
|
||
end;
|
||
DoProgress(psFinalization);
|
||
finally
|
||
F.Free;
|
||
end;
|
||
except
|
||
on E: Exception do
|
||
raise EZipWriterWrite.CreateFmt(string(
|
||
'Ошибка доступа к данным элемента №%d "%s".' +
|
||
sLineBreak) + ExceptionMessage(E),
|
||
[Index, CurrentItem.FileName]);
|
||
end;
|
||
finally
|
||
Compressor.Free;
|
||
end;
|
||
finally
|
||
ZipItemStream.Free;
|
||
end;
|
||
end;
|
||
|
||
{$IFDEF USE_AUTOGENERATED_ZLIB_HEADER}
|
||
// Rouse_ 14.02.2013
|
||
// Не знаю почему, но опытным путем установлено,
|
||
// что размер запакованых данных должен быть меньше на 4 байта
|
||
// при использовании автогенерируемого заголовка.
|
||
// Этот момент учитывается в ICSharpCode.SharpZipLibrary
|
||
// Распаковка в любом случае происходит нормально
|
||
if TrimPackedStreamSize then
|
||
Stream.Size := Stream.Size - 4;
|
||
{$ENDIF}
|
||
|
||
// Получаем размер сжатых данных
|
||
// В случае если использовалось шифрование в размере срузу будет
|
||
// учтен 12-ти байтный заголовок инициализации ключа расшифровки
|
||
FCD[Index].CompressedSize := Stream.Size - StreamSizeBeforeCompress;
|
||
|
||
end;
|
||
end;
|
||
|
||
// если файл зашифрован,
|
||
// записываем заголовок инициализации ключа расшифровки
|
||
if EncryptedHeaderStream.Size > 0 then
|
||
begin
|
||
Stream.Position := StreamSizeBeforeCompress;
|
||
Stream.CopyFrom(EncryptedHeaderStream, 0);
|
||
end;
|
||
finally
|
||
EncryptedHeaderStream.Free;
|
||
end;
|
||
|
||
finally
|
||
Cryptor.Free;
|
||
end;
|
||
end;
|
||
|
||
//
|
||
// Процедура вызывает событие OnProcess
|
||
// =============================================================================
|
||
procedure TFWZipWriter.CompressorOnProcess(Sender: TObject);
|
||
begin
|
||
DoProgress(psInProgress);
|
||
end;
|
||
|
||
//
|
||
// Функция возвращает количество добавленных элементов архива
|
||
// =============================================================================
|
||
function TFWZipWriter.Count: Integer;
|
||
begin
|
||
Result := FItems.Count;
|
||
end;
|
||
|
||
//
|
||
// Стандартный конструктор класса
|
||
// =============================================================================
|
||
constructor TFWZipWriter.Create;
|
||
begin
|
||
Create(False, clDefault, '');
|
||
end;
|
||
|
||
//
|
||
// Расширенный конструктор класса,
|
||
// в котором можно указать степень сжатия,
|
||
// используемую для всех элементов по умолчанию.
|
||
// =============================================================================
|
||
constructor TFWZipWriter.Create(CompressionLevel: TCompressionLevel);
|
||
begin
|
||
Create(False, CompressionLevel, '');
|
||
end;
|
||
|
||
//
|
||
// Расширенный конструктор класса,
|
||
// в котором можно изменить настройки элементов будующего архива по умолчнию.
|
||
// =============================================================================
|
||
constructor TFWZipWriter.Create(UseDescryptors: Boolean;
|
||
CompressionLevel: TCompressionLevel; const DefaultPassword: string);
|
||
begin
|
||
inherited Create;
|
||
FDefaultDescryptorState := UseDescryptors;
|
||
FDefaultCompressionLevel := CompressionLevel;
|
||
FDefaultPassword := DefaultPassword;
|
||
FItems := TObjectList.Create;
|
||
FItems.Capacity := 100000;
|
||
FTrimPackedStreamSize := True;
|
||
end;
|
||
|
||
//
|
||
// Функция создает но не добавляет в масив записей новый элемент
|
||
// =============================================================================
|
||
function TFWZipWriter.CreateItemFromStream(const FileName: string;
|
||
Value: TStream; AOwnerShip: TStreamOwnership): TFWZipWriterItem;
|
||
var
|
||
Size: Int64;
|
||
InitFileName: string;
|
||
Attributes: TFileAttributeData;
|
||
begin
|
||
// проверка на дубли
|
||
InitFileName := CheckFileNameSlashes(FileName);
|
||
|
||
Size := Value.Size;
|
||
ZeroMemory(@Attributes, SizeOf(TFileAttributeData));
|
||
Attributes.ftCreationTime := GetCurrentFileTime;
|
||
Attributes.ftLastAccessTime := Attributes.ftCreationTime;
|
||
Attributes.ftLastWriteTime := Attributes.ftCreationTime;
|
||
Attributes.nFileSizeLow := Size and MAXDWORD;
|
||
Attributes.nFileSizeHigh := Size shr 32;
|
||
Result := GetItemClass.Create(Self, '', Attributes, InitFileName);
|
||
Result.CompressionLevel := FDefaultCompressionLevel;
|
||
Result.Password := FDefaultPassword;
|
||
|
||
// в случае наличия дескриптора мы можем
|
||
// производить расчет контрольной суммы на лету, т.к. при включенном
|
||
// режиме шифрования она не участвует в генерации заголовка инициализации
|
||
Result.NeedDescriptor := FDefaultDescryptorState;
|
||
|
||
Result.ChangeDataStream(Value, AOwnerShip);
|
||
end;
|
||
|
||
//
|
||
// Процедура удаляет ненужный элемент архива
|
||
// =============================================================================
|
||
procedure TFWZipWriter.DeleteItem(Index: Integer);
|
||
begin
|
||
FItems.Delete(Index);
|
||
end;
|
||
|
||
//
|
||
// Стандартный деструктор класса
|
||
// =============================================================================
|
||
destructor TFWZipWriter.Destroy;
|
||
begin
|
||
FItems.Free;
|
||
inherited;
|
||
end;
|
||
|
||
//
|
||
// Вызов внешнего события о прогрессе сжатия
|
||
// =============================================================================
|
||
procedure TFWZipWriter.DoProgress(ProgressState: TProgressState);
|
||
var
|
||
CurrentProgress: Byte;
|
||
Cancel: Boolean;
|
||
begin
|
||
if Assigned(FOnProgress) then
|
||
begin
|
||
case ProgressState of
|
||
psInProgress:
|
||
begin
|
||
if FCompressedStream.Size = 0 then
|
||
CurrentProgress := 100
|
||
else
|
||
CurrentProgress :=
|
||
Round(FCompressedStream.Position / (FCompressedStream.Size / 100));
|
||
if FTotalSizeCount = 0 then
|
||
FTotalProgress := 100
|
||
else
|
||
FTotalProgress :=
|
||
Round((FTotalProcessedCount + FCompressedStream.Position) /
|
||
(FTotalSizeCount / 100));
|
||
end;
|
||
psFinalization, psEnd: CurrentProgress := 100;
|
||
else
|
||
CurrentProgress := 0;
|
||
end;
|
||
Cancel := False;
|
||
FOnProgress(Self, Item[FProcessedItemIndex].FileName,
|
||
CurrentProgress, FTotalProgress, Cancel, ProgressState);
|
||
if Cancel then Abort;
|
||
end;
|
||
end;
|
||
|
||
//
|
||
// Рассчитываем длину строки с учетом UTF8
|
||
// =============================================================================
|
||
function TFWZipWriter.StringLength(const Value: string; AUseUTF8String: Boolean): Integer;
|
||
begin
|
||
if AUseUTF8String then
|
||
Result := Length(UTF8Encode(Value))
|
||
else
|
||
Result := Length(ConvertToOemString(AnsiString(Value)));
|
||
end;
|
||
|
||
//
|
||
// Функция возвращает текущее время в формате TFileTime
|
||
// =============================================================================
|
||
function TFWZipWriter.GetCurrentFileTime: TFileTime;
|
||
begin
|
||
Result := DateTimeToFileTime(Now);
|
||
end;
|
||
|
||
//
|
||
// Обработчик свойства Items
|
||
// =============================================================================
|
||
function TFWZipWriter.GetItem(Index: Integer): TFWZipWriterItem;
|
||
begin
|
||
Result := TFWZipWriterItem(FItems[Index]);
|
||
end;
|
||
|
||
//
|
||
// Запрашиваем данные о расширенных блоках данных для каждой записи
|
||
// =============================================================================
|
||
procedure TFWZipWriter.FillExData(Stream: TStream; Index: Integer);
|
||
var
|
||
ExDataStream: TMemoryStream;
|
||
EmptyExData: Boolean;
|
||
UserExDataBlockCount, {%H-}ExDataSize: Integer;
|
||
ExDataHeaderTag: Word;
|
||
begin
|
||
if Assigned(FSaveExData) then
|
||
begin
|
||
ExDataStream := TMemoryStream.Create;
|
||
try
|
||
EmptyExData := False;
|
||
UserExDataBlockCount := 0;
|
||
while not EmptyExData do
|
||
begin
|
||
ExDataHeaderTag := 0;
|
||
ExDataStream.Clear;
|
||
FSaveExData(Self, Index, UserExDataBlockCount,
|
||
ExDataHeaderTag, ExDataStream);
|
||
Inc(UserExDataBlockCount);
|
||
EmptyExData := ExDataStream.Size = 0;
|
||
if not EmptyExData then
|
||
begin
|
||
// Rouse_ 18.05.2020
|
||
// Фикс ошибки. Общий размер блока EXDATA ограничен MAXWORD
|
||
// А не каждая запись в нем!
|
||
if Stream.Size + ExDataStream.Size + 4 > MAXWORD then
|
||
raise EZipWriter.Create(
|
||
'Размер блока расширенных данных' +
|
||
' не может превышать 65535 байт.')
|
||
else
|
||
ExDataSize := ExDataStream.Size;
|
||
if ExDataHeaderTag in
|
||
[0, SUPPORTED_EXDATA_ZIP64, SUPPORTED_EXDATA_NTFSTIME] then
|
||
raise EZipWriter.Create(
|
||
'Нельзя использовать зарезервированные тэги' +
|
||
' блока расширенных данных.');
|
||
Stream.WriteBuffer(ExDataHeaderTag, 2);
|
||
Stream.WriteBuffer(ExDataSize, 2);
|
||
Stream.CopyFrom(ExDataStream, 0);
|
||
end;
|
||
end;
|
||
finally
|
||
ExDataStream.Free;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
//
|
||
// Инициализируем CentralDirectoryFileHeader элемента
|
||
// =============================================================================
|
||
procedure TFWZipWriter.FillItemCDFHeader(CurrentItem: TFWZipWriterItem;
|
||
var Value: TCentralDirectoryFileHeaderEx);
|
||
var
|
||
FileDate: Cardinal;
|
||
Buff: array of Byte;
|
||
begin
|
||
Value.Header.CentralFileHeaderSignature := CENTRAL_FILE_HEADER_SIGNATURE;
|
||
Value.Header.VersionMadeBy := CurrentVersionMadeBy;
|
||
Value.Header.VersionNeededToExtract := 0; // Рассчитывается позднее
|
||
|
||
Value.Header.GeneralPurposeBitFlag := 0;
|
||
if CurrentItem.Password <> '' then
|
||
Value.Header.GeneralPurposeBitFlag :=
|
||
Value.Header.GeneralPurposeBitFlag or PBF_CRYPTED;
|
||
|
||
{%H-}case CurrentItem.CompressionLevel of
|
||
clNone:; // данный режим компрессии не поддерживается, сразу меняем на Store
|
||
clFastest:
|
||
Value.Header.GeneralPurposeBitFlag :=
|
||
Value.Header.GeneralPurposeBitFlag or PBF_COMPRESS_SUPERFAST;
|
||
clDefault:
|
||
Value.Header.GeneralPurposeBitFlag :=
|
||
Value.Header.GeneralPurposeBitFlag or PBF_COMPRESS_NORMAL;
|
||
clMax:
|
||
Value.Header.GeneralPurposeBitFlag :=
|
||
Value.Header.GeneralPurposeBitFlag or PBF_COMPRESS_MAXIMUM;
|
||
end;
|
||
if CurrentItem.NeedDescriptor then
|
||
Value.Header.GeneralPurposeBitFlag :=
|
||
Value.Header.GeneralPurposeBitFlag or PBF_DESCRIPTOR;
|
||
|
||
if CurrentItem.CompressionLevel = clNone then
|
||
Value.Header.CompressionMethod := Z_NO_COMPRESSION
|
||
else
|
||
Value.Header.CompressionMethod := Z_DEFLATED;
|
||
|
||
if not CurrentItem.IsFolder then
|
||
if not CurrentItem.NeedDescriptor then
|
||
if CurrentItem.Password <> '' then
|
||
begin
|
||
// в случае если дескрипторы отключены и включено шифрование элемента
|
||
// то необходимо рассчитать его контрольную сумму перед
|
||
// генерацией заголовка инициализации ключа шифрования
|
||
if CurrentItem.Data = nil then
|
||
Value.Header.Crc32 := FileCRC32(CurrentItem.FilePath)
|
||
else
|
||
begin
|
||
CurrentItem.Data.Position := 0;
|
||
SetLength(Buff{%H-}, CurrentItem.Data.Size);
|
||
CurrentItem.Data.Read(Buff[0], CurrentItem.Data.Size);
|
||
Value.Header.Crc32 :=
|
||
CRC32Calc(@Buff[0], CurrentItem.Data.Size);
|
||
end;
|
||
end;
|
||
Value.UncompressedSize := CurrentItem.Size;
|
||
|
||
FileDate := FileTimeToLocalFileDate(CurrentItem.Attributes.ftLastWriteTime);
|
||
|
||
Value.Header.LastModFileTimeTime := FileDate and $FFFF;
|
||
Value.Header.LastModFileTimeDate := FileDate shr 16;
|
||
|
||
Value.Filename := CurrentItem.FileName;
|
||
Value.Header.FilenameLength :=
|
||
StringLength(CurrentItem.Filename, CurrentItem.UseUTF8String);
|
||
Value.Header.ExtraFieldLength := 0;
|
||
Value.FileComment := CurrentItem.Comment;
|
||
Value.Header.FileCommentLength :=
|
||
StringLength(CurrentItem.Comment, CurrentItem.UseUTF8String);
|
||
|
||
Value.Header.InternalFileAttributes := 0;
|
||
Value.Header.ExternalFileAttributes :=
|
||
CurrentItem.Attributes.dwFileAttributes;
|
||
Value.Attributes := CurrentItem.Attributes;
|
||
|
||
if CurrentItem.UseUTF8String then
|
||
Value.Header.GeneralPurposeBitFlag :=
|
||
Value.Header.GeneralPurposeBitFlag or PBF_UTF8;
|
||
end;
|
||
|
||
function TFWZipWriter.Find(const Value: string; out AItem: TFWZipWriterItem;
|
||
IgnoreCase: Boolean): Boolean;
|
||
var
|
||
I: Integer;
|
||
AItemText: string;
|
||
begin
|
||
Result := False;
|
||
AItem := nil;
|
||
for I := 0 to Count - 1 do
|
||
begin
|
||
AItemText := Item[I].FileName;
|
||
if IgnoreCase then
|
||
Result := AnsiSameText(Value, AItemText)
|
||
else
|
||
Result := AnsiSameStr(Value, AItemText);
|
||
if Result then
|
||
begin
|
||
AItem := Item[I];
|
||
Break;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
//
|
||
// Добавляем возможность создавать наследников от базового класса
|
||
// =============================================================================
|
||
function TFWZipWriter.GetItemClass: TFWZipWriterItemClass;
|
||
begin
|
||
Result := TFWZipWriterItem;
|
||
end;
|
||
|
||
//
|
||
// Функция рассчитывает минимальную версию для извлечения
|
||
// указанного элемента архива
|
||
// =============================================================================
|
||
function TFWZipWriter.GetVersionToExtract(Index: Integer): Word;
|
||
begin
|
||
{
|
||
Current minimum feature versions are as defined below:
|
||
|
||
1.0 - Default value
|
||
1.1 - File is a volume label
|
||
2.0 - File is a folder (directory)
|
||
2.0 - File is compressed using Deflate compression
|
||
2.0 - File is encrypted using traditional PKWARE encryption
|
||
2.1 - File is compressed using Deflate64(tm)
|
||
2.5 - File is compressed using PKWARE DCL Implode
|
||
2.7 - File is a patch data set
|
||
4.5 - File uses ZIP64 format extensions
|
||
4.6 - File is compressed using BZIP2 compression*
|
||
5.0 - File is encrypted using DES
|
||
5.0 - File is encrypted using 3DES
|
||
5.0 - File is encrypted using original RC2 encryption
|
||
5.0 - File is encrypted using RC4 encryption
|
||
5.1 - File is encrypted using AES encryption
|
||
5.1 - File is encrypted using corrected RC2 encryption**
|
||
5.2 - File is encrypted using corrected RC2-64 encryption**
|
||
6.1 - File is encrypted using non-OAEP key wrapping***
|
||
6.2 - Central directory encryption
|
||
}
|
||
|
||
// TFWZIPWriter поддерживает следующие расширения стандарта:
|
||
// 1. использование директорий (версия для извлечения - 2.0)
|
||
// 2. использование ZIP64 расширения (версия для извлечения - 4.5)
|
||
|
||
// Для определения, нужно ли нам использовать ZIP64 необходимо проверить
|
||
// следующие параметры:
|
||
// размер каждого элемента архива сжатого и не сжатого,
|
||
// оффсет на начало блока данных для каждого элемента
|
||
// если любое из этих значений выходит за значение MAXDWORD,
|
||
// или количество элементов архива выходит за значение MAXWORD,
|
||
// нам необходимо применять ZIP64
|
||
|
||
Result := 20;
|
||
if (FCD[Index].UncompressedSize >= MAXDWORD) or
|
||
(FCD[Index].CompressedSize >= MAXDWORD) or
|
||
(FCD[Index].RelativeOffsetOfLocalHeader >= MAXDWORD) or
|
||
(FCD[Index].DiskNumberStart >= MAXWORD) then
|
||
Result := 45;
|
||
end;
|
||
|
||
//
|
||
// Функция добавляет в архив данные из переданного стрима.
|
||
// В качестве результата возвращает индекс элемента в списке
|
||
// =============================================================================
|
||
function TFWZipWriter.InsertStream(const FileName: string; Index: Integer;
|
||
Value: TStream; AOwnerShip: TStreamOwnership): Integer;
|
||
var
|
||
Item: TFWZipWriterItem;
|
||
begin
|
||
Item := CreateItemFromStream(FileName, Value, AOwnerShip);
|
||
FItems.Insert(Index, Item);
|
||
Result := Index;
|
||
end;
|
||
|
||
//
|
||
// Функция для переключения логики работы с многотомными масивами
|
||
// =============================================================================
|
||
function TFWZipWriter.IsMultiPartZip(AStream: TStream): Boolean;
|
||
begin
|
||
Result := AStream is TFWAbstractMultiStream;
|
||
end;
|
||
|
||
//
|
||
// Процедура проводит сохранение секции CentralDirectory
|
||
// =============================================================================
|
||
procedure TFWZipWriter.SaveCentralDirectory(Stream: TStream);
|
||
var
|
||
I, DiskNumber: Integer;
|
||
RealtiveOffset, VolumeSize: Int64;
|
||
{%H-}ExDataHeader: TExDataHeaderAndSize;
|
||
ExDataNTFS: TExDataNTFS;
|
||
ZIP64Data: TMemoryStream;
|
||
TotalExDataStream: TMemoryStream;
|
||
FirstDisk: Boolean;
|
||
begin
|
||
FirstDisk := True;
|
||
FcdfhRecordOnDisk := 0;
|
||
FSizeOfCentralDir := FcdfhOffset;
|
||
if IsMultiPartZip(Stream) then
|
||
TFWAbstractMultiStream(Stream).GetRelativeInfo(FcdfhDiskNumber, FcdfhOffset)
|
||
else
|
||
FcdfhDiskNumber := 0;
|
||
|
||
for I := 0 to Count - 1 do
|
||
begin
|
||
|
||
// пропускаем элементы при записи которых произошло исключение
|
||
if FCD[I].ExceptOnWrite then Continue;
|
||
|
||
// перед записью каждого элемента CentralDirectory
|
||
// необходимо подготовить буфферы с расширенными данными
|
||
// и указать их расмер
|
||
ZIP64Data := TMemoryStream.Create;
|
||
try
|
||
// подготавиваем буффер с ZIP64 данными
|
||
|
||
{
|
||
The order of the fields in the ZIP64 extended
|
||
information record is fixed, but the fields will
|
||
only appear if the corresponding Local or Central
|
||
directory record field is set to 0xFFFF or 0xFFFFFFFF.
|
||
}
|
||
|
||
if FCD[I].UncompressedSize >= MAXDWORD then
|
||
ZIP64Data.WriteBuffer(FCD[I].UncompressedSize, 8);
|
||
if FCD[I].CompressedSize >= MAXDWORD then
|
||
ZIP64Data.WriteBuffer(FCD[I].CompressedSize, 8);
|
||
if FCD[I].RelativeOffsetOfLocalHeader >= MAXDWORD then
|
||
ZIP64Data.WriteBuffer(FCD[I].RelativeOffsetOfLocalHeader, 8);
|
||
if FCD[I].DiskNumberStart >= MAXWORD then
|
||
ZIP64Data.WriteBuffer(FCD[I].DiskNumberStart, 4);
|
||
|
||
ZeroMemory(@ExDataNTFS, SizeOf(TExDataNTFS));
|
||
if IsAttributesPresent(FCD[I].Attributes) then
|
||
begin
|
||
// подготавливаем буффер с NTFS временем
|
||
FCD[I].Header.ExtraFieldLength := SizeOf(TExDataNTFS);
|
||
|
||
// (NTFS) 0x000a Short Tag for this "extra" block type
|
||
ExDataNTFS.HS.Header := SUPPORTED_EXDATA_NTFSTIME;
|
||
{
|
||
In the current implementations, this field has
|
||
a fixed total data size of 32 bytes and is only stored as local
|
||
extra field
|
||
}
|
||
ExDataNTFS.HS.Size := 32;
|
||
// Reserved Long for future use
|
||
ExDataNTFS.Reserved := 0;
|
||
// Tag1 Short NTFS attribute tag value #1
|
||
ExDataNTFS.Tag := 1;
|
||
//Size1 2 bytes Size of attribute #1, in bytes (24)
|
||
ExDataNTFS.RecordSize := 24;
|
||
ExDataNTFS.Data.Mtime := FCD[I].Attributes.ftLastWriteTime;
|
||
ExDataNTFS.Data.Atime := FCD[I].Attributes.ftLastAccessTime;
|
||
ExDataNTFS.Data.Ctime := FCD[I].Attributes.ftCreationTime;
|
||
end;
|
||
if ZIP64Data.Size > 0 then
|
||
Inc(FCD[I].Header.ExtraFieldLength,
|
||
ZIP64Data.Size + SizeOf(TExDataHeaderAndSize));
|
||
|
||
TotalExDataStream := TMemoryStream.Create;
|
||
try
|
||
// Запрашиваем блоки ExData от пользователя
|
||
FillExData(TotalExDataStream, I);
|
||
|
||
// правим общий размер расширенных блоков
|
||
Inc(FCD[I].Header.ExtraFieldLength, TotalExDataStream.Size);
|
||
|
||
// Для MultiPart архива надо следить чтобы CentralDirectoryFileHeader
|
||
// целиком влазило в том и небыло разбития между границ двух томов
|
||
if IsMultiPartZip(Stream) then
|
||
begin
|
||
VolumeSize := TFWAbstractMultiStream(Stream).GetWriteVolumeSize;
|
||
TFWAbstractMultiStream(Stream).GetRelativeInfo(
|
||
DiskNumber, RealtiveOffset);
|
||
if VolumeSize < RealtiveOffset + SizeOf(TCentralDirectoryFileHeader) +
|
||
FCD[I].Header.FilenameLength + FCD[I].Header.FileCommentLength +
|
||
FCD[I].Header.ExtraFieldLength then
|
||
begin
|
||
TFWAbstractMultiStream(Stream).StartNewVolume;
|
||
if FcdfhRecordOnDisk = 0 then
|
||
begin
|
||
Inc(FcdfhDiskNumber);
|
||
FcdfhOffset := 0;
|
||
end
|
||
else
|
||
FirstDisk := False;
|
||
end;
|
||
end;
|
||
|
||
// Пишем структуру TCentralDirectoryFileHeader, описывающую элемент
|
||
Stream.WriteBuffer(FCD[I].Header, SizeOf(TCentralDirectoryFileHeader));
|
||
|
||
// Пишем наименование элемента
|
||
SaveString(Stream, FCD[I].FileName,
|
||
FCD[I].Header.GeneralPurposeBitFlag and PBF_UTF8 = PBF_UTF8);
|
||
|
||
// если нужно - доп информацию в формате ZIP64
|
||
if ZIP64Data.Size > 0 then
|
||
begin
|
||
ExDataHeader.Header := SUPPORTED_EXDATA_ZIP64;
|
||
ExDataHeader.Size := ZIP64Data.Size;
|
||
Stream.WriteBuffer(ExDataHeader, SizeOf(TExDataHeaderAndSize));
|
||
Stream.CopyFrom(ZIP64Data, 0);
|
||
end;
|
||
|
||
// потом информацию о NTFSTime
|
||
if ExDataNTFS.HS.Header = SUPPORTED_EXDATA_NTFSTIME then
|
||
Stream.WriteBuffer(ExDataNTFS, SizeOf(TExDataNTFS));
|
||
|
||
// и расширенную информацию полученную от пользователя
|
||
if TotalExDataStream.Size > 0 then
|
||
Stream.CopyFrom(TotalExDataStream, 0);
|
||
|
||
finally
|
||
TotalExDataStream.Free;
|
||
end;
|
||
|
||
// в завершение, пишем коментарий к элементу
|
||
SaveString(Stream, FCD[I].FileComment,
|
||
FCD[I].Header.GeneralPurposeBitFlag and PBF_UTF8 = PBF_UTF8);
|
||
|
||
if FirstDisk then
|
||
Inc(FcdfhRecordOnDisk);
|
||
|
||
finally
|
||
ZIP64Data.Free;
|
||
end;
|
||
end;
|
||
FSizeOfCentralDir := Stream.Position - FSizeOfCentralDir;
|
||
end;
|
||
|
||
//
|
||
// Процедура проводит сохранение секции EndOfCentralDirectory
|
||
// =============================================================================
|
||
procedure TFWZipWriter.SaveEndOfCentralDirectory(Stream: TStream);
|
||
var
|
||
eo64cd: TZip64EOFCentralDirectoryRecord;
|
||
{%H-}locator: TZip64EOFCentralDirectoryLocator;
|
||
eocd: TEndOfCentralDir;
|
||
eo64cdOffset: Int64;
|
||
DiskNumber: Integer;
|
||
VolumeSize: Int64;
|
||
begin
|
||
eocd.ZipfileCommentLength := StringLength(FComment, False);
|
||
if IsMultiPartZip(Stream) then
|
||
begin
|
||
VolumeSize := TFWAbstractMultiStream(Stream).GetWriteVolumeSize;
|
||
TFWAbstractMultiStream(Stream).GetRelativeInfo(DiskNumber, eo64cdOffset);
|
||
if VolumeSize < eo64cdOffset + SizeOf(TZip64EOFCentralDirectoryRecord) +
|
||
SizeOf(TZip64EOFCentralDirectoryLocator) + SizeOf(TEndOfCentralDir) +
|
||
eocd.ZipfileCommentLength then
|
||
begin
|
||
TFWAbstractMultiStream(Stream).StartNewVolume;
|
||
Inc(DiskNumber);
|
||
eo64cdOffset := 0;
|
||
end;
|
||
locator.TotalNumberOfDisks := TFWAbstractMultiStream(Stream).GetDiskCount;
|
||
end
|
||
else
|
||
begin
|
||
DiskNumber := 0;
|
||
eo64cdOffset := Stream.Position;
|
||
locator.TotalNumberOfDisks := 1;
|
||
end;
|
||
|
||
// количество записей в конкретном томе
|
||
eo64cd.TotalNumberOfEntriesOnThisDisk := FcdfhRecordOnDisk;
|
||
// Исключаем из общего количества элементов архива количество исключений
|
||
eo64cd.TotalNumberOfEntries {%H-}:= Count - FExceptionCount;
|
||
|
||
// формат ZIP64 используется в случае если количество элементов
|
||
// архива превышает MAXWORD, или смещение на начало центральной директории
|
||
// превышает MAXDWORD или ее размер превышает MAXDWORD
|
||
if (FcdfhOffset > MAXDWORD) or (FSizeOfCentralDir > MAXDWORD) or
|
||
(eo64cd.TotalNumberOfEntriesOnThisDisk > MAXWORD) or
|
||
(eo64cd.TotalNumberOfEntries > MAXWORD) or (DiskNumber > MAXWORD) or
|
||
(FcdfhDiskNumber > MAXWORD) then
|
||
begin
|
||
// В случае использования формата ZIP64
|
||
// необходимо записать дополнительные структуры
|
||
|
||
// TZip64EOFCentralDirectoryRecord
|
||
eo64cd.Zip64EndOfCentralDirSignature := ZIP64_END_OF_CENTRAL_DIR_SIGNATURE;
|
||
|
||
|
||
// Rouse_ 20.07.2013
|
||
// в спецификации 6.3.0 от September 29, 2006 оговорено
|
||
{
|
||
The value stored into the "size of zip64 end of central
|
||
directory record" should be the size of the remaining
|
||
record and should not include the leading 12 bytes.
|
||
|
||
Size = SizeOfFixedFields + SizeOfVariableData - 12.
|
||
}
|
||
// FWZip разрабатывался на основе более ранних спецификаций
|
||
// (изначально на 6.0 потом на 6.2) и не учитывал этот момент
|
||
|
||
// Поэтому вместо
|
||
// oe64cd.SizeOfZip64EOFCentralDirectoryRecord :=
|
||
// SizeOf(TZip64EOFCentralDirectoryRecord);
|
||
// пишем:
|
||
|
||
eo64cd.SizeOfZip64EOFCentralDirectoryRecord :=
|
||
SizeOf(TZip64EOFCentralDirectoryRecord) - 12;
|
||
|
||
|
||
eo64cd.VersionMadeBy := CurrentVersionMadeBy;
|
||
eo64cd.VersionNeededToExtract := FVersionToExtract;
|
||
eo64cd.NumberOfThisDisk := DiskNumber;
|
||
eo64cd.DiskNumberStart := FcdfhDiskNumber;
|
||
eo64cd.SizeOfTheCentralDirectory := FSizeOfCentralDir;
|
||
eo64cd.RelativeOffsetOfCentralDirectory := FcdfhOffset;
|
||
Stream.WriteBuffer(eo64cd, SizeOf(TZip64EOFCentralDirectoryRecord));
|
||
|
||
// TZip64EOFCentralDirectoryLocator
|
||
locator.Signature := ZIP64_END_OF_CENTRAL_DIR_LOCATOR_SIGNATURE;
|
||
locator.DiskNumberStart := DiskNumber;
|
||
locator.RelativeOffset := eo64cdOffset;
|
||
Stream.WriteBuffer(locator, SizeOf(TZip64EOFCentralDirectoryLocator));
|
||
|
||
end;
|
||
eocd.EndOfCentralDirSignature := END_OF_CENTRAL_DIR_SIGNATURE;
|
||
if DiskNumber > MAXWORD then
|
||
eocd.NumberOfThisDisk := MAXWORD
|
||
else
|
||
eocd.NumberOfThisDisk := DiskNumber;
|
||
if FcdfhDiskNumber > MAXWORD then
|
||
eocd.DiskNumberStart := MAXWORD
|
||
else
|
||
eocd.DiskNumberStart := FcdfhDiskNumber;
|
||
if eo64cd.TotalNumberOfEntriesOnThisDisk > MAXWORD then
|
||
eocd.TotalNumberOfEntriesOnThisDisk := MAXWORD
|
||
else
|
||
eocd.TotalNumberOfEntriesOnThisDisk := eo64cd.TotalNumberOfEntriesOnThisDisk;
|
||
if eo64cd.TotalNumberOfEntries > MAXWORD then
|
||
eocd.TotalNumberOfEntries := MAXWORD
|
||
else
|
||
eocd.TotalNumberOfEntries := eo64cd.TotalNumberOfEntries;
|
||
if FSizeOfCentralDir > MAXDWORD then
|
||
eocd.SizeOfTheCentralDirectory := MAXDWORD
|
||
else
|
||
eocd.SizeOfTheCentralDirectory := FSizeOfCentralDir;
|
||
if FcdfhOffset > MAXDWORD then
|
||
eocd.RelativeOffsetOfCentralDirectory := MAXDWORD
|
||
else
|
||
eocd.RelativeOffsetOfCentralDirectory := FcdfhOffset;
|
||
Stream.WriteBuffer(eocd, SizeOf(TEndOfCentralDir));
|
||
if eocd.ZipfileCommentLength > 0 then
|
||
// Rouse_ 26.06.2023
|
||
// В спецификации вообще ничего не сказано про формат коментария
|
||
// и нет поля где хранился бы флаг кодировки общего коментария к архиву
|
||
// поэтому коментарий должен сохраняться ТОЛЬКО как Ansi строка
|
||
SaveString(Stream, FComment, False);
|
||
end;
|
||
|
||
//
|
||
// Процедура проводит все процедуры подготовки, сжатия и сохранения указанного элемента архива
|
||
// =============================================================================
|
||
procedure TFWZipWriter.SaveItemToStream(Stream: TStream; Index: Integer);
|
||
var
|
||
CurrentItem: TFWZipWriterItem;
|
||
FileNameOffset, StreamSizeBeforeCompress, RealtiveOffset: Int64;
|
||
DiskNumber: Integer;
|
||
begin
|
||
CurrentItem := Item[Index];
|
||
|
||
// проверка на дуракоустойчивость
|
||
if not CurrentItem.UseExternalData then
|
||
if (CurrentItem.FilePath = '') and (CurrentItem.Data = nil) then
|
||
raise EZipWriter.CreateFmt('Данные элемента №%d "%s" отсутствуют',
|
||
[Index, CurrentItem.FileName]);
|
||
|
||
FProcessedItemIndex := Index;
|
||
|
||
// Rouse_ 25.10.2013
|
||
// Генерируем событие начала распаковки перед тем как результирующий файл будет залочен
|
||
DoProgress(psStart);
|
||
try
|
||
|
||
// Заполняем информацию в CentralDirectory
|
||
// ===========================================================================
|
||
FillItemCDFHeader(CurrentItem, FCD[Index]);
|
||
|
||
if IsMultiPartZip(Stream) then
|
||
begin
|
||
TFWAbstractMultiStream(Stream).GetRelativeInfo(DiskNumber, RealtiveOffset);
|
||
FCD[Index].DiskNumberStart := DiskNumber;
|
||
FCD[Index].RelativeOffsetOfLocalHeader := RealtiveOffset;
|
||
end
|
||
else
|
||
begin
|
||
FCD[Index].DiskNumberStart := 0;
|
||
FCD[Index].RelativeOffsetOfLocalHeader := Stream.Position;
|
||
end;
|
||
|
||
// Помещаем данные в результирующий файл
|
||
// ===========================================================================
|
||
|
||
// Запоминаем оффсет по которому необходимо будет писать имя файла
|
||
FileNameOffset := Stream.Position + SizeOf(TLocalFileHeader);
|
||
|
||
// рассчитываем размер резервируемого места под
|
||
// LocalFileHeader и имя файла
|
||
StreamSizeBeforeCompress := FileNameOffset +
|
||
FCD[Index].Header.FilenameLength;
|
||
|
||
// резервируем место под ZIP64
|
||
if FCD[Index].UncompressedSize >= MAXDWORD then
|
||
Inc(StreamSizeBeforeCompress, SizeOf(TExDataInfo64));
|
||
|
||
// выделяем блок данных под LocalFileHeader и имя файла
|
||
Stream.Size := StreamSizeBeforeCompress;
|
||
Stream.Position := Stream.Size;
|
||
|
||
// сжимаем данные
|
||
if not CurrentItem.IsFolder then
|
||
CompressItem(CurrentItem, Index, StreamSizeBeforeCompress, Stream);
|
||
|
||
Inc(FTotalProcessedCount, CurrentItem.Size);
|
||
|
||
// пишем имя файла
|
||
Stream.Position := FileNameOffset;
|
||
SaveString(Stream, FCD[Index].Filename, CurrentItem.UseUTF8String);
|
||
|
||
// резервируем место под дескриптор
|
||
if CurrentItem.NeedDescriptor then
|
||
Stream.Size := Stream.Size + SizeOf(TDataDescriptor);
|
||
|
||
Stream.Position := Stream.Size;
|
||
|
||
finally
|
||
// Rouse_ 25.10.2013
|
||
// Результирующий файл освобожден, генерируем событие
|
||
DoProgress(psEnd);
|
||
end;
|
||
end;
|
||
|
||
//
|
||
// Процедура проводит преобразование переданной строки в OEM и ее сохранение
|
||
// =============================================================================
|
||
procedure TFWZipWriter.SaveString(Stream: TStream; const Value: string;
|
||
AUseUTF8String: Boolean);
|
||
var
|
||
OemString: AnsiString;
|
||
begin
|
||
if Value <> '' then
|
||
begin
|
||
if AUseUTF8String then
|
||
OemString := UTF8Encode(Value)
|
||
else
|
||
OemString := ConvertToOemString(AnsiString(Value));
|
||
// длина строки после конвертации будет правильной, т.е. для
|
||
// 'Мой тестовый комментарий' у UTF8 будет равна 46 и 24 в противном случае
|
||
Stream.WriteBuffer(OemString[1], Length(OemString));
|
||
end;
|
||
end;
|
||
|
||
//
|
||
// Процедура обновляет секции LocalFileHeader
|
||
// =============================================================================
|
||
procedure TFWZipWriter.UpdateLocalHeaders(Stream: TStream);
|
||
var
|
||
I: Integer;
|
||
lfh: TLocalFileHeader;
|
||
dd: TDataDescriptor;
|
||
UseDescriptor: Boolean;
|
||
{%H-}Info64: TExDataInfo64;
|
||
begin
|
||
FcdfhOffset := Stream.Position;
|
||
for I := 0 to Count - 1 do
|
||
begin
|
||
|
||
// пропускаем элементы при записи которых произошло исключение
|
||
if FCD[I].ExceptOnWrite then Continue;
|
||
|
||
// Имея на руках все данные перезаписываем все LocalFileHeader
|
||
// и DataDescriptor (если требуется)
|
||
lfh.LocalFileHeaderSignature := LOCAL_FILE_HEADER_SIGNATURE;
|
||
|
||
// рассчитываем версию необходимую для распаковки элемента архива
|
||
lfh.VersionNeededToExtract := GetVersionToExtract(I);
|
||
lfh.GeneralPurposeBitFlag := FCD[I].Header.GeneralPurposeBitFlag;
|
||
UseDescriptor := lfh.GeneralPurposeBitFlag and PBF_DESCRIPTOR <> 0;
|
||
lfh.CompressionMethod := FCD[I].Header.CompressionMethod;
|
||
lfh.LastModFileTimeTime := FCD[I].Header.LastModFileTimeTime;
|
||
lfh.LastModFileTimeDate := FCD[I].Header.LastModFileTimeDate;
|
||
if UseDescriptor then
|
||
begin
|
||
dd.DescriptorSignature := DATA_DESCRIPTOR_SIGNATURE;
|
||
// хоть в стандарте сказано что при использовании дескрипторов
|
||
// поля Crc32, CompressedSize и UncompressedSize должны быль установлены
|
||
// в ноль, но большинство архиваторов этого не делают,
|
||
// поэтому уподобимся им :)
|
||
lfh.Crc32 := FCD[I].Header.Crc32;
|
||
dd.Crc32 := lfh.Crc32;
|
||
if FCD[I].CompressedSize > MAXDWORD then
|
||
dd.CompressedSize := MAXDWORD
|
||
else
|
||
dd.CompressedSize := FCD[I].CompressedSize;
|
||
lfh.CompressedSize := dd.CompressedSize;
|
||
if FCD[I].UncompressedSize > MAXDWORD then
|
||
dd.UncompressedSize := MAXDWORD
|
||
else
|
||
dd.UncompressedSize := FCD[I].UncompressedSize;
|
||
lfh.UncompressedSize := dd.UncompressedSize;
|
||
end
|
||
else
|
||
begin
|
||
lfh.Crc32 := FCD[I].Header.Crc32;
|
||
if FCD[I].CompressedSize > MAXDWORD then
|
||
lfh.CompressedSize := MAXDWORD
|
||
else
|
||
lfh.CompressedSize := FCD[I].CompressedSize;
|
||
if FCD[I].UncompressedSize > MAXDWORD then
|
||
lfh.UncompressedSize := MAXDWORD
|
||
else
|
||
lfh.UncompressedSize := FCD[I].UncompressedSize;
|
||
end;
|
||
lfh.FilenameLength := FCD[I].Header.FilenameLength;
|
||
|
||
if (FCD[I].UncompressedSize >= MAXDWORD) or
|
||
(FCD[I].CompressedSize >= MAXDWORD) then
|
||
lfh.ExtraFieldLength := SizeOf(TExDataInfo64)
|
||
else
|
||
lfh.ExtraFieldLength := 0;
|
||
|
||
if IsMultiPartZip(Stream) then
|
||
TFWAbstractMultiStream(Stream).Seek(
|
||
FCD[I].DiskNumberStart, FCD[I].RelativeOffsetOfLocalHeader)
|
||
else
|
||
Stream.Position := FCD[I].RelativeOffsetOfLocalHeader;
|
||
|
||
Stream.WriteBuffer(lfh, SizeOf(TLocalFileHeader));
|
||
|
||
// Rouse_ 20.03.2015
|
||
// Пишем данные для поддержки ZIP64
|
||
// а то WinRar, WinZip и 7Zip не будут распаковывать такой архив
|
||
// (не понятно правда, почему они не читают эту информацию из CentralDirectory)
|
||
if lfh.ExtraFieldLength > 0 then
|
||
begin
|
||
Stream.Position := Stream.Position + lfh.FilenameLength;
|
||
Info64.HS.Header := SUPPORTED_EXDATA_ZIP64;
|
||
Info64.HS.Size := SizeOf(TExDataInfo64) - SizeOf(TExDataHeaderAndSize);
|
||
Info64.UncompressedSize := FCD[I].UncompressedSize;
|
||
// если CompressedSize меньше MAXDWORD его писать не надо по стандарту,
|
||
// но место под него уже зарезервированно, поэтому придется писать его в любом случае
|
||
// как обойти это расхождение со стандартом хорошим способом - я пока не знаю
|
||
Info64.CompressedSize := FCD[I].CompressedSize;
|
||
Stream.WriteBuffer(Info64, SizeOf(TExDataInfo64));
|
||
end;
|
||
|
||
if UseDescriptor then
|
||
begin
|
||
// дескриптор пишется после сжатого блока данных
|
||
if IsMultiPartZip(Stream) then
|
||
begin
|
||
TFWAbstractMultiStream(Stream).Seek(
|
||
FCD[I].DiskNumberStart, FCD[I].RelativeOffsetOfLocalHeader);
|
||
Stream.Seek(SizeOf(TLocalFileHeader) + lfh.FilenameLength +
|
||
lfh.ExtraFieldLength {%H-}+ FCD[I].CompressedSize, soCurrent);
|
||
end
|
||
else
|
||
Stream.Position := FCD[I].RelativeOffsetOfLocalHeader +
|
||
SizeOf(TLocalFileHeader) + lfh.FilenameLength +
|
||
lfh.ExtraFieldLength + FCD[I].CompressedSize;
|
||
Stream.WriteBuffer(dd, SizeOf(TDataDescriptor));
|
||
end;
|
||
|
||
// обновляем информацию в массиве CentralDirectoryFileHeader
|
||
|
||
// Rouse_ 14.02.2013
|
||
// Неверно выставлялась версия для распаковки в CentralDirectoryFileHeader
|
||
//FCD[I].Header.VersionNeededToExtract := FVersionToExtract;
|
||
FCD[I].Header.VersionNeededToExtract := lfh.VersionNeededToExtract;
|
||
|
||
if UseDescriptor then
|
||
FCD[I].Header.CompressedSize := dd.CompressedSize
|
||
else
|
||
FCD[I].Header.CompressedSize := lfh.CompressedSize;
|
||
if UseDescriptor then
|
||
FCD[I].Header.UncompressedSize := dd.UncompressedSize
|
||
else
|
||
FCD[I].Header.UncompressedSize := lfh.UncompressedSize;
|
||
if FCD[I].RelativeOffsetOfLocalHeader > MAXDWORD then
|
||
FCD[I].Header.RelativeOffsetOfLocalHeader := MAXDWORD
|
||
else
|
||
FCD[I].Header.RelativeOffsetOfLocalHeader :=
|
||
FCD[I].RelativeOffsetOfLocalHeader;
|
||
if FCD[I].DiskNumberStart > MAXWORD then
|
||
FCD[I].Header.DiskNumberStart := MAXWORD
|
||
else
|
||
FCD[I].Header.DiskNumberStart := FCD[I].DiskNumberStart;
|
||
|
||
// Rouse_ 14.02.2013
|
||
// обновляем глобальную метку версии
|
||
if FVersionToExtract < lfh.VersionNeededToExtract then
|
||
FVersionToExtract := lfh.VersionNeededToExtract;
|
||
end;
|
||
Stream.Position := FcdfhOffset;
|
||
end;
|
||
|
||
end.
|