unit XE_ZipFile;
interface
uses
SysUtils,
IOUtils,
Generics.Collections,
Classes;
type
/// <summary> Zip Compression Method Enumeration </summary>
TZipCompression = (
zcStored = 0,
zcShrunk,
zcReduce1,
zcReduce2,
zcReduce3,
zcReduce4,
zcImplode,
zcTokenize,
zcDeflate,
zcDeflate64,
zcPKImplode,
{11 RESERVED}
zcBZIP2 = 12,
{13 RESERVED}
zcLZMA = 14,
{15-17 RESERVED}
zcTERSE = 18,
zcLZ77,
zcWavePack = 97,
zcPPMdI1
);
/// <summary> Converts ZIP compression method value to string </summary>
function TZipCompressionToString(Compression: TZipCompression): string;
const
SIGNATURE_ZIPENDOFHEADER: UInt32 = $06054B50;
SIGNATURE_CENTRALHEADER: UInt32 = $02014B50;
SIGNATURE_LOCALHEADER: UInt32 = $04034B50;
LOCALHEADERSIZE = 26;
CENTRALHEADERSIZE = 42;
type
/// <summary> Final block written to zip file</summary>
TZipEndOfCentralHeader = packed record
DiskNumber: UInt16;
CentralDirStartDisk: UInt16;
NumEntriesThisDisk: UInt16;
CentralDirEntries: UInt16;
CentralDirSize: UInt32;
CentralDirOffset: UInt32;
CommentLength: UInt16;
{Comment: RawByteString}
end;
/// <summary> TZipHeader contains information about a file in a zip archive.
/// </summary>
/// <remarks>
/// <para>
/// This record is overloaded for use in reading/writing ZIP
/// [Local file header] and the Central Directory's [file header].
/// </para>
/// <para> See PKZIP Application Note section V. General Format of a .ZIP file
/// sub section J. Explanation of fields for more detailed description
// of each field's usage.
/// </para>
/// </remarks>
TZipHeader = packed record
MadeByVersion: UInt16; // Start of Central Header
RequiredVersion: UInt16; // Start of Local Header
Flag: UInt16;
CompressionMethod: UInt16;
ModifiedDateTime: UInt32;
CRC32: UInt32;
CompressedSize: UInt32;
UncompressedSize: UInt32;
FileNameLength: UInt16;
ExtraFieldLength: UInt16; // End of Local Header
FileCommentLength: UInt16;
DiskNumberStart: UInt16;
InternalAttributes: UInt16;
ExternalAttributes: UInt32;
LocalHeaderOffset: UInt32; // End of Central Header
FileName: RawByteString;
ExtraField: TBytes;
FileComment: RawByteString;
end;
PZipHeader = ^TZipHeader;
/// <summary> Exception type for all Zip errors. </summary>
EZipException = class( Exception );
TZipMode = (zmClosed, zmRead, zmReadWrite, zmWrite);
TZipFile = class;
/// <summary> Function to Create a Compression/Decompression stream </summary>
/// <remarks>
/// Call <c>RegisterCompressionHandler</c> to register a compression type that
/// can Compress/Decompress a stream. The output stream reads/write from/to InStream.
/// </remarks>
TStreamConstructor = reference to function(InStream: TStream; const ZipFile: TZipFile; const Item: TZipHeader): TStream;
/// <summary> Class for creating and reading .ZIP files.
/// </summary>
TZipFile = class
private type
TCompressionDict = TDictionary< TZipCompression , TPair<TStreamConstructor, TStreamConstructor > >;
private class var
FCompressionHandler: TCompressionDict;
private
FMode: TZipMode;
FStream: TStream;
FFileStream: TFileStream;
FStartFileData: Int64;
FEndFileData: Int64;
FFiles: TList<TZipHeader>;
FComment: String;
FUTF8Support: Boolean;
function GetFileComment(Index: Integer): string;
function GetFileCount: Integer;
function GetFileInfo(Index: Integer): TZipHeader;
function GetFileInfos: TArray<TZipHeader>;
function GetFileName(Index: Integer): string;
function GetFileNames: TArray<string>;
procedure ReadCentralHeader;
procedure SetFileComment(Index: Integer; Value: string);
procedure SetUTF8Support(const Value: Boolean);
function LocateEndOfCentralHeader(var Header: TZipEndOfCentralHeader): Boolean;
public
class constructor Create;
class destructor Destroy;
/// <remarks>
/// Call <c>RegisterCompressionHandler</c> to register a compression type that
/// can Compress/Decompress a stream. The output stream reads/write from/to InStream.
/// </remarks>
class procedure RegisterCompressionHandler(Compression: TZipCompression;
CompressStream, DecompressStream: TStreamConstructor);
/// <param name="ZipFileName">Path to Zip File</param>
/// <returns>Is the .ZIP file valid</returns>
class function IsValid(ZipFileName: string): Boolean; static;
/// <summary> Extract a ZipFile</summary>
/// <param name="ZipFileName">File name of the ZIP file</param>
/// <param name="Path">Path to extract to disk</param>
class procedure ExtractZipFile(ZipFileName: string; Path: string); static;
/// <summary> Zip the contents of a directory </summary>
/// <param name="ZipFileName">File name of the ZIP file</param>
/// <param name="Path">Path of directory to zip</param>
/// <param name="Compression">Compression mode.</param>
class procedure ZipDirectoryContents(ZipFileName: string; Path: string;
Compression: TZipCompression = zcDeflate); static;
/// <summary> Create a TZipFile</summary>
constructor Create;
/// <remarks> Destroy will close an open zipfile before disposing of it</remarks>
destructor Destroy; override;
/// <summary> Opens a ZIP file for reading or writing.</summary>
/// <param name="ZipFileName">Path to ZipFile</param>
/// <param name="OpenMode"> File Mode to open file.
/// <c>zmWrite</c> Creates a new ZIP file for writing.
/// <c>zmReadWrite</c> Opens the file for reading and allows adding
/// additional new files.
/// <c>zmRead</c> Opens the file for reading.
///</param>
procedure Open(ZipFileName: string; OpenMode: TZipMode); overload;
procedure Open(ZipFileStream: TStream; OpenMode: TZipMode); overload;
/// <remarks>
/// Closing is required to write the ZipFile's
/// Central Directory to disk. Closing a file that is open for writing
/// writes additonal metadata that is required for reading the file.
/// </remarks>
procedure Close;
/// <summary> Extract a single file </summary>
/// <remarks>
/// <c>FileName</c> specifies a file in the ZIP file. All slashes
/// in ZIP file names should be '/'.
/// The overload that takes an Integer may be useful when a ZIP file
/// has duplicate filenames.
/// </remarks>
/// <param name="FileName">File name in the archive</param>
/// <param name="Path">Path to extract to disk</param>
/// <param name="CreateSubdirs">The output should create sub directories specified in the ZIP file</param>
procedure Extract(FileName: string; Path: string = ''; CreateSubdirs: Boolean=True); overload;
procedure Extract(Index: Integer; Path: string = ''; CreateSubdirs: Boolean=True); overload;
/// <summary> Extract All files </summary>
/// <param name="Path">Path to extract to.</param>
procedure ExtractAll(Path: string = '');
/// <summary> Read a file from arcive to an array of Bytes </summary>
/// <remarks>
/// The overload that takes an Integer may be useful when a ZIP file
/// has duplicate filenames.
/// </remarks>
/// <param name="FileName">ZIP file FileName</param>
/// <param name="Bytes">Output bytes</param>
procedure Read(FileName: string; out Bytes: TBytes); overload;
procedure Read(Index: Integer; out Bytes: TBytes); overload;
/// <summary> Get a stream to read a file from disk </summary>
/// <remarks>
/// The Stream returned by this function is a decomression stream
/// wrapper around the interal Stream reading the zip file. You must
/// Free this stream before using other TZipFile methods that change the
/// contents of the ZipFile, such as Read or Add.
/// The overload that takes an Integer may be useful when a ZIP file
/// has duplicate filenames.
/// </remarks>
/// <param name="FileName">ZIP file FileName</param>
/// <param name="Stream">Output Stream</param>
/// <param name="LocalHeader">Local File header</param>
procedure Read(FileName: string; out Stream: TStream; out LocalHeader: TZipHeader); overload;
procedure Read(Index: Integer; out Stream: TStream; out LocalHeader: TZipHeader); overload;
/// <summary> Add a file to the ZIP file </summary>
/// <param name="FileName">FileName to be added</param>
/// <param name="ArchiveFileName">Path + Name of file in the arcive.
/// If Ommitted, <C>ExtractFileName(FileName)</C> will be used.</param>
/// <param name="Compression">Compression mode.</param>
procedure Add(FileName: string; ArchiveFileName: string = '';
Compression: TZipCompression = zcDeflate); overload;
/// <summary> Add a memory file to the ZIP file </summary>
/// <param name="Data">Bytes to be added</param>
/// <param name="ArchiveFileName">Path + Name of file in the arcive.</param>
/// <param name="Compression">Compression mode.</param>
procedure Add(Data: TBytes; ArchiveFileName: string;
Compression: TZipCompression = zcDeflate); overload;
/// <summary> Add a memory file to the ZIP file </summary>
/// <param name="Data">Stream of file to be added</param>
/// <param name="ArchiveFileName">Path + Name of file in the arcive.</param>
/// <param name="Compression">Compression mode.</param>
procedure Add(Data: TStream; ArchiveFileName: string;
Compression: TZipCompression = zcDeflate); overload;
/// <summary> Add a memory file to the ZIP file. Allows programmer to specify
/// the Local and Central Header data for more flexibility on what gets written.
/// Minimal vailidation is done on the Header parameters; speficying bad options
/// could result in a corrupted zip file. </summary>
/// <param name="Data">Stream of file to be added</param>
/// <param name="LocalHeader">The local header data</param>
/// <param name="CentralHeader">A Pointer to an optional central header. If no
/// central Header is provided, the Local Header information is used. </param>
procedure Add(Data: TStream; LocalHeader: TZipHeader;
CentralHeader: PZipHeader = nil); overload;
/// <summary> Translate from FileName to index in ZIP Central Header
/// </summary>
/// <remarks>
/// A ZIP file may have dupicate entries with the same name. This
/// function will return the index of the first.
/// </remarks>
/// <param name="FileName">Path + Name of file in the arcive.</param>
/// <returns>The index of the file in the archive, or -1 on failure.
/// </returns>
function IndexOf(FileName: string): Integer;
/// <returns> The mode the TZipFile is opened to</returns>
property Mode: TZipMode read FMode;
/// <returns>Total files in ZIP File</returns>
property FileCount: Integer read GetFileCount;
/// <returns>An array of FileNames in the ZIP file</returns>
property FileNames: TArray<string> read GetFileNames;
/// <returns>An array of the TZipHeader of the files in the ZIP file</returns>
property FileInfos: TArray<TZipHeader> read GetFileInfos;
/// <returns>FileName of a File in the ZipFile</returns>
property FileName[Index: Integer]: string read GetFileName;
/// <returns>TZipHeader of a File in the ZipFile</returns>
property FileInfo[Index: Integer]: TZipHeader read GetFileInfo;
/// <remarks>
/// File Comments can be changed for files opened in write mode at any point.
/// The comment is written when the Central Directory is written to disk.
/// Comments can be a maximum of 65535 bytes long. If a longer comment is supplied,
/// It is truncated before writing to the ZIP File.
/// </remarks>
property FileComment[Index: Integer]: string read GetFileComment write SetFileComment;
/// <remarks>
/// Comments can be a maximum of 65535 bytes long. If a longer comment is supplied,
/// It is truncated before writing to the ZIP File.
/// </remarks>
property Comment: string read FComment write FComment;
property UTF8Support: Boolean read FUTF8Support write SetUTF8Support default True;
end;
resourcestring
{ Zip Strings}
SZipErrorRead = 'Error reading zip file';
SZipErrorWrite = 'Error writing zip file';
SZipInvalidLocalHeader = 'Invalid Zip Local Header signature';
SZipInvalidCentralHeader = 'Invalid Zip Central Header signature';
SZipNotSupported = 'Support for compression method not registered: %s';
SZipNotOpen = 'File must be open';
SZipNoWrite = 'File must be open for writing';
SZipNoRead = 'File must be open for reading';
SZipNotEmpty = 'Zip file must be empty';
sArgumentInvalid = 'Invalid argument';
SReadError = 'Stream read error';
SFileNotFound = 'The specified file was not found';
implementation
uses ZLib,CRC;
type
TOem437String = type AnsiString(437);
procedure VerifyRead(Stream: TStream; var Buffer; Count: Integer);
begin
if Stream.Read(Buffer, Count) <> Count then
raise EZipException.CreateRes(@SZipErrorRead);// at ReturnAddress;
end;
procedure VerifyWrite(Stream: TStream; var Buffer; Count: Integer);
begin
if Stream.Write(Buffer, Count) <> Count then
raise EZipException.CreateRes(@SZipErrorWrite);// at ReturnAddress;
end;
type
/// <summary> Helper class for reading a segment of another stream.</summary>
TStoredStream = class( TStream )
private
FStream: TStream;
FPos: Int64;
protected
function GetSize: Int64; override;
public
constructor Create( Stream: TStream );
function Read(var Buffer; Count: Longint): Longint; override;
function Write(const Buffer; Count: Longint): Longint; override;
function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
end;
{ TStoredStream }
constructor TStoredStream.Create(Stream: TStream);
begin
FStream := Stream;
FPos := FStream.Position;
end;
function TStoredStream.GetSize: Int64;
begin
Result := FStream.Size;
end;
function TStoredStream.Read(var Buffer; Count: Integer): Longint;
begin
Result := FStream.Read(Buffer, Count);
end;
function TStoredStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
Result := FStream.Seek(Offset, Origin)
end;
function TStoredStream.Write(const Buffer; Count: Integer): Longint;
begin
Result := FStream.Write(Buffer, Count);
end;
function TZipCompressionToString(Compression: TZipCompression): string;
begin
case Compression of
zcStored: Result := 'Stored'; // do not localize
zcShrunk: Result := 'Shrunk'; // do not localize
zcReduce1: Result := 'Reduced1'; // do not localize
zcReduce2: Result := 'Reduced2'; // do not localize
zcReduce3: Result := 'Reduced3'; // do not localize
zcReduce4: Result := 'Reduced4'; // do not localize
zcImplode: Result := 'Imploded'; // do not localize
zcTokenize: Result := 'Tokenized'; // do not localize
zcDeflate: Result := 'Deflated'; // do not localize
zcDeflate64: Result := 'Deflated64'; // do not localize
zcPKImplode: Result := 'Imploded(TERSE)'; // do not localize
zcBZIP2: Result := 'BZIP2'; // do not localize
zcLZMA: Result := 'LZMA'; // do not localize
zcTERSE: Result := 'TERSE'; // do not localize
zcLZ77: Result := 'LZ77'; // do not localize
zcWavePack: Result := 'WavPack'; // do not localize
zcPPMdI1: Result := 'PPMd version I, Rev 1'; // do not localize
else
Result := 'Unknown';
end;
end;
{ TZipFile }
function TZipFile.GetFileComment(Index: Integer): string;
begin
if FMode = zmClosed then
raise EZipException.CreateRes(@SZipNotOpen);
Result := string(FFiles[Index].FileComment);
end;
function TZipFile.GetFileCount: Integer;
begin
if FMode = zmClosed then
raise EZipException.CreateRes(@SZipNotOpen);
Result := FFiles.Count;
end;
function TZipFile.GetFileInfo(Index: Integer): TZipHeader;
begin
if FMode = zmClosed then
raise EZipException.CreateRes(@SZipNotOpen);
Result := FFiles[Index];
end;
function TZipFile.GetFileInfos: TArray<TZipHeader>;
begin
if FMode = zmClosed then
raise EZipException.CreateRes(@SZipNotOpen);
Result := FFiles.ToArray;
end;
function TZipFile.GetFileName(Index: Integer): string;
begin
if FMode = zmClosed then
raise EZipException.CreateRes(@SZipNotOpen);
Result := string(FFiles[Index].FileName);
end;
function TZipFile.GetFileNames: TArray<string>;
var
I: Integer;
begin
if FMode = zmClosed then
raise EZipException.CreateRes(@SZipNotOpen);
SetLength(Result, FFiles.Count);
for I := 0 to High(Result) do
Result[I] := string(FFiles[I].FileName);
end;
procedure TZipFile.ReadCentralHeader;
var
I: Integer;
Signature: UInt32;
LEndHeader: TZipEndOfCentralHeader;
LHeader: TZipHeader;
begin
FFiles.Clear;
if FStream.Size = 0 then
Exit;
// Read End Of Centeral Direcotry Header
if not LocateEndOfCentralHeader(LEndHeader) then
raise EZipException.CreateRes(@SZipErrorRead);
// Move to the beginning of the CentralDirectory
FStream.Position := LEndHeader.CentralDirOffset;
// Save Begginning of Central Directory. This is where new files
// get written to, and where the new central directory gets written when
// closing.
FEndFileData := LEndHeader.CentralDirOffset;
// Read File Headers
for I := 0 to LEndHeader.CentralDirEntries - 1 do
begin
// Verify Central Header signature
FStream.Read(Signature, Sizeof(Signature));
if Signature <> SIGNATURE_CENTRALHEADER then
raise EZipException.CreateRes(@SZipInvalidCentralHeader);
// Read Central Header
VerifyRead(FStream, LHeader.MadeByVersion, CENTRALHEADERSIZE);
// Read Dynamic length fields (FileName, ExtraField, FileComment)
if LHeader.FileNameLength > 0 then
begin
SetLength(LHeader.FileName, LHeader.FileNameLength);
if (LHeader.Flag and (1 SHL 11)) <> 0 then
SetCodepage(LHeader.FileName, 65001, False)
else
SetCodepage(LHeader.FileName, 437, False);
VerifyRead(FStream, LHeader.FileName[1], LHeader.FileNameLength);
end;
if LHeader.ExtraFieldLength > 0 then
begin
SetLength(LHeader.ExtraField, LHeader.ExtraFieldLength);
VerifyRead(FStream, LHeader.ExtraField[0], LHeader.ExtraFieldLength);
end;
if LHeader.FileCommentLength > 0 then
begin
SetLength(LHeader.FileComment, LHeader.FileCommentLength);
if (LHeader.Flag and (1 SHL 11)) <> 0 then
SetCodepage(LHeader.FileName, 65001, False)
else
SetCodepage(LHeader.FileName, 437, False);
VerifyRead(FStream, LHeader.FileComment[1], LHeader.FileCommentLength);
end;
if (LHeader.Flag and (1 shl 11)) = 0 then
FUTF8Support := False;
// Save File Header in interal list
FFiles.Add(LHeader);
end;
end;
procedure TZipFile.SetFileComment(Index: Integer; Value: string);
var
LFile: TZipHeader;
begin
if not (FMode in [zmReadWrite, zmWrite]) then
raise EZipException.CreateRes(@SZipNoWrite);
LFile := FFiles[Index];
if Length(Value) > $FFFF then
SetLength(Value, $FFFF);
if UTF8Support then
LFile.FileComment := UTF8Encode(Value)
else
LFile.FileComment := TOem437String(Value);
LFile.FileCommentLength := Length(LFile.FileComment);
FFiles[Index] := LFile;
end;
procedure TZipFile.SetUTF8Support(const Value: Boolean);
begin
if Value = FUTF8Support then Exit;
if not (FMode in [zmReadWrite, zmWrite]) then
raise EZipException.CreateRes(@SZipNoWrite);
// Resetting this flag would require re-writing all the local headers with the
// new strings and flag, and adjusting the offsets.
if FFiles.Count <> 0 then
raise EZipException.CreateRes(@SZipNotEmpty);
FUTF8Support := Value;
end;
class constructor TZipFile.Create;
begin
FCompressionHandler := TCompressionDict.Create;
RegisterCompressionHandler(zcStored,
function(InStream: TStream; const ZipFile: TZipFile; const Item: TZipHeader): TStream
begin
Result := TStoredStream.Create(InStream);
end,
function(InStream: TStream; const ZipFile: TZipFile; const Item: TZipHeader): TStream
begin
Result := TStoredStream.Create(InStream);
end);
RegisterCompressionHandler(zcDeflate,
function(InStream: TStream; const ZipFile: TZipFile; const Item: TZipHeader): TStream
begin
Result := TZCompressionStream.Create(InStream, zcDefault);
end,
function(InStream: TStream; const ZipFile: TZipFile; const Item: TZipHeader): TStream
begin
Result := TZDecompressionStream.Create(InStream);
end);
end;
class destructor TZipFile.Destroy;
begin
FCompressionHandler.Free;
end;
class procedure TZipFile.RegisterCompressionHandler(
Compression: TZipCompression; CompressStream, DecompressStream: TStreamConstructor);
begin
FCompressionHandler.AddOrSetValue(Compression,
TPair<TStreamConstructor, TStreamConstructor>.Create(CompressStream, DecompressStream));
end;
class function TZipFile.IsValid(ZipFileName: string): Boolean;
var
Z: TZipFile;
Header: TZipEndOfCentralHeader;
begin
Result := False;
try
Z := tzipfile.Create;
try
Z.FStream := TFileStream.Create(ZipFileName, fmOpenRead);
try
Result := Z.LocateEndOfCentralHeader(Header);
finally
Z.FStream.Free;
end;
finally
Z.Free;
end;
except on E: Exception do
// Swallow exceptions and return False
end;
end;
function TZipFile.LocateEndOfCentralHeader(var Header: TZipEndOfCentralHeader): Boolean;
var
I: Integer;
LBackRead, LReadSize, LMaxBack: UInt32;
LBackBuf: array[0..$404-1] of Byte;
begin
if FStream.Size < $FFFF then
LMaxBack := FStream.Size
else
LMaxBack := $FFFF;
LBackRead := 4;
while LBackRead < LMaxBack do
begin
if LBackRead + Cardinal(Length(LBackBuf) - 4) > LMaxBack then
LBackRead := LMaxBack
else
Inc(LBackRead, Length(LBackBuf) -4);
FStream.Position := FStream.Size - LBackRead;
if Length(LBackBuf) < (FStream.Size - FStream.Position) then
LReadSize := Length(LBackBuf)
else
LReadSize := FStream.Size - FStream.Position;
VerifyRead(FStream, LBackBuf[0], LReadSize);
for I := LReadSize - 4 downto 0 do
begin
if PCardinal(@LBackBuf[I])^ = SIGNATURE_ZIPENDOFHEADER then
begin
Move(LBackBuf[I+4], Header, SizeOf(Header));
if Header.CommentLength > 0 then
begin
FStream.Position := FStream.Size - LBackRead + I + 4 + SizeOf(Header);
SetLength(FComment, Header.CommentLength);
FStream.Read(FComment[1], Header.CommentLength);
end
else
FComment := '';
Exit(True);
end;
end;
end;
Result := False;
end;
class procedure TZipFile.ExtractZipFile(ZipFileName: string; Path: string);
var
LZip: TZipFile;
begin
LZip := TZipFile.Create;
try
LZip.Open(ZipFileName, zmRead);
LZip.ExtractAll(Path);
LZip.Close;
finally
LZip.Free;
end;
end;
class procedure TZipFile.ZipDirectoryContents(ZipFileName: string; Path: string;
Compression: TZipCompression);
var
LZipFile: TZipFile;
LFile: string;
LZFile: string;
begin
LZipFile := TZipFile.Create;
try
LZipFile.Open(ZipFileName, zmWrite);
// Ensure path ends with PathDelim so when we strip it we have a valid relative path
if Path[Length(Path)] <> PathDelim then
Path := Path + PathDelim;
for LFile in TDirectory.GetFiles(Path, '*', TSearchOption.soAllDirectories) do
begin
// Strip off root path
{$IFDEF MSWINDOWS}
LZFile := StringReplace(
Copy(LFile, Length(Path)+1, Length(LFile)), '\', '/', [rfReplaceAll]);
{$ELSE}
LZFile := Copy(LFile, Length(Path)+1, Length(LFile));
{$ENDIF MSWINDOWS}
LZipFile.Add(LFile, LZFile, Compression);
end;
finally
LZipFile.Free;
end;
end;
constructor TZipFile.Create;
begin
inherited Create;
FFiles := TList<TZipHeader>.Create;
FMode := zmClosed;
FUTF8Support := True;
end;
destructor TZipFile.Destroy;
begin
Close; // In case a file is open for writing currently
FFiles.Free;
inherited;
end;
procedure TZipFile.Open(ZipFileName: string; OpenMode: TZipMode);
var
LMode: LongInt;
LFileStream: TFileStream;
begin
Close; // In case the user had a file open
case OpenMode of
zmRead: LMode := fmOpenRead;
zmReadWrite: LMode := fmOpenReadWrite;
zmWrite: LMode := fmCreate;
else
raise EZipException.CreateRes(@sArgumentInvalid);
end;
LFileStream := TFileStream.Create(ZipFileName, LMode);
try
Open(LFileStream, OpenMode);
FFileStream := LFileStream;
except
FreeAndNil(LFileStream);
raise;
end;
end;
procedure TZipFile.Open(ZipFileStream: TStream; OpenMode: TZipMode);
begin
Close; // In case the user had a file open
if OpenMode = zmClosed then
raise EZipException.CreateRes(@sArgumentInvalid);
if (OpenMode = zmRead) and (ZipFileStream.Size = 0) then
raise EZipException.CreateRes(@SReadError);
FStream := ZipFileStream;
FStartFileData := FStream.Position;
if OpenMode in [zmRead, zmReadWrite] then
try
// Read the Central Header to verify it's a valid zipfile
ReadCentralHeader;
except
// If it's an invalid zipfile, cleanup
FStream := nil;
raise;
end;
FMode := OpenMode;
end;
procedure TZipFile.Close;
var
LHeader: TZipHeader;
LEndOfHeader: TZipEndOfCentralHeader;
I: Integer;
Signature: UInt32;
begin
try
// Only need to write Central Directory and End Of Central Directory if writing
if (FMode = zmReadWrite) or (FMode = zmWrite) then
begin
FStream.Position := FEndFileData;
Signature := SIGNATURE_CENTRALHEADER;
// Write File Signatures
for I := 0 to FFiles.Count - 1 do
begin
LHeader := FFiles[I];
VerifyWrite(FStream, Signature, SizeOf(Signature));
VerifyWrite(FStream, LHeader.MadeByVersion, CENTRALHEADERSIZE);
if LHeader.FileNameLength <> 0 then
VerifyWrite(FStream, LHeader.FileName[1], LHeader.FileNameLength);
if LHeader.ExtraFieldLength <> 0 then
VerifyWrite(FStream, LHeader.ExtraField[1], LHeader.ExtraFieldLength);
if LHeader.FileCommentLength <> 0 then
VerifyWrite(FStream, LHeader.FileComment[1], LHeader.FileCommentLength);
end;
// Only support writing single disk .ZIP files
FillChar(LEndOfHeader, Sizeof(LEndOfHeader), 0);
LEndOfHeader.CentralDirEntries := FFiles.Count;
LEndOfHeader.NumEntriesThisDisk := FFiles.Count;
LEndOfHeader.CentralDirSize := FStream.Position - FEndFileData;
LEndOfHeader.CentralDirOffset := FEndFileData;
// Truncate comment if it's too long
if Length(FComment) > $FFFF then
SetLength(FComment, $FFFF);
LEndofHeader.CommentLength := Length(FComment);
// Write End Of Centeral Directory
Signature := SIGNATURE_ZIPENDOFHEADER;
VerifyWrite(FStream, Signature, SizeOf(Signature));
VerifyWrite(FStream, LEndOfHeader, SizeOf(LEndOfHeader));
if LEndOfHeader.CommentLength > 0 then
VerifyWrite(FStream, FComment[1], LEndOfHeader.CommentLength);
end;
finally
FMode := zmClosed;
FFiles.Clear;
FStream := nil;
if Assigned(FFileStream) then
FreeAndNil(FFileStream);
end;
end;
procedure TZipFile.Extract(FileName: string; Path: string; CreateSubDirs: Boolean);
begin
Extract(IndexOf(FileName), Path, CreateSubdirs);
end;
procedure TZipFile.Extract(Index: Integer; Path: string; CreateSubdirs: Boolean);
var
LInStream, LOutStream: TStream;
LHeader: TZipHeader;
LDir, LFileName: string;
Bytes: array [0..4095] of Byte;
ReadBytes: Int64;
begin
// Get decompression stream for file
Read(Index, LInStream, LHeader);
try
LFileName := string(FFiles[Index].FileName);
{$IFDEF MSWINDOWS} // ZIP stores files with '/', so translate to a relative Windows path.
LFileName := StringReplace(LFileName, '/', '\', [rfReplaceAll]);
{$ENDIF}
// CreateSubDirs = False assumes the user passed in the path where they want the file to end up
if CreateSubdirs then
LFileName := TPath.Combine(Path, LFileName)
else
LFileName := TPath.Combine(Path, ExtractFileName(LFileName));
// Force directory creation
LDir := ExtractFileDir(LFileName);
if CreateSubdirs and (LDir <> '') then
TDirectory.CreateDirectory(ExtractFileDir(LFileName));
// Open the File For output
if LFileName[Length(LFileName)] = PathDelim then
Exit; // Central Directory Entry points at a directory, not a file.
LOutStream := TFileStream.Create(LFileName, fmCreate);
try // And Copy from the decompression stream.
if (LHeader.Flag and (1 SHL 3)) = 0 then
if FFiles[Index].UncompressedSize > 0 then // Special case for empty files.
LOutStream.CopyFrom(LInStream, FFiles[Index].UncompressedSize)
else
begin
//CRC, Uncompressed, and Compressed Size follow the compressed data.
while True do
begin
ReadBytes := LInStream.Read(Bytes, Length(Bytes));
LOutStream.Write(Bytes, ReadBytes);
if ReadBytes < Length(Bytes) then
break;
end;
end;
finally
LOutStream.Free;
end;
finally
LInStream.Free;
end;
end;
procedure TZipFile.ExtractAll(Path: string);
var
I: Integer;
begin
if not (FMode in [zmReadWrite, zmRead]) then
raise EZipException.CreateRes(@SZipNoRead);
for I := 0 to FFiles.Count - 1 do
Extract(I, Path);
end;
procedure TZipFile.Read(FileName: string; out Bytes: TBytes);
begin
Read(IndexOf(FileName), Bytes);
end;
procedure TZipFile.Read(Index: Integer; out Bytes: TBytes);
var
LStream: TStream;
LHeader: TZipHeader;
ReadStart, ReadBytes: Int64;
begin
Read(Index, LStream, LHeader);
try
if (LHeader.Flag and (1 SHL 3)) = 0 then
begin
SetLength(Bytes, FFiles[Index].UncompressedSize);
if FFiles[Index].UncompressedSize > 0 then // Special case for empty files.
VerifyRead(LStream, Bytes[0], LHeader.UncompressedSize);
end
else
begin
//CRC, Uncompressed, and Compressed Size follow the compressed data.
SetLength(Bytes, 4096);
ReadStart := 0;
ReadBytes := 0; // Supress warning
while True do
begin
ReadBytes := LStream.Read(Bytes[ReadStart], Length(Bytes)-ReadStart);
if ReadBytes < (Length(Bytes) - ReadStart) then
break;
ReadStart := ReadStart + ReadBytes;
SetLength(Bytes, Length(Bytes)*2);
end;
SetLength(Bytes, ReadStart + ReadBytes);
end;
finally
LStream.Free;
end;
end;
procedure TZipFile.Read(FileName: string; out Stream: TStream; out LocalHeader: TZipHeader);
begin
Read(IndexOf(FileName), Stream, LocalHeader);
end;
procedure TZipFile.Read(Index: Integer; out Stream: TStream; out LocalHeader: TZipHeader);
var
Signature: UInt32;
begin
if not (FMode in [zmReadWrite, zmRead]) then
raise EZipException.CreateRes(@SZipNoRead);
if (Index < 0) or (Index > FFiles.Count) then
raise EZipException.CreateRes(@SFileNotFound);
// Move to beginning of Local Header
FStream.Position := FFiles[Index].LocalHeaderOffset + FStartFileData;
// Verify local header signature
FStream.Read(Signature, Sizeof(Signature));
if Signature <> SIGNATURE_LOCALHEADER then
raise EZipException.CreateRes(@SZipInvalidLocalHeader);
// Read local header
FStream.Read(LocalHeader.RequiredVersion, LOCALHEADERSIZE);
// Read Name and extra fields
SetLength(LocalHeader.FileName, LocalHeader.FileNameLength);
SetLength(LocalHeader.ExtraField, LocalHeader.ExtraFieldLength);
if (LocalHeader.Flag and (1 SHL 11)) <> 0 then
SetCodepage(LocalHeader.FileName, 65001, False)
else
SetCodepage(LocalHeader.FileName, 437, False);
FStream.Read(LocalHeader.FileName[1], LocalHeader.FileNameLength);
if LocalHeader.ExtraFieldLength > 0 then
FStream.Read(LocalHeader.ExtraField[0], LocalHeader.ExtraFieldLength);
// Create Decompression stream.
Stream := FCompressionHandler[TZipCompression(FFiles[Index].CompressionMethod)].Value(FStream, Self, LocalHeader);
end;
procedure TZipFile.Add(Data: TStream; LocalHeader: TZipHeader; CentralHeader: PZipHeader);
var
DataStart: Int64;
LCompressStream: TStream;
Signature: UInt32;
LStartPos: Int64;
LBuffer: array[0..$4000] of Byte;
begin
// Seek to End of zipped data
FStream.Position := FEndFileData;
LocalHeader.LocalHeaderOffset := FEndFileData;
// Require at least version 2.0
if LocalHeader.MadeByVersion < 20 then
LocalHeader.MadeByVersion := 20;
if LocalHeader.RequiredVersion < 20 then
LocalHeader.RequiredVersion := 20;
if CentralHeader = nil then
CentralHeader := @LocalHeader;
// Write Signature, Header, and FileName
Signature := SIGNATURE_LOCALHEADER;
VerifyWrite(FStream, Signature, SizeOf(Signature));
VerifyWrite(FStream, LocalHeader.RequiredVersion, LOCALHEADERSIZE);
VerifyWrite(FStream, LocalHeader.FileName[1], LocalHeader.FileNameLength);
if LocalHeader.ExtraFieldLength > 0 then
VerifyWrite(FStream, LocalHeader.ExtraField[0], LocalHeader.ExtraFieldLength);
// Save position to calcuate Compressed Size
LStartPos := FStream.Position;
DataStart := Data.Position;
LocalHeader.UncompressedSize := Data.Size - DataStart;
// Write Compressed data
LCompressStream := FCompressionHandler[TZipCompression(LocalHeader.CompressionMethod)].Key(FStream, self, LocalHeader);
try
LCompressStream.CopyFrom(Data, LocalHeader.UncompressedSize);
finally
LCompressStream.Free;
end;
// Calcuate CompressedSize
LocalHeader.CompressedSize := FStream.Position - LStartPos;
Data.Position := DataStart;
// Calcuate Uncompressed data's CRC
while Data.Position < LocalHeader.UncompressedSize do
LocalHeader.CRC32 := crc32(LocalHeader.CRC32, LBuffer[0],Data.Read(LBuffer, SizeOf(LBuffer)));
CentralHeader.UnCompressedSize := LocalHeader.UnCompressedSize;
CentralHeader.CompressedSize := LocalHeader.CompressedSize;
CentralHeader.CRC32 := LocalHeader.CRC32;
// Save new End of zipped data mark
FEndFileData := FStream.Position;
// Move to beginning of Local Header offset and rewrite header
// with correct CompressedSize and CRC32
FStream.Position := LocalHeader.LocalHeaderOffset + SizeOf(UInt32);
FStream.Write(LocalHeader.RequiredVersion, LOCALHEADERSIZE);
FFiles.Add(CentralHeader^);
end;
procedure TZipFile.Add(FileName: string; ArchiveFileName: string;
Compression: TZipCompression);
var
LInStream: TStream;
LHeader: TZipHeader;
begin
if not (FMode in [zmReadWrite, zmWrite]) then
raise EZipException.CreateRes(@SZipNoWrite);
if not FCompressionHandler.ContainsKey(Compression) then
raise EZipException.CreateResFmt(@SZipNotSupported, [
TZipCompressionToString(Compression) ]);
// Setup Header
FillChar(LHeader, sizeof(LHeader), 0);
LHeader.Flag := 0;
LInStream := TFileStream.Create(FileName, fmOpenRead);
try
LHeader.Flag := 0;
LHeader.CompressionMethod := UInt16(Compression);
LHeader.ModifiedDateTime := DateTimeToFileDate( tfile.GetLastWriteTime(FileName) );
LHeader.UncompressedSize := LInStream.Size;
LHeader.InternalAttributes := 0;
LHeader.ExternalAttributes := 0;
if ArchiveFileName = '' then
ArchiveFileName := ExtractFileName(FileName);
if FUTF8Support then
begin
LHeader.Flag := LHeader.Flag or (1 SHL 11); // Language encoding flag, UTF8
LHeader.FileName := UTF8Encode(ArchiveFileName);
end
else
LHeader.FileName := TOem437String(ArchiveFileName);
LHeader.FileNameLength := Length(LHeader.FileName);
LHeader.ExtraFieldLength := 0;
Add(LInStream, LHeader);
finally
LInStream.Free;
end;
end;
procedure TZipFile.Add(Data: TBytes; ArchiveFileName: string;
Compression: TZipCompression);
var
LInStream: TStream;
begin
if not (FMode in [zmReadWrite, zmWrite]) then
raise EZipException.CreateRes(@SZipNoWrite);
if not FCompressionHandler.ContainsKey(Compression) then
raise EZipException.CreateResFmt(@SZipNotSupported, [
TZipCompressionToString(Compression) ]);
LInStream := TBytesStream.Create(Data);
try
Add(LInStream, ArchiveFileName, Compression);
finally
LInStream.Free;
end;
end;
procedure TZipFile.Add(Data: TStream; ArchiveFileName: string;
Compression: TZipCompression);
var
LHeader: TZipHeader;
begin
if not (FMode in [zmReadWrite, zmWrite]) then
raise EZipException.CreateRes(@SZipNoWrite);
if not FCompressionHandler.ContainsKey(Compression) then
raise EZipException.CreateResFmt(@SZipNotSupported, [
TZipCompressionToString(Compression) ]);
// Setup Header
FillChar(LHeader, sizeof(LHeader), 0);
LHeader.Flag := 0;
LHeader.CompressionMethod := UInt16(Compression);
LHeader.ModifiedDateTime := DateTimeToFileDate( Now );
LHeader.InternalAttributes := 0;
LHeader.ExternalAttributes := 0;
if FUTF8Support then
begin
LHeader.Flag := LHeader.Flag or (1 SHL 11); // Language encoding flag, UTF8
LHeader.FileName := UTF8Encode(ArchiveFileName);
end
else
LHeader.FileName := TOem437String(ArchiveFileName);
LHeader.FileNameLength := Length(LHeader.FileName);
LHeader.ExtraFieldLength := 0;
Add(Data, LHeader);
end;
function TZipFile.IndexOf(FileName: string): Integer;
var
I: Integer;
begin
Result := -1;
for I := 0 to FFiles.Count - 1 do
if string(FFiles[I].FileName) = FileName then
Exit(I);
end;
end.
unit ZipFile;
interface
uses
SysUtils,
IOUtils,
Generics.Collections,
Classes;
type
/// <summary> Zip Compression Method Enumeration </summary>
TZipCompression = (
zcStored = 0,
zcShrunk,
zcReduce1,
zcReduce2,
zcReduce3,
zcReduce4,
zcImplode,
zcTokenize,
zcDeflate,
zcDeflate64,
zcPKImplode,
{11 RESERVED}
zcBZIP2 = 12,
{13 RESERVED}
zcLZMA = 14,
{15-17 RESERVED}
zcTERSE = 18,
zcLZ77,
zcWavePack = 97,
zcPPMdI1
);
/// <summary> Converts ZIP compression method value to string </summary>
function TZipCompressionToString(Compression: TZipCompression): string;
const
SIGNATURE_ZIPENDOFHEADER: UInt32 = $06054B50;
SIGNATURE_CENTRALHEADER: UInt32 = $02014B50;
SIGNATURE_LOCALHEADER: UInt32 = $04034B50;
LOCALHEADERSIZE = 26;
CENTRALHEADERSIZE = 42;
type
/// <summary> Final block written to zip file</summary>
TZipEndOfCentralHeader = packed record
DiskNumber: UInt16;
CentralDirStartDisk: UInt16;
NumEntriesThisDisk: UInt16;
CentralDirEntries: UInt16;
CentralDirSize: UInt32;
CentralDirOffset: UInt32;
CommentLength: UInt16;
{Comment: RawByteString}
end;
/// <summary> TZipHeader contains information about a file in a zip archive.
/// </summary>
/// <remarks>
/// <para>
/// This record is overloaded for use in reading/writing ZIP
/// [Local file header] and the Central Directory's [file header].
/// </para>
/// <para> See PKZIP Application Note section V. General Format of a .ZIP file
/// sub section J. Explanation of fields for more detailed description
// of each field's usage.
/// </para>
/// </remarks>
TZipHeader = packed record
MadeByVersion: UInt16; // Start of Central Header
RequiredVersion: UInt16; // Start of Local Header
Flag: UInt16;
CompressionMethod: UInt16;
ModifiedDateTime: UInt32;
CRC32: UInt32;
CompressedSize: UInt32;
UncompressedSize: UInt32;
FileNameLength: UInt16;
ExtraFieldLength: UInt16; // End of Local Header
FileCommentLength: UInt16;
DiskNumberStart: UInt16;
InternalAttributes: UInt16;
ExternalAttributes: UInt32;
LocalHeaderOffset: UInt32; // End of Central Header
FileName: RawByteString;
ExtraField: TBytes;
FileComment: RawByteString;
end;
PZipHeader = ^TZipHeader;
/// <summary> Exception type for all Zip errors. </summary>
EZipException = class( Exception );
TZipMode = (zmClosed, zmRead, zmReadWrite, zmWrite);
TZipFile = class;
/// <summary> Function to Create a Compression/Decompression stream </summary>
/// <remarks>
/// Call <c>RegisterCompressionHandler</c> to register a compression type that
/// can Compress/Decompress a stream. The output stream reads/write from/to InStream.
/// </remarks>
TStreamConstructor = reference to function(InStream: TStream; const ZipFile: TZipFile; const Item: TZipHeader): TStream;
/// <summary> Class for creating and reading .ZIP files.
/// </summary>
TZipFile = class
private type
TCompressionDict = TDictionary< TZipCompression , TPair<TStreamConstructor, TStreamConstructor > >;
private class var
FCompressionHandler: TCompressionDict;
private
FMode: TZipMode;
FStream: TStream;
FFileStream: TFileStream;
FStartFileData: Int64;
FEndFileData: Int64;
FFiles: TList<TZipHeader>;
FComment: String;
FUTF8Support: Boolean;
function GetFileComment(Index: Integer): string;
function GetFileCount: Integer;
function GetFileInfo(Index: Integer): TZipHeader;
function GetFileInfos: TArray<TZipHeader>;
function GetFileName(Index: Integer): string;
function GetFileNames: TArray<string>;
procedure ReadCentralHeader;
procedure SetFileComment(Index: Integer; Value: string);
procedure SetUTF8Support(const Value: Boolean);
function LocateEndOfCentralHeader(var Header: TZipEndOfCentralHeader): Boolean;
public
class constructor Create;
class destructor Destroy;
/// <remarks>
/// Call <c>RegisterCompressionHandler</c> to register a compression type that
/// can Compress/Decompress a stream. The output stream reads/write from/to InStream.
/// </remarks>
class procedure RegisterCompressionHandler(Compression: TZipCompression;
CompressStream, DecompressStream: TStreamConstructor);
/// <param name="ZipFileName">Path to Zip File</param>
/// <returns>Is the .ZIP file valid</returns>
class function IsValid(ZipFileName: string): Boolean; static;
/// <summary> Extract a ZipFile</summary>
/// <param name="ZipFileName">File name of the ZIP file</param>
/// <param name="Path">Path to extract to disk</param>
class procedure ExtractZipFile(ZipFileName: string; Path: string); static;
/// <summary> Zip the contents of a directory </summary>
/// <param name="ZipFileName">File name of the ZIP file</param>
/// <param name="Path">Path of directory to zip</param>
/// <param name="Compression">Compression mode.</param>
class procedure ZipDirectoryContents(ZipFileName: string; Path: string;
Compression: TZipCompression = zcDeflate); static;
/// <summary> Create a TZipFile</summary>
constructor Create;
/// <remarks> Destroy will close an open zipfile before disposing of it</remarks>
destructor Destroy; override;
/// <summary> Opens a ZIP file for reading or writing.</summary>
/// <param name="ZipFileName">Path to ZipFile</param>
/// <param name="OpenMode"> File Mode to open file.
/// <c>zmWrite</c> Creates a new ZIP file for writing.
/// <c>zmReadWrite</c> Opens the file for reading and allows adding
/// additional new files.
/// <c>zmRead</c> Opens the file for reading.
///</param>
procedure Open(ZipFileName: string; OpenMode: TZipMode); overload;
procedure Open(ZipFileStream: TStream; OpenMode: TZipMode); overload;
/// <remarks>
/// Closing is required to write the ZipFile's
/// Central Directory to disk. Closing a file that is open for writing
/// writes additonal metadata that is required for reading the file.
/// </remarks>
procedure Close;
/// <summary> Extract a single file </summary>
/// <remarks>
/// <c>FileName</c> specifies a file in the ZIP file. All slashes
/// in ZIP file names should be '/'.
/// The overload that takes an Integer may be useful when a ZIP file
/// has duplicate filenames.
/// </remarks>
/// <param name="FileName">File name in the archive</param>
/// <param name="Path">Path to extract to disk</param>
/// <param name="CreateSubdirs">The output should create sub directories specified in the ZIP file</param>
procedure Extract(FileName: string; Path: string = ''; CreateSubdirs: Boolean=True); overload;
procedure Extract(Index: Integer; Path: string = ''; CreateSubdirs: Boolean=True); overload;
/// <summary> Extract All files </summary>
/// <param name="Path">Path to extract to.</param>
procedure ExtractAll(Path: string = '');
/// <summary> Read a file from arcive to an array of Bytes </summary>
/// <remarks>
/// The overload that takes an Integer may be useful when a ZIP file
/// has duplicate filenames.
/// </remarks>
/// <param name="FileName">ZIP file FileName</param>
/// <param name="Bytes">Output bytes</param>
procedure Read(FileName: string; out Bytes: TBytes); overload;
procedure Read(Index: Integer; out Bytes: TBytes); overload;
/// <summary> Get a stream to read a file from disk </summary>
/// <remarks>
/// The Stream returned by this function is a decomression stream
/// wrapper around the interal Stream reading the zip file. You must
/// Free this stream before using other TZipFile methods that change the
/// contents of the ZipFile, such as Read or Add.
/// The overload that takes an Integer may be useful when a ZIP file
/// has duplicate filenames.
/// </remarks>
/// <param name="FileName">ZIP file FileName</param>
/// <param name="Stream">Output Stream</param>
/// <param name="LocalHeader">Local File header</param>
procedure Read(FileName: string; out Stream: TStream; out LocalHeader: TZipHeader); overload;
procedure Read(Index: Integer; out Stream: TStream; out LocalHeader: TZipHeader); overload;
/// <summary> Add a file to the ZIP file </summary>
/// <param name="FileName">FileName to be added</param>
/// <param name="ArchiveFileName">Path + Name of file in the arcive.
/// If Ommitted, <C>ExtractFileName(FileName)</C> will be used.</param>
/// <param name="Compression">Compression mode.</param>
procedure Add(FileName: string; ArchiveFileName: string = '';
Compression: TZipCompression = zcDeflate); overload;
/// <summary> Add a memory file to the ZIP file </summary>
/// <param name="Data">Bytes to be added</param>
/// <param name="ArchiveFileName">Path + Name of file in the arcive.</param>
/// <param name="Compression">Compression mode.</param>
procedure Add(Data: TBytes; ArchiveFileName: string;
Compression: TZipCompression = zcDeflate); overload;
/// <summary> Add a memory file to the ZIP file </summary>
/// <param name="Data">Stream of file to be added</param>
/// <param name="ArchiveFileName">Path + Name of file in the arcive.</param>
/// <param name="Compression">Compression mode.</param>
procedure Add(Data: TStream; ArchiveFileName: string;
Compression: TZipCompression = zcDeflate); overload;
/// <summary> Add a memory file to the ZIP file. Allows programmer to specify
/// the Local and Central Header data for more flexibility on what gets written.
/// Minimal vailidation is done on the Header parameters; speficying bad options
/// could result in a corrupted zip file. </summary>
/// <param name="Data">Stream of file to be added</param>
/// <param name="LocalHeader">The local header data</param>
/// <param name="CentralHeader">A Pointer to an optional central header. If no
/// central Header is provided, the Local Header information is used. </param>
procedure Add(Data: TStream; LocalHeader: TZipHeader;
CentralHeader: PZipHeader = nil); overload;
/// <summary> Translate from FileName to index in ZIP Central Header
/// </summary>
/// <remarks>
/// A ZIP file may have dupicate entries with the same name. This
/// function will return the index of the first.
/// </remarks>
/// <param name="FileName">Path + Name of file in the arcive.</param>
/// <returns>The index of the file in the archive, or -1 on failure.
/// </returns>
function IndexOf(FileName: string): Integer;
/// <returns> The mode the TZipFile is opened to</returns>
property Mode: TZipMode read FMode;
/// <returns>Total files in ZIP File</returns>
property FileCount: Integer read GetFileCount;
/// <returns>An array of FileNames in the ZIP file</returns>
property FileNames: TArray<string> read GetFileNames;
/// <returns>An array of the TZipHeader of the files in the ZIP file</returns>
property FileInfos: TArray<TZipHeader> read GetFileInfos;
/// <returns>FileName of a File in the ZipFile</returns>
property FileName[Index: Integer]: string read GetFileName;
/// <returns>TZipHeader of a File in the ZipFile</returns>
property FileInfo[Index: Integer]: TZipHeader read GetFileInfo;
/// <remarks>
/// File Comments can be changed for files opened in write mode at any point.
/// The comment is written when the Central Directory is written to disk.
/// Comments can be a maximum of 65535 bytes long. If a longer comment is supplied,
/// It is truncated before writing to the ZIP File.
/// </remarks>
property FileComment[Index: Integer]: string read GetFileComment write SetFileComment;
/// <remarks>
/// Comments can be a maximum of 65535 bytes long. If a longer comment is supplied,
/// It is truncated before writing to the ZIP File.
/// </remarks>
property Comment: string read FComment write FComment;
property UTF8Support: Boolean read FUTF8Support write SetUTF8Support default True;
end;
resourcestring
{ Zip Strings}
SZipErrorRead = 'Error reading zip file';
SZipErrorWrite = 'Error writing zip file';
SZipInvalidLocalHeader = 'Invalid Zip Local Header signature';
SZipInvalidCentralHeader = 'Invalid Zip Central Header signature';
SZipNotSupported = 'Support for compression method not registered: %s';
SZipNotOpen = 'File must be open';
SZipNoWrite = 'File must be open for writing';
SZipNoRead = 'File must be open for reading';
SZipNotEmpty = 'Zip file must be empty';
sArgumentInvalid = 'Invalid argument';
SReadError = 'Stream read error';
SFileNotFound = 'The specified file was not found';
implementation
uses ZLib,CRC;
type
TOem437String = type AnsiString(437);
procedure VerifyRead(Stream: TStream; var Buffer; Count: Integer);
begin
if Stream.Read(Buffer, Count) <> Count then
raise EZipException.CreateRes(@SZipErrorRead);// at ReturnAddress;
end;
procedure VerifyWrite(Stream: TStream; var Buffer; Count: Integer);
begin
if Stream.Write(Buffer, Count) <> Count then
raise EZipException.CreateRes(@SZipErrorWrite);// at ReturnAddress;
end;
type
/// <summary> Helper class for reading a segment of another stream.</summary>
TStoredStream = class( TStream )
private
FStream: TStream;
FPos: Int64;
protected
function GetSize: Int64; override;
public
constructor Create( Stream: TStream );
function Read(var Buffer; Count: Longint): Longint; override;
function Write(const Buffer; Count: Longint): Longint; override;
function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
end;
{ TStoredStream }
constructor TStoredStream.Create(Stream: TStream);
begin
FStream := Stream;
FPos := FStream.Position;
end;
function TStoredStream.GetSize: Int64;
begin
Result := FStream.Size;
end;
function TStoredStream.Read(var Buffer; Count: Integer): Longint;
begin
Result := FStream.Read(Buffer, Count);
end;
function TStoredStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
Result := FStream.Seek(Offset, Origin)
end;
function TStoredStream.Write(const Buffer; Count: Integer): Longint;
begin
Result := FStream.Write(Buffer, Count);
end;
function TZipCompressionToString(Compression: TZipCompression): string;
begin
case Compression of
zcStored: Result := 'Stored'; // do not localize
zcShrunk: Result := 'Shrunk'; // do not localize
zcReduce1: Result := 'Reduced1'; // do not localize
zcReduce2: Result := 'Reduced2'; // do not localize
zcReduce3: Result := 'Reduced3'; // do not localize
zcReduce4: Result := 'Reduced4'; // do not localize
zcImplode: Result := 'Imploded'; // do not localize
zcTokenize: Result := 'Tokenized'; // do not localize
zcDeflate: Result := 'Deflated'; // do not localize
zcDeflate64: Result := 'Deflated64'; // do not localize
zcPKImplode: Result := 'Imploded(TERSE)'; // do not localize
zcBZIP2: Result := 'BZIP2'; // do not localize
zcLZMA: Result := 'LZMA'; // do not localize
zcTERSE: Result := 'TERSE'; // do not localize
zcLZ77: Result := 'LZ77'; // do not localize
zcWavePack: Result := 'WavPack'; // do not localize
zcPPMdI1: Result := 'PPMd version I, Rev 1'; // do not localize
else
Result := 'Unknown';
end;
end;
{ TZipFile }
function TZipFile.GetFileComment(Index: Integer): string;
begin
if FMode = zmClosed then
raise EZipException.CreateRes(@SZipNotOpen);
Result := string(FFiles[Index].FileComment);
end;
function TZipFile.GetFileCount: Integer;
begin
if FMode = zmClosed then
raise EZipException.CreateRes(@SZipNotOpen);
Result := FFiles.Count;
end;
function TZipFile.GetFileInfo(Index: Integer): TZipHeader;
begin
if FMode = zmClosed then
raise EZipException.CreateRes(@SZipNotOpen);
Result := FFiles[Index];
end;
function TZipFile.GetFileInfos: TArray<TZipHeader>;
begin
if FMode = zmClosed then
raise EZipException.CreateRes(@SZipNotOpen);
Result := FFiles.ToArray;
end;
function TZipFile.GetFileName(Index: Integer): string;
begin
if FMode = zmClosed then
raise EZipException.CreateRes(@SZipNotOpen);
Result := string(FFiles[Index].FileName);
end;
function TZipFile.GetFileNames: TArray<string>;
var
I: Integer;
begin
if FMode = zmClosed then
raise EZipException.CreateRes(@SZipNotOpen);
SetLength(Result, FFiles.Count);
for I := 0 to High(Result) do
Result[I] := string(FFiles[I].FileName);
end;
procedure TZipFile.ReadCentralHeader;
var
I: Integer;
Signature: UInt32;
LEndHeader: TZipEndOfCentralHeader;
LHeader: TZipHeader;
begin
FFiles.Clear;
if FStream.Size = 0 then
Exit;
// Read End Of Centeral Direcotry Header
if not LocateEndOfCentralHeader(LEndHeader) then
raise EZipException.CreateRes(@SZipErrorRead);
// Move to the beginning of the CentralDirectory
FStream.Position := LEndHeader.CentralDirOffset;
// Save Begginning of Central Directory. This is where new files
// get written to, and where the new central directory gets written when
// closing.
FEndFileData := LEndHeader.CentralDirOffset;
// Read File Headers
for I := 0 to LEndHeader.CentralDirEntries - 1 do
begin
// Verify Central Header signature
FStream.Read(Signature, Sizeof(Signature));
if Signature <> SIGNATURE_CENTRALHEADER then
raise EZipException.CreateRes(@SZipInvalidCentralHeader);
// Read Central Header
VerifyRead(FStream, LHeader.MadeByVersion, CENTRALHEADERSIZE);
// Read Dynamic length fields (FileName, ExtraField, FileComment)
if LHeader.FileNameLength > 0 then
begin
SetLength(LHeader.FileName, LHeader.FileNameLength);
if (LHeader.Flag and (1 SHL 11)) <> 0 then
SetCodepage(LHeader.FileName, 65001, False)
else
SetCodepage(LHeader.FileName, 437, False);
VerifyRead(FStream, LHeader.FileName[1], LHeader.FileNameLength);
end;
if LHeader.ExtraFieldLength > 0 then
begin
SetLength(LHeader.ExtraField, LHeader.ExtraFieldLength);
VerifyRead(FStream, LHeader.ExtraField[0], LHeader.ExtraFieldLength);
end;
if LHeader.FileCommentLength > 0 then
begin
SetLength(LHeader.FileComment, LHeader.FileCommentLength);
if (LHeader.Flag and (1 SHL 11)) <> 0 then
SetCodepage(LHeader.FileName, 65001, False)
else
SetCodepage(LHeader.FileName, 437, False);
VerifyRead(FStream, LHeader.FileComment[1], LHeader.FileCommentLength);
end;
if (LHeader.Flag and (1 shl 11)) = 0 then
FUTF8Support := False;
// Save File Header in interal list
FFiles.Add(LHeader);
end;
end;
procedure TZipFile.SetFileComment(Index: Integer; Value: string);
var
LFile: TZipHeader;
begin
if not (FMode in [zmReadWrite, zmWrite]) then
raise EZipException.CreateRes(@SZipNoWrite);
LFile := FFiles[Index];
if Length(Value) > $FFFF then
SetLength(Value, $FFFF);
if UTF8Support then
LFile.FileComment := UTF8Encode(Value)
else
LFile.FileComment := TOem437String(Value);
LFile.FileCommentLength := Length(LFile.FileComment);
FFiles[Index] := LFile;
end;
procedure TZipFile.SetUTF8Support(const Value: Boolean);
begin
if Value = FUTF8Support then Exit;
if not (FMode in [zmReadWrite, zmWrite]) then
raise EZipException.CreateRes(@SZipNoWrite);
// Resetting this flag would require re-writing all the local headers with the
// new strings and flag, and adjusting the offsets.
if FFiles.Count <> 0 then
raise EZipException.CreateRes(@SZipNotEmpty);
FUTF8Support := Value;
end;
class constructor TZipFile.Create;
begin
FCompressionHandler := TCompressionDict.Create;
RegisterCompressionHandler(zcStored,
function(InStream: TStream; const ZipFile: TZipFile; const Item: TZipHeader): TStream
begin
Result := TStoredStream.Create(InStream);
end,
function(InStream: TStream; const ZipFile: TZipFile; const Item: TZipHeader): TStream
begin
Result := TStoredStream.Create(InStream);
end);
RegisterCompressionHandler(zcDeflate,
function(InStream: TStream; const ZipFile: TZipFile; const Item: TZipHeader): TStream
begin
Result := TZCompressionStream.Create(InStream, zcDefault);
end,
function(InStream: TStream; const ZipFile: TZipFile; const Item: TZipHeader): TStream
begin
Result := TZDecompressionStream.Create(InStream);
end);
end;
class destructor TZipFile.Destroy;
begin
FCompressionHandler.Free;
end;
class procedure TZipFile.RegisterCompressionHandler(
Compression: TZipCompression; CompressStream, DecompressStream: TStreamConstructor);
begin
FCompressionHandler.AddOrSetValue(Compression,
TPair<TStreamConstructor, TStreamConstructor>.Create(CompressStream, DecompressStream));
end;
class function TZipFile.IsValid(ZipFileName: string): Boolean;
var
Z: TZipFile;
Header: TZipEndOfCentralHeader;
begin
Result := False;
try
Z := tzipfile.Create;
try
Z.FStream := TFileStream.Create(ZipFileName, fmOpenRead);
try
Result := Z.LocateEndOfCentralHeader(Header);
finally
Z.FStream.Free;
end;
finally
Z.Free;
end;
except on E: Exception do
// Swallow exceptions and return False
end;
end;
function TZipFile.LocateEndOfCentralHeader(var Header: TZipEndOfCentralHeader): Boolean;
var
I: Integer;
LBackRead, LReadSize, LMaxBack: UInt32;
LBackBuf: array[0..$404-1] of Byte;
begin
if FStream.Size < $FFFF then
LMaxBack := FStream.Size
else
LMaxBack := $FFFF;
LBackRead := 4;
while LBackRead < LMaxBack do
begin
if LBackRead + Cardinal(Length(LBackBuf) - 4) > LMaxBack then
LBackRead := LMaxBack
else
Inc(LBackRead, Length(LBackBuf) -4);
FStream.Position := FStream.Size - LBackRead;
if Length(LBackBuf) < (FStream.Size - FStream.Position) then
LReadSize := Length(LBackBuf)
else
LReadSize := FStream.Size - FStream.Position;
VerifyRead(FStream, LBackBuf[0], LReadSize);
for I := LReadSize - 4 downto 0 do
begin
if PCardinal(@LBackBuf[I])^ = SIGNATURE_ZIPENDOFHEADER then
begin
Move(LBackBuf[I+4], Header, SizeOf(Header));
if Header.CommentLength > 0 then
begin
FStream.Position := FStream.Size - LBackRead + I + 4 + SizeOf(Header);
SetLength(FComment, Header.CommentLength);
FStream.Read(FComment[1], Header.CommentLength);
end
else
FComment := '';
Exit(True);
end;
end;
end;
Result := False;
end;
class procedure TZipFile.ExtractZipFile(ZipFileName: string; Path: string);
var
LZip: TZipFile;
begin
LZip := TZipFile.Create;
try
LZip.Open(ZipFileName, zmRead);
LZip.ExtractAll(Path);
LZip.Close;
finally
LZip.Free;
end;
end;
class procedure TZipFile.ZipDirectoryContents(ZipFileName: string; Path: string;
Compression: TZipCompression);
var
LZipFile: TZipFile;
LFile: string;
LZFile: string;
begin
LZipFile := TZipFile.Create;
try
LZipFile.Open(ZipFileName, zmWrite);
// Ensure path ends with PathDelim so when we strip it we have a valid relative path
if Path[Length(Path)] <> PathDelim then
Path := Path + PathDelim;
for LFile in TDirectory.GetFiles(Path, '*', TSearchOption.soAllDirectories) do
begin
// Strip off root path
{$IFDEF MSWINDOWS}
LZFile := StringReplace(
Copy(LFile, Length(Path)+1, Length(LFile)), '\', '/', [rfReplaceAll]);
{$ELSE}
LZFile := Copy(LFile, Length(Path)+1, Length(LFile));
{$ENDIF MSWINDOWS}
LZipFile.Add(LFile, LZFile, Compression);
end;
finally
LZipFile.Free;
end;
end;
constructor TZipFile.Create;
begin
inherited Create;
FFiles := TList<TZipHeader>.Create;
FMode := zmClosed;
FUTF8Support := True;
end;
destructor TZipFile.Destroy;
begin
Close; // In case a file is open for writing currently
FFiles.Free;
inherited;
end;
procedure TZipFile.Open(ZipFileName: string; OpenMode: TZipMode);
var
LMode: LongInt;
LFileStream: TFileStream;
begin
Close; // In case the user had a file open
case OpenMode of
zmRead: LMode := fmOpenRead;
zmReadWrite: LMode := fmOpenReadWrite;
zmWrite: LMode := fmCreate;
else
raise EZipException.CreateRes(@sArgumentInvalid);
end;
LFileStream := TFileStream.Create(ZipFileName, LMode);
try
Open(LFileStream, OpenMode);
FFileStream := LFileStream;
except
FreeAndNil(LFileStream);
raise;
end;
end;
procedure TZipFile.Open(ZipFileStream: TStream; OpenMode: TZipMode);
begin
Close; // In case the user had a file open
if OpenMode = zmClosed then
raise EZipException.CreateRes(@sArgumentInvalid);
if (OpenMode = zmRead) and (ZipFileStream.Size = 0) then
raise EZipException.CreateRes(@SReadError);
FStream := ZipFileStream;
FStartFileData := FStream.Position;
if OpenMode in [zmRead, zmReadWrite] then
try
// Read the Central Header to verify it's a valid zipfile
ReadCentralHeader;
except
// If it's an invalid zipfile, cleanup
FStream := nil;
raise;
end;
FMode := OpenMode;
end;
procedure TZipFile.Close;
var
LHeader: TZipHeader;
LEndOfHeader: TZipEndOfCentralHeader;
I: Integer;
Signature: UInt32;
begin
try
// Only need to write Central Directory and End Of Central Directory if writing
if (FMode = zmReadWrite) or (FMode = zmWrite) then
begin
FStream.Position := FEndFileData;
Signature := SIGNATURE_CENTRALHEADER;
// Write File Signatures
for I := 0 to FFiles.Count - 1 do
begin
LHeader := FFiles[I];
VerifyWrite(FStream, Signature, SizeOf(Signature));
VerifyWrite(FStream, LHeader.MadeByVersion, CENTRALHEADERSIZE);
if LHeader.FileNameLength <> 0 then
VerifyWrite(FStream, LHeader.FileName[1], LHeader.FileNameLength);
if LHeader.ExtraFieldLength <> 0 then
VerifyWrite(FStream, LHeader.ExtraField[1], LHeader.ExtraFieldLength);
if LHeader.FileCommentLength <> 0 then
VerifyWrite(FStream, LHeader.FileComment[1], LHeader.FileCommentLength);
end;
// Only support writing single disk .ZIP files
FillChar(LEndOfHeader, Sizeof(LEndOfHeader), 0);
LEndOfHeader.CentralDirEntries := FFiles.Count;
LEndOfHeader.NumEntriesThisDisk := FFiles.Count;
LEndOfHeader.CentralDirSize := FStream.Position - FEndFileData;
LEndOfHeader.CentralDirOffset := FEndFileData;
// Truncate comment if it's too long
if Length(FComment) > $FFFF then
SetLength(FComment, $FFFF);
LEndofHeader.CommentLength := Length(FComment);
// Write End Of Centeral Directory
Signature := SIGNATURE_ZIPENDOFHEADER;
VerifyWrite(FStream, Signature, SizeOf(Signature));
VerifyWrite(FStream, LEndOfHeader, SizeOf(LEndOfHeader));
if LEndOfHeader.CommentLength > 0 then
VerifyWrite(FStream, FComment[1], LEndOfHeader.CommentLength);
end;
finally
FMode := zmClosed;
FFiles.Clear;
FStream := nil;
if Assigned(FFileStream) then
FreeAndNil(FFileStream);
end;
end;
procedure TZipFile.Extract(FileName: string; Path: string; CreateSubDirs: Boolean);
begin
Extract(IndexOf(FileName), Path, CreateSubdirs);
end;
procedure TZipFile.Extract(Index: Integer; Path: string; CreateSubdirs: Boolean);
var
LInStream, LOutStream: TStream;
LHeader: TZipHeader;
LDir, LFileName: string;
Bytes: array [0..4095] of Byte;
ReadBytes: Int64;
begin
// Get decompression stream for file
Read(Index, LInStream, LHeader);
try
LFileName := string(FFiles[Index].FileName);
{$IFDEF MSWINDOWS} // ZIP stores files with '/', so translate to a relative Windows path.
LFileName := StringReplace(LFileName, '/', '\', [rfReplaceAll]);
{$ENDIF}
// CreateSubDirs = False assumes the user passed in the path where they want the file to end up
if CreateSubdirs then
LFileName := TPath.Combine(Path, LFileName)
else
LFileName := TPath.Combine(Path, ExtractFileName(LFileName));
// Force directory creation
LDir := ExtractFileDir(LFileName);
if CreateSubdirs and (LDir <> '') then
TDirectory.CreateDirectory(ExtractFileDir(LFileName));
// Open the File For output
if LFileName[Length(LFileName)] = PathDelim then
Exit; // Central Directory Entry points at a directory, not a file.
LOutStream := TFileStream.Create(LFileName, fmCreate);
try // And Copy from the decompression stream.
if (LHeader.Flag and (1 SHL 3)) = 0 then
if FFiles[Index].UncompressedSize > 0 then // Special case for empty files.
LOutStream.CopyFrom(LInStream, FFiles[Index].UncompressedSize)
else
begin
//CRC, Uncompressed, and Compressed Size follow the compressed data.
while True do
begin
ReadBytes := LInStream.Read(Bytes, Length(Bytes));
LOutStream.Write(Bytes, ReadBytes);
if ReadBytes < Length(Bytes) then
break;
end;
end;
finally
LOutStream.Free;
end;
finally
LInStream.Free;
end;
end;
procedure TZipFile.ExtractAll(Path: string);
var
I: Integer;
begin
if not (FMode in [zmReadWrite, zmRead]) then
raise EZipException.CreateRes(@SZipNoRead);
for I := 0 to FFiles.Count - 1 do
Extract(I, Path);
end;
procedure TZipFile.Read(FileName: string; out Bytes: TBytes);
begin
Read(IndexOf(FileName), Bytes);
end;
procedure TZipFile.Read(Index: Integer; out Bytes: TBytes);
var
LStream: TStream;
LHeader: TZipHeader;
ReadStart, ReadBytes: Int64;
begin
Read(Index, LStream, LHeader);
try
if (LHeader.Flag and (1 SHL 3)) = 0 then
begin
SetLength(Bytes, FFiles[Index].UncompressedSize);
if FFiles[Index].UncompressedSize > 0 then // Special case for empty files.
VerifyRead(LStream, Bytes[0], LHeader.UncompressedSize);
end
else
begin
//CRC, Uncompressed, and Compressed Size follow the compressed data.
SetLength(Bytes, 4096);
ReadStart := 0;
ReadBytes := 0; // Supress warning
while True do
begin
ReadBytes := LStream.Read(Bytes[ReadStart], Length(Bytes)-ReadStart);
if ReadBytes < (Length(Bytes) - ReadStart) then
break;
ReadStart := ReadStart + ReadBytes;
SetLength(Bytes, Length(Bytes)*2);
end;
SetLength(Bytes, ReadStart + ReadBytes);
end;
finally
LStream.Free;
end;
end;
procedure TZipFile.Read(FileName: string; out Stream: TStream; out LocalHeader: TZipHeader);
begin
Read(IndexOf(FileName), Stream, LocalHeader);
end;
procedure TZipFile.Read(Index: Integer; out Stream: TStream; out LocalHeader: TZipHeader);
var
Signature: UInt32;
begin
if not (FMode in [zmReadWrite, zmRead]) then
raise EZipException.CreateRes(@SZipNoRead);
if (Index < 0) or (Index > FFiles.Count) then
raise EZipException.CreateRes(@SFileNotFound);
// Move to beginning of Local Header
FStream.Position := FFiles[Index].LocalHeaderOffset + FStartFileData;
// Verify local header signature
FStream.Read(Signature, Sizeof(Signature));
if Signature <> SIGNATURE_LOCALHEADER then
raise EZipException.CreateRes(@SZipInvalidLocalHeader);
// Read local header
FStream.Read(LocalHeader.RequiredVersion, LOCALHEADERSIZE);
// Read Name and extra fields
SetLength(LocalHeader.FileName, LocalHeader.FileNameLength);
SetLength(LocalHeader.ExtraField, LocalHeader.ExtraFieldLength);
if (LocalHeader.Flag and (1 SHL 11)) <> 0 then
SetCodepage(LocalHeader.FileName, 65001, False)
else
SetCodepage(LocalHeader.FileName, 437, False);
FStream.Read(LocalHeader.FileName[1], LocalHeader.FileNameLength);
if LocalHeader.ExtraFieldLength > 0 then
FStream.Read(LocalHeader.ExtraField[0], LocalHeader.ExtraFieldLength);
// Create Decompression stream.
Stream := FCompressionHandler[TZipCompression(FFiles[Index].CompressionMethod)].Value(FStream, Self, LocalHeader);
end;
procedure TZipFile.Add(Data: TStream; LocalHeader: TZipHeader; CentralHeader: PZipHeader);
var
DataStart: Int64;
LCompressStream: TStream;
Signature: UInt32;
LStartPos: Int64;
LBuffer: array[0..$4000] of Byte;
begin
// Seek to End of zipped data
FStream.Position := FEndFileData;
LocalHeader.LocalHeaderOffset := FEndFileData;
// Require at least version 2.0
if LocalHeader.MadeByVersion < 20 then
LocalHeader.MadeByVersion := 20;
if LocalHeader.RequiredVersion < 20 then
LocalHeader.RequiredVersion := 20;
if CentralHeader = nil then
CentralHeader := @LocalHeader;
// Write Signature, Header, and FileName
Signature := SIGNATURE_LOCALHEADER;
VerifyWrite(FStream, Signature, SizeOf(Signature));
VerifyWrite(FStream, LocalHeader.RequiredVersion, LOCALHEADERSIZE);
VerifyWrite(FStream, LocalHeader.FileName[1], LocalHeader.FileNameLength);
if LocalHeader.ExtraFieldLength > 0 then
VerifyWrite(FStream, LocalHeader.ExtraField[0], LocalHeader.ExtraFieldLength);
// Save position to calcuate Compressed Size
LStartPos := FStream.Position;
DataStart := Data.Position;
LocalHeader.UncompressedSize := Data.Size - DataStart;
// Write Compressed data
LCompressStream := FCompressionHandler[TZipCompression(LocalHeader.CompressionMethod)].Key(FStream, self, LocalHeader);
try
LCompressStream.CopyFrom(Data, LocalHeader.UncompressedSize);
finally
LCompressStream.Free;
end;
// Calcuate CompressedSize
LocalHeader.CompressedSize := FStream.Position - LStartPos;
Data.Position := DataStart;
// Calcuate Uncompressed data's CRC
while Data.Position < LocalHeader.UncompressedSize do
LocalHeader.CRC32 := crc32(LocalHeader.CRC32, LBuffer[0],Data.Read(LBuffer, SizeOf(LBuffer)));
CentralHeader.UnCompressedSize := LocalHeader.UnCompressedSize;
CentralHeader.CompressedSize := LocalHeader.CompressedSize;
CentralHeader.CRC32 := LocalHeader.CRC32;
// Save new End of zipped data mark
FEndFileData := FStream.Position;
// Move to beginning of Local Header offset and rewrite header
// with correct CompressedSize and CRC32
FStream.Position := LocalHeader.LocalHeaderOffset + SizeOf(UInt32);
FStream.Write(LocalHeader.RequiredVersion, LOCALHEADERSIZE);
FFiles.Add(CentralHeader^);
end;
procedure TZipFile.Add(FileName: string; ArchiveFileName: string;
Compression: TZipCompression);
var
LInStream: TStream;
LHeader: TZipHeader;
begin
if not (FMode in [zmReadWrite, zmWrite]) then
raise EZipException.CreateRes(@SZipNoWrite);
if not FCompressionHandler.ContainsKey(Compression) then
raise EZipException.CreateResFmt(@SZipNotSupported, [
TZipCompressionToString(Compression) ]);
// Setup Header
FillChar(LHeader, sizeof(LHeader), 0);
LHeader.Flag := 0;
LInStream := TFileStream.Create(FileName, fmOpenRead);
try
LHeader.Flag := 0;
LHeader.CompressionMethod := UInt16(Compression);
LHeader.ModifiedDateTime := DateTimeToFileDate( tfile.GetLastWriteTime(FileName) );
LHeader.UncompressedSize := LInStream.Size;
LHeader.InternalAttributes := 0;
LHeader.ExternalAttributes := 0;
if ArchiveFileName = '' then
ArchiveFileName := ExtractFileName(FileName);
if FUTF8Support then
begin
LHeader.Flag := LHeader.Flag or (1 SHL 11); // Language encoding flag, UTF8
LHeader.FileName := UTF8Encode(ArchiveFileName);
end
else
LHeader.FileName := TOem437String(ArchiveFileName);
LHeader.FileNameLength := Length(LHeader.FileName);
LHeader.ExtraFieldLength := 0;
Add(LInStream, LHeader);
finally
LInStream.Free;
end;
end;
procedure TZipFile.Add(Data: TBytes; ArchiveFileName: string;
Compression: TZipCompression);
var
LInStream: TStream;
begin
if not (FMode in [zmReadWrite, zmWrite]) then
raise EZipException.CreateRes(@SZipNoWrite);
if not FCompressionHandler.ContainsKey(Compression) then
raise EZipException.CreateResFmt(@SZipNotSupported, [
TZipCompressionToString(Compression) ]);
LInStream := TBytesStream.Create(Data);
try
Add(LInStream, ArchiveFileName, Compression);
finally
LInStream.Free;
end;
end;
procedure TZipFile.Add(Data: TStream; ArchiveFileName: string;
Compression: TZipCompression);
var
LHeader: TZipHeader;
begin
if not (FMode in [zmReadWrite, zmWrite]) then
raise EZipException.CreateRes(@SZipNoWrite);
if not FCompressionHandler.ContainsKey(Compression) then
raise EZipException.CreateResFmt(@SZipNotSupported, [
TZipCompressionToString(Compression) ]);
// Setup Header
FillChar(LHeader, sizeof(LHeader), 0);
LHeader.Flag := 0;
LHeader.CompressionMethod := UInt16(Compression);
LHeader.ModifiedDateTime := DateTimeToFileDate( Now );
LHeader.InternalAttributes := 0;
LHeader.ExternalAttributes := 0;
if FUTF8Support then
begin
LHeader.Flag := LHeader.Flag or (1 SHL 11); // Language encoding flag, UTF8
LHeader.FileName := UTF8Encode(ArchiveFileName);
end
else
LHeader.FileName := TOem437String(ArchiveFileName);
LHeader.FileNameLength := Length(LHeader.FileName);
LHeader.ExtraFieldLength := 0;
Add(Data, LHeader);
end;
function TZipFile.IndexOf(FileName: string): Integer;
var
I: Integer;
begin
Result := -1;
for I := 0 to FFiles.Count - 1 do
if string(FFiles[I].FileName) = FileName then
Exit(I);
end;
end.
unit CRC;
interface
{
how to use:
var
CRC16: Word;
begin
CRC16 := CRCCalc(CRC_16, Data, SizeOf(Data)); // all in one
end;
var
CRC: TCRCDef;
CRC32: Cardinal;
begin
CRCInit(CRC, CRC_32); // setup CRC data structure
CRCCode(CRC, Data, SizeOf(Data)); // returns correct CRC32 for this Data
CRCCode(CRC, PChar(String)^, Length(String) * SizeOf(Char)); // returns correct CRC32 for String AND CRC.CRC holds intermediate
CRC32 := CRCDone(CRC); // returns correct CRC32 for Data + String
// after CRCDone we can restart a new calculation
end;
above examples are fully threadsafe and require ~ $0420 Bytes Stack space.
}
type
// CRC Definitions Structure
PCRCDef = ^TCRCDef;
TCRCDef = packed record // don't reorder or change this structure
Table: array[0..255] of Cardinal; // Lookuptable, precomputed in CRCSetup
CRC: Cardinal; // intermediate CRC
Inverse: LongBool; // is this Polynomial a inverse function
Shift: Cardinal; // Shift Value for CRCCode, more speed
InitVector: Cardinal; // Startvalue of CRC Computation
FinalVector: Cardinal; // final XOR Vector of computed CRC
Mask: Cardinal; // precomputed AND Mask of computed CRC
Bits: Cardinal; // Bitsize of CRC
Polynomial: Cardinal; // used Polynomial
end; // SizeOf(TCRCDef) = 1056 = 0420h
// predefined Standard CRC Types
TCRCType = (CRC_8, CRC_10, CRC_12, CRC_16, CRC_16CCITT, CRC_16XModem, CRC_24,
CRC_32, CRC_32CCITT, CRC_32ZModem);
type
TReadMethod = function(var Buffer; Count: LongInt): LongInt of object;
// calculates a CRC over Buffer with Size Bytes Length, used Algo in CRCType, all is done in one Step
function CRCCalc(CRCType: TCRCType; const Buffer; Size: Cardinal): Cardinal;
// use a callback
function CRCCalcEx(CRCType: TCRCType; ReadMethod: TReadMethod; Size: Cardinal{$IFDEF VER_D4H} = $FFFFFFFF{$ENDIF}): Cardinal;
// initialize CRC Definition with CRCType Standard CRC
function CRCInit(var CRCDef: TCRCDef; CRCType: TCRCType): Boolean;
// initilaize CRC Definition with a custom Algorithm
function CRCSetup(var CRCDef: TCRCDef; Polynomial, Bits, InitVector, FinalVector: Cardinal; Inverse: LongBool): Boolean;
// process over Buffer with Size Bytes Length a CRC definied in CRCDef.
// Result is actual computed CRC with correction, same as CRCDone(),
// CRCDef.CRC holds the actual computed CRC, a second/more call to CRCCode
// computes than both/more buffers as one buffer.
function CRCCode(var CRCDef: TCRCDef; const Buffer; Size: Cardinal): Cardinal;
// use a callback, eg. TStream.Read(). I hate D4 because they don't love overloaded procedures here
function CRCCodeEx(var CRCDef: TCRCDef; ReadMethod: TReadMethod; Size: Cardinal{$IFDEF VER_D4H} = $FFFFFFFF{$ENDIF}): Cardinal;
// retruns corrected CRC as definied in CRCDef, and reset CRCDef.CRC to InitVector
function CRCDone(var CRCDef: TCRCDef): Cardinal;
// predefined CRC16-Standard, call CRC := CRC16(0, Data, SizeOf(Data));
function CRC16(CRC: Word; const Buffer; Size: Cardinal): Word;
// predefined CRC32-CCITT, call CRC := CRC32(0, Data, SizeOf(Data));
function CRC32(CRC: Cardinal; const Buffer; Size: Cardinal): Cardinal;
//crc32(crc: LongWord; buf: PByte; len: Cardinal): LongWord;
// make it threadsafe
procedure CRCInitThreadSafe;
implementation
function CRCSetup(var CRCDef: TCRCDef; Polynomial, Bits, InitVector,
FinalVector: Cardinal; Inverse: LongBool): Boolean; register;
asm // initialize CRCDef according to the parameters, calculate the lookup table
CMP ECX,8
JB @@8
PUSH EBX
PUSH EDI
PUSH ESI
MOV [EAX].TCRCDef.Polynomial,EDX
MOV [EAX].TCRCDef.Bits,ECX
MOV EBX,InitVector
MOV EDI,FinalVector
MOV ESI,Inverse
MOV [EAX].TCRCDef.CRC,EBX
MOV [EAX].TCRCDef.InitVector,EBX
MOV [EAX].TCRCDef.FinalVector,EDI
MOV [EAX].TCRCDef.Inverse,ESI
XOR EDI,EDI
LEA EBX,[ECX - 8]
SUB ECX,32
DEC EDI
NEG ECX
SHR EDI,CL
MOV [EAX].TCRCDef.Shift,EBX
MOV [EAX].TCRCDef.Mask,EDI
TEST ESI,ESI
JZ @@5
XOR EBX,EBX
MOV ECX,[EAX].TCRCDef.Bits
@@1: SHR EDX,1
ADC EBX,EBX
DEC ECX
JNZ @@1
NOP
MOV ECX,255
NOP
@@20: MOV EDX,ECX
SHR EDX,1
JNC @@21
XOR EDX,EBX
@@21: SHR EDX,1
JNC @@22
XOR EDX,EBX
@@22: SHR EDX,1
JNC @@23
XOR EDX,EBX
@@23: SHR EDX,1
JNC @@24
XOR EDX,EBX
@@24: SHR EDX,1
JNC @@25
XOR EDX,EBX
@@25: SHR EDX,1
JNC @@26
XOR EDX,EBX
@@26: SHR EDX,1
JNC @@27
XOR EDX,EBX
@@27: SHR EDX,1
JNC @@28
XOR EDX,EBX
@@28: MOV [EAX + ECX * 4],EDX
DEC ECX
JNL @@20
JMP @@7
@@5: AND EDX,EDI
ROL EDX,CL
MOV EBX,255
// can be coded branchfree
@@60: MOV ESI,EBX
SHL ESI,25
JNC @@61
XOR ESI,EDX
@@61: ADD ESI,ESI
JNC @@62
XOR ESI,EDX
@@62: ADD ESI,ESI
JNC @@63
XOR ESI,EDX
@@63: ADD ESI,ESI
JNC @@64
XOR ESI,EDX
@@64: ADD ESI,ESI
JNC @@65
XOR ESI,EDX
@@65: ADD ESI,ESI
JNC @@66
XOR ESI,EDX
@@66: ADD ESI,ESI
JNC @@67
XOR ESI,EDX
@@67: ADD ESI,ESI
JNC @@68
XOR ESI,EDX
@@68: ROR ESI,CL
MOV [EAX + EBX * 4],ESI
DEC EBX
JNL @@60
@@7: POP ESI
POP EDI
POP EBX
@@8: CMC
SBB EAX,EAX
NEG EAX
end;
function CRCCode(var CRCDef: TCRCDef; const Buffer;
Size: Cardinal): Cardinal; register;
asm // do the CRC computation
JECXZ @@5
TEST EDX,EDX
JZ @@5
PUSH ESI
PUSH EBX
MOV ESI,EAX
CMP [EAX].TCRCDef.Inverse,0
MOV EAX,[ESI].TCRCDef.CRC
JZ @@2
XOR EBX,EBX
@@1: MOV BL,[EDX]
XOR BL,AL
SHR EAX,8
INC EDX
XOR EAX,[ESI + EBX * 4]
DEC ECX
JNZ @@1
JMP @@4
@@2: PUSH EDI
MOV EBX,EAX
MOV EDI,ECX
MOV ECX,[ESI].TCRCDef.Shift
MOV EBX,EAX
@@3: SHR EBX,CL
SHL EAX,8
XOR BL,[EDX]
INC EDX
MOVZX EBX,BL
XOR EAX,[ESI + EBX * 4]
DEC EDI
MOV EBX,EAX
JNZ @@3
POP EDI
@@4: MOV [ESI].TCRCDef.CRC,EAX
XOR EAX,[ESI].TCRCDef.FinalVector
AND EAX,[ESI].TCRCDef.Mask
POP EBX
POP ESI
RET
@@5: MOV EAX,[EAX].TCRCDef.CRC
end;
function CRCCodeEx(var CRCDef: TCRCDef; ReadMethod: TReadMethod;
Size: Cardinal): Cardinal;
var
Buffer: array[0..1023] of Char;
Count: LongInt;
begin
repeat
if Size > SizeOf(Buffer) then
Count := SizeOf(Buffer)
else
Count := Size;
Count := ReadMethod(Buffer, Count);
Result := CRCCode(CRCDef, Buffer, Count);
Dec(Size, Count);
until (Size = 0) or (Count = 0);
end;
{$IFOPT O-}{$O+}{$DEFINE NoOpt}{$ENDIF}
function CRCInit(var CRCDef: TCRCDef; CRCType: TCRCType): Boolean; register;
type
PCRCTab = ^TCRCTab;
TCRCTab = array[TCRCType] of packed record
Poly, Bits, Init, FInit: Cardinal;
Inverse: LongBool;
end;
procedure CRCTab;
asm
// Polynom Bits InitVec FinitVec Inverse
DD $000000D1, 8, $00000000, $00000000, -1 // CRC_8 GSM/ERR
DD $00000233, 10, $00000000, $00000000, -1 // CRC_10 ATM/OAM Cell
DD $0000080F, 12, $00000000, $00000000, -1 // CRC_12
DD $00008005, 16, $00000000, $00000000, -1 // CRC_16 ARC,IBM
DD $00001021, 16, $00001D0F, $00000000, 0 // CRC_16 CCITT ITU
DD $00008408, 16, $00000000, $00000000, -1 // CRC_16 XModem
DD $00864CFB, 24, $00B704CE, $00000000, 0 // CRC_24
DD $9DB11213, 32, $FFFFFFFF, $FFFFFFFF, -1 // CRC_32
DD $04C11DB7, 32, $FFFFFFFF, $FFFFFFFF, -1 // CRC_32CCITT
DD $04C11DB7, 32, $FFFFFFFF, $00000000, -1 // CRC_32ZModem
// some other CRC's, not all yet verfied
// DD $00000007, 8, $00000000, $00000000, -1 // CRC_8 ATM/HEC
// DD $00000007, 8, $00000000, $00000000, 0 // CRC_8 the SMBus Working Group
// DD $00004599, 15, $00000000, $00000000, -1 // CRC_15 CANBus
// DD $00001021, 16, $00000000, $00000000, 0 // CRC_16ZModem
// DD $00001021, 16, $0000FFFF, $00000000, 0 // CRC_16 CCITT British Aerospace
// DD $00004003, 16, $00000000, $00000000, -1 // CRC_16 reversed
// DD $00001005, 16, $00000000, $00000000, -1 // CRC_16 X25
// DD $00000053, 16, $00000000, $00000000, -1 // BasicCard 16Bit CRC (sparse poly for Crypto MCU)
// DD $000000C5, 32, $00000000, $00000000, -1 // BasicCard 32Bit CRC
end;
begin
with PCRCTab(@CRCTab)[CRCType] do
Result := CRCSetup(CRCDef, Poly, Bits, Init, FInit, Inverse);
end;
{$IFDEF NoOpt}{$O-}{$ENDIF}
function CRCDone(var CRCDef: TCRCDef): Cardinal; register;
asm // finalize CRCDef after a computation
MOV EDX,[EAX].TCRCDef.CRC
MOV ECX,[EAX].TCRCDef.InitVector
XOR EDX,[EAX].TCRCDef.FinalVector
MOV [EAX].TCRCDef.CRC,ECX
AND EDX,[EAX].TCRCDef.Mask
MOV EAX,EDX
end;
function CRCCalc(CRCType: TCRCType; const Buffer; Size: Cardinal): Cardinal;
// inplace calculation
var
CRC: TCRCDef;
begin
CRCInit(CRC, CRCType);
Result := CRCCode(CRC, Buffer, Size);
end;
function CRCCalcEx(CRCType: TCRCType; ReadMethod: TReadMethod; Size: Cardinal): Cardinal;
var
CRC: TCRCDef;
begin
CRCInit(CRC, CRCType);
Result := CRCCodeEx(CRC, ReadMethod, Size);
end;
// predefined CRC16/CRC32CCITT, avoid slower lookuptable computation by use of precomputation
var
FCRC16: PCRCDef = nil;
FCRC32: PCRCDef = nil;
function CRC16Init: Pointer;
begin
GetMem(FCRC16, SizeOf(TCRCDef));
CRCInit(FCRC16^, CRC_16);
Result := FCRC16;
end;
function CRC16(CRC: Word; const Buffer; Size: Cardinal): Word;
asm
JECXZ @@2
PUSH EDI
PUSH ESI
MOV EDI,ECX
{$IFDEF PIC}
MOV ESI,[EBX].FCRC16
{$ELSE}
MOV ESI,FCRC16
{$ENDIF}
XOR ECX,ECX
TEST ESI,ESI
JZ @@3
@@1: MOV CL,[EDX]
XOR CL,AL
SHR EAX,8
INC EDX
XOR EAX,[ESI + ECX * 4]
DEC EDI
JNZ @@1
POP ESI
POP EDI
@@2: RET
@@3: PUSH EAX
PUSH EDX
CALL CRC16Init
MOV ESI,EAX
XOR ECX,ECX
POP EDX
POP EAX
JMP @@1
end;
function CRC32Init: Pointer;
begin
GetMem(FCRC32, SizeOf(TCRCDef));
CRCInit(FCRC32^, CRC_32CCITT);
Result := FCRC32;
end;
function CRC32(CRC: Cardinal; const Buffer; Size: Cardinal): Cardinal;
asm
JECXZ @@2
PUSH EDI
PUSH ESI
NOT EAX // inverse Input CRC
MOV EDI,ECX
{$IFDEF PIC}
MOV ESI,[EBX].FCRC32
{$ELSE}
MOV ESI,FCRC32
{$ENDIF}
XOR ECX,ECX
TEST ESI,ESI
JZ @@3
@@1: MOV CL,[EDX]
XOR CL,AL
SHR EAX,8
INC EDX
XOR EAX,[ESI + ECX * 4]
DEC EDI
JNZ @@1
NOT EAX // inverse Output CRC
POP ESI
POP EDI
@@2: RET
@@3: PUSH EAX
PUSH EDX
CALL CRC32Init
MOV ESI,EAX
XOR ECX,ECX
POP EDX
POP EAX
JMP @@1
end;
procedure CRCInitThreadSafe;
begin
CRC16Init;
CRC32Init;
end;
initialization
finalization
if FCRC16 <> nil then FreeMem(FCRC16);
if FCRC32 <> nil then FreeMem(FCRC32);
end.
原帖地址
将Delphi Xe2的Zip单元移植了一份到Delphi Xe上
作者 http://my.csdn.net/anyong001
扫一扫
3746
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
