542 lines
18 KiB
ObjectPascal
542 lines
18 KiB
ObjectPascal
{-----------------------------------------------------------------------------
|
|
The contents of this file are subject to the Mozilla Public License
|
|
Version 1.1 (the "License"); you may not use this file except in compliance
|
|
with the License. You may obtain a copy of the License at
|
|
http://www.mozilla.org/MPL/MPL-1.1.html
|
|
|
|
Software distributed under the License is distributed on an "AS IS" basis,
|
|
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
|
|
the specific language governing rights and limitations under the License.
|
|
|
|
The Original Code is: JvZlibMultiple.PAS, released on 2001-02-28.
|
|
|
|
The Initial Developer of the Original Code is S?stien Buysse [sbuysse att buypin dott com]
|
|
Portions created by S?stien Buysse are Copyright (C) 2001 S?stien Buysse.
|
|
All Rights Reserved.
|
|
|
|
Contributor(s): Michael Beck [mbeck att bigfoot dott com].
|
|
|
|
You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
|
|
located at http://jvcl.sourceforge.net
|
|
|
|
Known Issues:
|
|
2004-07-27 - Read the 'ALL USERS READ THIS' section below.
|
|
-----------------------------------------------------------------------------}
|
|
// $Id: JvZlibMultiple.pas,v 1.28 2006/02/09 16:36:18 outchy Exp $
|
|
|
|
{$I jvcl.inc}
|
|
|
|
unit JvZlibMultiple;
|
|
|
|
interface
|
|
|
|
uses
|
|
{$IFDEF UNITVERSIONING}
|
|
JclUnitVersioning,
|
|
{$ENDIF UNITVERSIONING}
|
|
{$IFDEF MSWINDOWS}
|
|
Windows, // inline
|
|
{$ENDIF MSWINDOWS}
|
|
SysUtils, Classes, Graphics, Controls, Dialogs,
|
|
JclCompression,
|
|
JvComponentBase;
|
|
|
|
// ----------------------------------------------------------------------------}
|
|
// 2004-07-27 *** ALL USERS READ THIS: (wpostma) ***
|
|
//
|
|
// I have added support for selective extraction and listing archive contents without
|
|
// writing any files to disk. To do this we had to add some parameters to the component events.
|
|
//
|
|
// This will break existing applications that use these events, until they update their
|
|
// event declarations, to add the new parameters to your events.
|
|
//
|
|
// This is something the Delphi IDE should do automatically, but does not do. <grin>
|
|
//
|
|
// The old events for OnDecompressingFile, and OnDecompressedFile
|
|
// look like this:
|
|
// procedure <<TMyForm.MyEventHandlerName>>(Sender: TObject; const FileName: string)
|
|
//
|
|
// The new events have an additional parameter each:
|
|
//
|
|
// OnDecompressingFile -> (Sender: TObject; const FileName: string;
|
|
// {NEW!} var WriteFile: Boolean )
|
|
// OnDecompressedFile -> (Sender: TObject; const FileName: string;
|
|
// {NEW!} const FileSize: Longword )
|
|
//
|
|
// -----------------------------------------------------------------------------}
|
|
|
|
{ November 11, 2005 - yozey
|
|
|
|
NOTE #1
|
|
Added new procedures to pause and terminate the compression process.
|
|
These would be very useful in a threaded environment.
|
|
|
|
NOTE #2 December 22, 2005 - Johann Campbell
|
|
- Added new procedure to list files stored in the zlib file ( basic rewrite of the decompression procedure )
|
|
- Exposed the Pause and Terminate procedures
|
|
|
|
See below.
|
|
}
|
|
|
|
type
|
|
{NEW:}
|
|
TFileBeforeWriteEvent = procedure(Sender: TObject; const FileName: string; var WriteFile: Boolean) of object;
|
|
TFileAfterWriteEvent = procedure(Sender: TObject; const FileName: string; const FileSize: Longword) of object;
|
|
|
|
TFileEvent = procedure(Sender: TObject; const FileName: string) of object;
|
|
TProgressEvent = procedure(Sender: TObject; Position, Total: Integer) of object;
|
|
|
|
TJvZlibMultiple = class(TJvComponent)
|
|
private
|
|
FStorePaths: Boolean;
|
|
FIgnoreExclusive : Boolean; // November 7, 2004 - USE WITH CAUTION !!!!!
|
|
FOnProgress: TProgressEvent;
|
|
FOnCompressingFile: TFileEvent;
|
|
FOnCompressedFile: TFileEvent;
|
|
FOnCompletedAction: TNotifyEvent;
|
|
// July 26, 2004: New improved event types for decompression: Allow user to
|
|
// skip writing of files they want skipped on extraction, and if they
|
|
// extract nothing, they can use this "nil extraction" to scan the contents
|
|
// of the file, returning the file names and sizes inside.
|
|
FOnDecompressingFile: TFileBeforeWriteEvent;
|
|
FOnDecompressedFile: TFileAfterWriteEvent;
|
|
FTerminateCompress : Boolean; // Note #1
|
|
FTerminateDecompress : Boolean; // Note #1
|
|
FCompressionPause : Boolean; // Note #1
|
|
FDecompressionPause : Boolean; // Note #1
|
|
protected
|
|
procedure AddFile(FileName, Directory, FilePath: string; DestStream: TStream);
|
|
procedure DoProgress(Position, Total: Integer); virtual;
|
|
procedure DoStopCompression; // Note #1
|
|
procedure DoStopDecompression; // Note #1
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
// compresses a list of files (can contain wildcards)
|
|
// NOTE: caller must free returned stream!
|
|
function CompressFiles(Files: TStrings): TStream; overload;
|
|
// compresses a list of files (can contain wildcards)
|
|
// and saves the compressed result to FileName
|
|
procedure CompressFiles(Files: TStrings; FileName: string); overload;
|
|
// compresses a Directory (recursing if Recursive is true)
|
|
// NOTE: caller must free returned stream!
|
|
function CompressDirectory(Directory: string; Recursive: Boolean): TStream; overload;
|
|
// compresses a Directory (recursing if Recursive is true)
|
|
// and saves the compressed result to FileName
|
|
procedure CompressDirectory(Directory: string; Recursive: Boolean; FileName: string); overload;
|
|
// decompresses FileName into Directory. If Overwrite is true, overwrites any existing files with
|
|
// the same name as those in the compressed archive.
|
|
// If RelativePaths is true, the paths in the compressed file are stripped from their drive letter
|
|
procedure DecompressFile(FileName, Directory: string; Overwrite: Boolean; const RelativePaths: Boolean = True);
|
|
// decompresses Stream into Directory optionally overwriting any existing files
|
|
// If RelativePaths is true, any paths in the stream are stripped from their drive letter
|
|
procedure ListStoredFiles(FileName : String; FileList : TStrings); // Note #2
|
|
procedure DecompressStream(Stream: TStream; Directory: string; Overwrite: Boolean; const RelativePaths: Boolean = True);
|
|
procedure StopCompression; // Note #1
|
|
procedure StopDecompression; // Note #1
|
|
property CompressionPaused : Boolean read FCompressionPause write FCompressionPause; // Note #1
|
|
property DecompressionPaused : Boolean read FDecompressionPause write FDecompressionPause; // Note #1
|
|
published
|
|
property StorePaths: Boolean read FStorePaths write FStorePaths default True;
|
|
// NOTE : This property allows you to override already opened files - USE WITH CAUTION!!! opened files may still be writing data
|
|
// causing stored files to be different from the final file.
|
|
property IgnoreExclusive : Boolean read FIgnoreExclusive write FIgnoreExclusive default False;
|
|
// NOTE: Changed decompression event parameters. July 26 2004. -WPostma.
|
|
property OnDecompressingFile: TFileBeforeWriteEvent read FOnDecompressingFile write FOnDecompressingFile;
|
|
property OnDecompressedFile: TFileAfterWriteEvent read FOnDecompressedFile write FOnDecompressedFile;
|
|
property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
|
|
property OnCompressingFile: TFileEvent read FOnCompressingFile write FOnCompressingFile;
|
|
property OnCompressedFile: TFileEvent read FOnCompressedFile write FOnCompressedFile;
|
|
property OnCompletedAction: TNotifyEvent read FOnCompletedAction write FOnCompletedAction;
|
|
end;
|
|
|
|
{$IFDEF UNITVERSIONING}
|
|
const
|
|
UnitVersioning: TUnitVersionInfo = (
|
|
RCSfile: '$RCSfile: JvZlibMultiple.pas,v $';
|
|
Revision: '$Revision: 1.28 $';
|
|
Date: '$Date: 2006/02/09 16:36:18 $';
|
|
LogPath: 'JVCL\run'
|
|
);
|
|
{$ENDIF UNITVERSIONING}
|
|
|
|
implementation
|
|
|
|
uses
|
|
JvVCL5Utils, JvJCLUtils;
|
|
|
|
{*******************************************************}
|
|
{ Format of the File: }
|
|
{ File Header }
|
|
{ 1 Byte Size of the directory variable }
|
|
{ x bytes Directory of the file }
|
|
{ 1 Byte Size of the filename }
|
|
{ x bytes Filename }
|
|
{ 4 bytes Size of the file (uncompressed) }
|
|
{ 4 bytes Size of the file (compressed) }
|
|
{ Data chunk }
|
|
{ x bytes the compressed chunk }
|
|
{*******************************************************}
|
|
|
|
constructor TJvZlibMultiple.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
FStorePaths := True;
|
|
FIgnoreExclusive := False;
|
|
end;
|
|
|
|
function TJvZlibMultiple.CompressDirectory(Directory: string; Recursive: Boolean): TStream;
|
|
|
|
procedure SearchDirectory(SDirectory: string);
|
|
var
|
|
SearchRec: TSearchRec;
|
|
Res: Integer;
|
|
begin
|
|
// (rom) this may not work for network drives and compressed files
|
|
// (rom) because of faAnyFile
|
|
Res := FindFirst(Directory + SDirectory + AllFilesMask, faAnyFile, SearchRec);
|
|
try
|
|
while Res = 0 do
|
|
begin
|
|
if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
|
|
begin
|
|
if (SearchRec.Attr and faDirectory) = 0 then
|
|
AddFile(SearchRec.Name, SDirectory, Directory + SDirectory + SearchRec.Name, Result)
|
|
else
|
|
if Recursive then
|
|
SearchDirectory(SDirectory + SearchRec.Name + PathDelim);
|
|
end;
|
|
Res := FindNext(SearchRec);
|
|
end;
|
|
finally
|
|
FindClose(SearchRec);
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
{ (RB) Letting this function create a stream is not a good idea;
|
|
see other CompressDirectory function that causes a memory leak }
|
|
Result := TMemoryStream.Create;
|
|
Directory := IncludeTrailingPathDelimiter(Directory);
|
|
SearchDirectory('');
|
|
Result.Position := 0;
|
|
end;
|
|
|
|
procedure TJvZlibMultiple.AddFile(FileName, Directory, FilePath: string;
|
|
DestStream: TStream);
|
|
var
|
|
Stream: TStream;
|
|
FileStream: TFileStream;
|
|
ZStream: TJclZLibCompressStream;
|
|
Buffer: array [0..1023] of Byte;
|
|
Count: Integer;
|
|
|
|
procedure WriteFileRecord(Directory, FileName: string; FileSize: Integer;
|
|
CompressedSize: Integer);
|
|
var
|
|
B: Byte;
|
|
Tab: array [1..256] of Char;
|
|
begin
|
|
{ (RB) Can be improved }
|
|
for B := 1 to Length(Directory) do
|
|
Tab[B] := Directory[B];
|
|
B := Length(Directory);
|
|
DestStream.Write(B, SizeOf(B));
|
|
DestStream.Write(Tab, B);
|
|
|
|
{ (RB) Can be improved }
|
|
for B := 1 to Length(FileName) do
|
|
Tab[B] := FileName[B];
|
|
B := Length(FileName);
|
|
DestStream.Write(B, SizeOf(B));
|
|
DestStream.Write(Tab, B);
|
|
|
|
DestStream.Write(FileSize, SizeOf(FileSize));
|
|
DestStream.Write(CompressedSize, SizeOf(CompressedSize));
|
|
end;
|
|
|
|
begin
|
|
Stream := TMemoryStream.Create;
|
|
if not IgnoreExclusive then
|
|
FileStream := TFileStream.Create(FilePath, fmOpenRead or fmShareDenyWrite)
|
|
else
|
|
FileStream := TFileStream.Create(FilePath, fmOpenRead or fmShareDenyNone);
|
|
try
|
|
ZStream := TJclZLibCompressStream.Create(Stream);
|
|
try
|
|
if Assigned(FOnCompressingFile) then
|
|
FOnCompressingFile(Self, FilePath);
|
|
|
|
{ (RB) ZStream has an OnProgress event, thus CopyFrom can be used }
|
|
repeat
|
|
Count := FileStream.Read(Buffer, SizeOf(Buffer));
|
|
ZStream.Write(Buffer, Count);
|
|
DoProgress(FileStream.Position, FileStream.Size);
|
|
while CompressionPaused do
|
|
Sleep(1);
|
|
until (Count = 0) or FTerminateCompress;
|
|
finally
|
|
ZStream.Free;
|
|
end;
|
|
|
|
if Assigned(FOnCompressedFile) then
|
|
FOnCompressedFile(Self, FilePath);
|
|
|
|
if StorePaths then
|
|
WriteFileRecord(Directory, FileName, FileStream.Size, Stream.Size)
|
|
else
|
|
WriteFileRecord('', FileName, FileStream.Size, Stream.Size);
|
|
|
|
DestStream.CopyFrom(Stream, 0);
|
|
finally
|
|
FileStream.Free;
|
|
Stream.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvZlibMultiple.CompressDirectory(Directory: string;
|
|
Recursive: Boolean; FileName: string);
|
|
var
|
|
TmpStream: TStream;
|
|
begin
|
|
// don't create file until we save it so we don't accidentally
|
|
// try to compress ourselves!
|
|
DeleteFile(FileName); // make sure we don't compress a previous archive into ourselves
|
|
TmpStream := CompressDirectory(Directory, Recursive);
|
|
try
|
|
TMemoryStream(TmpStream).SaveToFile(FileName);
|
|
finally
|
|
TmpStream.Free;
|
|
end;
|
|
end;
|
|
|
|
function TJvZlibMultiple.CompressFiles(Files: TStrings): TStream;
|
|
var
|
|
I: Integer;
|
|
S1, S2, Common: string;
|
|
begin
|
|
FTerminateCompress := False;
|
|
{ (RB) Letting this function create a stream is not a good idea;
|
|
see other CompressFiles function that causes a memory leak }
|
|
Result := TMemoryStream.Create;
|
|
if Files.Count = 0 then
|
|
Exit;
|
|
|
|
//Find the biggest Common part of all files
|
|
S1 := UpperCase(Files[0]);
|
|
for I := 1 to Files.Count - 1 do
|
|
begin
|
|
S2 := Files[I];
|
|
while (Pos(S1, S2) = 0) and (S1 <> '') do
|
|
S1 := Copy(S1, 1, Length(S1) - 1);
|
|
end;
|
|
{ (RB) This should be Common := S1 (?) }
|
|
Common := S2;
|
|
|
|
//Add the files to the stream
|
|
for I := 0 to Files.Count - 1 do
|
|
begin
|
|
S1 := ExtractFileName(Files[I]);
|
|
S2 := ExtractFilePath(Files[I]);
|
|
S2 := Copy(S2, 1, Length(Common));
|
|
AddFile(S1, S2, Files[I], Result);
|
|
end;
|
|
|
|
Result.Position := 0;
|
|
end;
|
|
|
|
procedure TJvZlibMultiple.CompressFiles(Files: TStrings; FileName: string);
|
|
var
|
|
TmpStream: TStream;
|
|
begin
|
|
TmpStream := CompressFiles(Files);
|
|
try
|
|
TMemoryStream(TmpStream).SaveToFile(FileName);
|
|
finally
|
|
TmpStream.Free;
|
|
end;
|
|
if Assigned(FOnCompletedAction) then
|
|
FOnCompletedAction(Self);
|
|
end;
|
|
|
|
procedure TJvZlibMultiple.DecompressStream(Stream: TStream;
|
|
Directory: string; Overwrite: Boolean; const RelativePaths: Boolean);
|
|
var
|
|
FileStream: TFileStream;
|
|
ZStream: TJclZLibDecompressStream;
|
|
CStream: TMemoryStream;
|
|
B, LastPos: Byte;
|
|
S: string;
|
|
Count, FileSize, I: Integer;
|
|
Buffer: array [0..1023] of Byte;
|
|
TotalByteCount: Longword;
|
|
WriteMe: Boolean; // Allow skipping of files instead of writing them.
|
|
begin
|
|
if Directory <> '' then
|
|
Directory := IncludeTrailingPathDelimiter(Directory);
|
|
|
|
while Stream.Position < Stream.Size do
|
|
begin
|
|
//Read and force the directory
|
|
Stream.Read(B, SizeOf(B));
|
|
SetLength(S, B);
|
|
if B > 0 then
|
|
Stream.Read(S[1], B);
|
|
ForceDirectories(Directory + S);
|
|
if S <> '' then
|
|
S := IncludeTrailingPathDelimiter(S);
|
|
|
|
//This make files decompress either on Directory or Directory+SavedRelativePath
|
|
if not RelativePaths then
|
|
S := '';
|
|
|
|
//Read filename
|
|
Stream.Read(B, SizeOf(B));
|
|
if B > 0 then
|
|
begin
|
|
LastPos := Length(S);
|
|
SetLength(S, LastPos + B);
|
|
Stream.Read(S[LastPos + 1], B);
|
|
end;
|
|
|
|
Stream.Read(FileSize, SizeOf(FileSize));
|
|
Stream.Read(I, SizeOf(I));
|
|
CStream := TMemoryStream.Create;
|
|
|
|
try
|
|
CStream.CopyFrom(Stream, I);
|
|
CStream.Position := 0;
|
|
|
|
//Decompress the file
|
|
S := Directory + S;
|
|
if Overwrite or not FileExists(S) then
|
|
begin
|
|
//This fails if Directory isn't empty
|
|
WriteMe := True;
|
|
if Assigned(FOnDecompressingFile) then
|
|
FOnDecompressingFile(Self, S, WriteMe);
|
|
|
|
if WriteMe then
|
|
FileStream := TFileStream.Create(S, fmCreate or fmShareExclusive)
|
|
else
|
|
FileStream := nil; // skip it!
|
|
|
|
ZStream := TJclZLibDecompressStream.Create(CStream);
|
|
try
|
|
TotalByteCount := 0;
|
|
|
|
{ (RB) ZStream has an OnProgress event, thus copyfrom can be used }
|
|
repeat
|
|
Count := ZStream.Read(Buffer, SizeOf(Buffer));
|
|
if Assigned(FileStream) then
|
|
begin
|
|
FileStream.Write(Buffer, Count);
|
|
DoProgress(FileStream.Size, FileSize);
|
|
while DecompressionPaused do
|
|
Sleep(1);
|
|
end;
|
|
Inc(TotalByteCount, Count);
|
|
until (Count = 0) or FTerminateDecompress;
|
|
if Assigned(FOnDecompressedFile) then
|
|
FOnDecompressedFile(Self, S, TotalByteCount);
|
|
finally
|
|
FreeAndNil(FileStream);
|
|
ZStream.Free;
|
|
end;
|
|
end;
|
|
finally
|
|
CStream.Free;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvZlibMultiple.DecompressFile(FileName, Directory: string;
|
|
Overwrite: Boolean; const RelativePaths: Boolean);
|
|
var
|
|
Stream: TFileStream;
|
|
begin
|
|
Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
|
|
try
|
|
Stream.Position := 0;
|
|
DecompressStream(Stream, Directory, Overwrite, RelativePaths);
|
|
finally
|
|
Stream.Free;
|
|
end;
|
|
if Assigned(FOnCompletedAction) then
|
|
FOnCompletedAction(Self);
|
|
end;
|
|
|
|
procedure TJvZlibMultiple.DoProgress(Position, Total: Integer);
|
|
begin
|
|
if Assigned(FOnProgress) then
|
|
FOnProgress(Self, Position, Total);
|
|
end;
|
|
|
|
procedure TJvZlibMultiple.DoStopCompression;
|
|
begin
|
|
FTerminateCompress := True;
|
|
end;
|
|
|
|
procedure TJvZlibMultiple.DoStopDecompression;
|
|
begin
|
|
FTerminateDecompress := True;
|
|
end;
|
|
|
|
procedure TJvZlibMultiple.StopCompression;
|
|
begin
|
|
DoStopCompression;
|
|
end;
|
|
|
|
procedure TJvZlibMultiple.StopDecompression;
|
|
begin
|
|
DoStopDecompression;
|
|
end;
|
|
|
|
procedure TJvZLibMultiple.ListStoredFiles(FileName: String;
|
|
FileList : TStrings);
|
|
var
|
|
ZStream : TFileStream;
|
|
FHByte : Byte;
|
|
FilePos, HeaderPos, CompressedSize, UnCompressedSize : Integer;
|
|
FileInfo : string;
|
|
begin
|
|
ZStream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
|
|
try
|
|
while ZStream.Position < ZStream.Size do
|
|
begin
|
|
ZStream.Read(FHByte, SizeOf(FHByte));
|
|
SetLength(FileInfo, FHByte);
|
|
if FHByte > 0 then
|
|
ZStream.Read(FileInfo[1], FHByte);
|
|
|
|
if FileInfo <> '' then
|
|
FileInfo := IncludeTrailingPathDelimiter(FileInfo);
|
|
ZStream.Read(FHByte, SizeOf(FHByte));
|
|
if FHByte > 0 then
|
|
begin
|
|
HeaderPos := Length(FileInfo);
|
|
SetLength(FileInfo, HeaderPos + FHByte);
|
|
ZStream.Read(FileInfo[HeaderPos + 1], FHByte);
|
|
end;
|
|
|
|
FileList.Add(FileInfo);
|
|
ZStream.Read(UncompressedSize, SizeOf(UncompressedSize));
|
|
ZStream.Read(CompressedSize, SizeOf(CompressedSize));
|
|
FilePos := ZStream.Position + CompressedSize;
|
|
ZStream.Position := FilePos;
|
|
end;
|
|
finally
|
|
ZStream.Free
|
|
end;
|
|
end;
|
|
|
|
{$IFDEF UNITVERSIONING}
|
|
initialization
|
|
RegisterUnitVersion(HInstance, UnitVersioning);
|
|
|
|
finalization
|
|
UnregisterUnitVersion(HInstance);
|
|
{$ENDIF UNITVERSIONING}
|
|
|
|
end.
|
|
|