340 lines
10 KiB
ObjectPascal
340 lines
10 KiB
ObjectPascal
(* ***** BEGIN LICENSE BLOCK *****
|
|
* Version: MPL 1.1
|
|
*
|
|
* 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/
|
|
*
|
|
* Software distributed under the License is distributed on an "AS IS" basis,
|
|
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
|
|
* for the specific language governing rights and limitations under the
|
|
* License.
|
|
*
|
|
* The Original Code is TurboPower Abbrevia
|
|
*
|
|
* The Initial Developer of the Original Code is
|
|
* TurboPower Software
|
|
*
|
|
* Portions created by the Initial Developer are Copyright (C) 1997-2002
|
|
* the Initial Developer. All Rights Reserved.
|
|
*
|
|
* Contributor(s):
|
|
*
|
|
* ***** END LICENSE BLOCK ***** *)
|
|
|
|
{*********************************************************}
|
|
{* ABBREVIA: AbZipPrc.pas *}
|
|
{*********************************************************}
|
|
{* ABBREVIA: TABZipHelper class *}
|
|
{*********************************************************}
|
|
|
|
unit AbZipPrc;
|
|
|
|
{$I AbDefine.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes,
|
|
AbZipTyp;
|
|
|
|
procedure AbZip( Sender : TAbZipArchive; Item : TAbZipItem;
|
|
OutStream : TStream );
|
|
|
|
procedure AbZipFromStream(Sender : TAbZipArchive; Item : TAbZipItem;
|
|
OutStream, InStream : TStream);
|
|
|
|
procedure DeflateStream( UncompressedStream, CompressedStream : TStream );
|
|
{-Deflates everything in UncompressedStream to CompressedStream
|
|
no encryption is tried, no check on CRC is done, uses the whole
|
|
compressedstream - no Progress events - no Frills! }
|
|
|
|
implementation
|
|
|
|
uses
|
|
{$IFDEF MSWINDOWS}
|
|
Windows,
|
|
{$ENDIF}
|
|
{$IFDEF LibcAPI}
|
|
Libc,
|
|
{$ENDIF}
|
|
SysUtils,
|
|
AbArcTyp,
|
|
AbExcept,
|
|
AbUtils,
|
|
AbDfCryS,
|
|
AbVMStrm,
|
|
AbDfBase,
|
|
AbDfEnc,
|
|
AbSpanSt;
|
|
|
|
|
|
{ ========================================================================== }
|
|
procedure DoDeflate(Archive : TAbZipArchive; Item : TAbZipItem; OutStream, InStream : TStream);
|
|
const
|
|
DEFLATE_NORMAL_MASK = $00;
|
|
DEFLATE_MAXIMUM_MASK = $02;
|
|
DEFLATE_FAST_MASK = $04;
|
|
DEFLATE_SUPERFAST_MASK = $06;
|
|
var
|
|
Hlpr : TAbDeflateHelper;
|
|
begin
|
|
Item.CompressionMethod := cmDeflated;
|
|
|
|
Hlpr := TAbDeflateHelper.Create;
|
|
|
|
{anything dealing with store options, etc. should already be done.}
|
|
|
|
try {Hlpr}
|
|
Hlpr.StreamSize := InStream.Size;
|
|
|
|
{ set deflation level desired }
|
|
Hlpr.PKZipOption := '0';
|
|
|
|
case Archive.DeflationOption of
|
|
doNormal : begin
|
|
Hlpr.PKZipOption := 'n';
|
|
Item.GeneralPurposeBitFlag :=
|
|
Item.GeneralPurposeBitFlag or DEFLATE_NORMAL_MASK;
|
|
end;
|
|
|
|
doMaximum : begin
|
|
Hlpr.PKZipOption := 'x';
|
|
Item.GeneralPurposeBitFlag :=
|
|
Item.GeneralPurposeBitFlag or DEFLATE_MAXIMUM_MASK;
|
|
end;
|
|
|
|
doFast : begin
|
|
Hlpr.PKZipOption := 'f';
|
|
Item.GeneralPurposeBitFlag :=
|
|
Item.GeneralPurposeBitFlag or DEFLATE_FAST_MASK;
|
|
end;
|
|
|
|
doSuperFast : begin
|
|
Hlpr.PKZipOption := 's';
|
|
Item.GeneralPurposeBitFlag :=
|
|
Item.GeneralPurposeBitFlag or DEFLATE_SUPERFAST_MASK;
|
|
end;
|
|
end;
|
|
|
|
{ attach progress notification method }
|
|
Hlpr.OnProgressStep := Archive.DoInflateProgress;
|
|
|
|
{ provide encryption check value }
|
|
Item.CRC32 := Deflate(InStream, OutStream, Hlpr);
|
|
|
|
finally {Hlpr}
|
|
Hlpr.Free;
|
|
end; {Hlpr}
|
|
end;
|
|
{ ========================================================================== }
|
|
procedure DoStore(Archive : TAbZipArchive; Item : TAbZipItem; OutStream, InStream : TStream);
|
|
var
|
|
CRC32 : LongInt;
|
|
Percent : LongInt;
|
|
LastPercent : LongInt;
|
|
InSize : Int64;
|
|
DataRead : Int64;
|
|
Total : Int64;
|
|
Abort : Boolean;
|
|
Buffer : array [0..8191] of byte;
|
|
begin
|
|
{ setup }
|
|
Item.CompressionMethod := cmStored;
|
|
Abort := False;
|
|
CRC32 := -1;
|
|
Total := 0;
|
|
Percent := 0;
|
|
LastPercent := 0;
|
|
InSize := InStream.Size;
|
|
|
|
{ get first bufferful }
|
|
DataRead := InStream.Read(Buffer, SizeOf(Buffer));
|
|
{ while more data has been read and we're not told to bail }
|
|
while (DataRead <> 0) and not Abort do begin
|
|
{report the progress}
|
|
if Assigned(Archive.OnProgress) then begin
|
|
Total := Total + DataRead;
|
|
Percent := Round((100.0 * Total) / InSize);
|
|
if (LastPercent <> Percent) then
|
|
Archive.OnProgress(Percent, Abort);
|
|
LastPercent := Percent;
|
|
end;
|
|
|
|
{ update CRC}
|
|
AbUpdateCRCBuffer(CRC32, Buffer, DataRead);
|
|
|
|
{ write data (encrypting if needed) }
|
|
OutStream.WriteBuffer(Buffer, DataRead);
|
|
|
|
{ get next bufferful }
|
|
DataRead := InStream.Read(Buffer, SizeOf(Buffer));
|
|
end;
|
|
|
|
{ finish CRC calculation }
|
|
Item.CRC32 := not CRC32;
|
|
|
|
{ show final progress increment }
|
|
if (Percent < 100) and Assigned(Archive.OnProgress) then
|
|
Archive.OnProgress(100, Abort);
|
|
|
|
{ User wants to bail }
|
|
if Abort then begin
|
|
raise EAbUserAbort.Create;
|
|
end;
|
|
|
|
end;
|
|
{ ========================================================================== }
|
|
procedure DoZipFromStream(Sender : TAbZipArchive; Item : TAbZipItem;
|
|
OutStream, InStream : TStream);
|
|
var
|
|
ZipArchive : TAbZipArchive;
|
|
InStartPos : LongInt;
|
|
TempOut : TAbVirtualMemoryStream;
|
|
DestStrm : TStream;
|
|
begin
|
|
ZipArchive := TAbZipArchive(Sender);
|
|
|
|
{ configure Item }
|
|
Item.UncompressedSize := InStream.Size;
|
|
Item.GeneralPurposeBitFlag := Item.GeneralPurposeBitFlag and AbLanguageEncodingFlag;
|
|
|
|
if ZipArchive.Password <> '' then { encrypt the stream }
|
|
DestStrm := TAbDfEncryptStream.Create(OutStream,
|
|
LongInt(Item.LastModFileTime shl $10),
|
|
ZipArchive.Password)
|
|
else
|
|
DestStrm := OutStream;
|
|
try
|
|
if InStream.Size > 0 then begin
|
|
|
|
{ determine how to store Item based on specified CompressionMethodToUse }
|
|
case ZipArchive.CompressionMethodToUse of
|
|
smDeflated : begin
|
|
{ Item is to be deflated regarless }
|
|
{ deflate item }
|
|
DoDeflate(ZipArchive, Item, DestStrm, InStream);
|
|
end;
|
|
|
|
smStored : begin
|
|
{ Item is to be stored regardless }
|
|
{ store item }
|
|
DoStore(ZipArchive, Item, DestStrm, InStream);
|
|
end;
|
|
|
|
smBestMethod : begin
|
|
{ Item is to be archived using method producing best compression }
|
|
TempOut := TAbVirtualMemoryStream.Create;
|
|
try
|
|
TempOut.SwapFileDirectory := Sender.TempDirectory;
|
|
|
|
{ save starting points }
|
|
InStartPos := InStream.Position;
|
|
|
|
{ try deflating item }
|
|
DoDeflate(ZipArchive, Item, TempOut, InStream);
|
|
{ if deflated size > input size then got negative compression }
|
|
{ so storing the item is more efficient }
|
|
|
|
if TempOut.Size > InStream.Size then begin { store item instead }
|
|
{ reset streams to original positions }
|
|
InStream.Position := InStartPos;
|
|
TempOut.Free;
|
|
TempOut := TAbVirtualMemoryStream.Create;
|
|
TempOut.SwapFileDirectory := Sender.TempDirectory;
|
|
|
|
{ store item }
|
|
DoStore(ZipArchive, Item, TempOut, InStream);
|
|
end {if};
|
|
|
|
TempOut.Seek(0, soBeginning);
|
|
DestStrm.CopyFrom(TempOut, TempOut.Size);
|
|
finally
|
|
TempOut.Free;
|
|
end;
|
|
end;
|
|
end; { case }
|
|
|
|
end
|
|
else begin
|
|
{ InStream is zero length}
|
|
Item.CRC32 := 0;
|
|
{ ignore any storage indicator and treat as stored }
|
|
DoStore(ZipArchive, Item, DestStrm, InStream);
|
|
end;
|
|
finally
|
|
if DestStrm <> OutStream then
|
|
DestStrm.Free;
|
|
end;
|
|
|
|
{ update item }
|
|
Item.CompressedSize := OutStream.Size;
|
|
Item.InternalFileAttributes := 0; { don't care }
|
|
if (ZipArchive.Password <> '') then
|
|
Item.GeneralPurposeBitFlag := Item.GeneralPurposeBitFlag
|
|
or AbFileIsEncryptedFlag or AbHasDataDescriptorFlag;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure AbZipFromStream(Sender : TAbZipArchive; Item : TAbZipItem;
|
|
OutStream, InStream : TStream);
|
|
var
|
|
FileTimeStamp : LongInt;
|
|
begin
|
|
// Set item properties for non-file streams
|
|
Item.ExternalFileAttributes := 0;
|
|
FileTimeStamp := DateTimeToFileDate(SysUtils.Now);
|
|
Item.LastModFileTime := LongRec(FileTimeStamp).Lo;
|
|
Item.LastModFileDate := LongRec(FileTimeStamp).Hi;
|
|
|
|
DoZipFromStream(Sender, Item, OutStream, InStream);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure AbZip( Sender : TAbZipArchive; Item : TAbZipItem;
|
|
OutStream : TStream );
|
|
var
|
|
UncompressedStream : TStream;
|
|
SaveDir : string;
|
|
AttrEx : TAbAttrExRec;
|
|
begin
|
|
UncompressedStream := nil;
|
|
GetDir(0, SaveDir);
|
|
try {SaveDir}
|
|
if (Sender.BaseDirectory <> '') then
|
|
ChDir(Sender.BaseDirectory);
|
|
if not AbFileGetAttrEx(Item.DiskFileName, AttrEx) then
|
|
raise EAbFileNotFound.Create;
|
|
if ((AttrEx.Attr and faDirectory) <> 0) then
|
|
UncompressedStream := TMemoryStream.Create
|
|
else
|
|
UncompressedStream :=
|
|
TFileStream.Create(Item.DiskFileName, fmOpenRead or fmShareDenyWrite);
|
|
finally {SaveDir}
|
|
ChDir( SaveDir );
|
|
end; {SaveDir}
|
|
try {UncompressedStream}
|
|
{$IFDEF UNIX}
|
|
Item.ExternalFileAttributes := LongWord(AttrEx.Mode) shl 16 + LongWord(AttrEx.Attr);
|
|
{$ELSE}
|
|
Item.ExternalFileAttributes := AttrEx.Attr;
|
|
{$ENDIF}
|
|
Item.LastModTimeAsDateTime := AttrEx.Time;
|
|
DoZipFromStream(Sender, Item, OutStream, UncompressedStream);
|
|
finally {UncompressedStream}
|
|
UncompressedStream.Free;
|
|
end; {UncompressedStream}
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure DeflateStream( UncompressedStream, CompressedStream : TStream );
|
|
{-Deflates everything in CompressedStream to UncompressedStream
|
|
no encryption is tried, no check on CRC is done, uses the whole
|
|
Uncompressedstream - no Progress events - no Frills!
|
|
}
|
|
begin
|
|
Deflate(UncompressedStream, CompressedStream, nil);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
|
|
end.
|
|
|