freepascal.compiler/fcl/inc/zipper.pp

{
    $Id: header,v 1.1 2000/07/13 06:33:45 michael Exp $
    This file is part of the Free Component Library (FCL)
    Copyright (c) 1999-2000 by the Free Pascal development team

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}
{$mode objfpc}
{$h+}
unit zipper;

Interface

Uses 
   SysUtils,Classes, ZStream;


Const
   LOCAL_FILE_HEADER_SIGNATURE = $04034B50;

Type
   Local_File_Header_Type = Packed Record
     Signature              :  LongInt;
     Extract_Version_Reqd   :  Word;
     Bit_Flag               :  Word;
     Compress_Method        :  Word;
     Last_Mod_Time          :  Word;
     Last_Mod_Date          :  Word;
     Crc32                  :  LongInt;
     Compressed_Size        :  LongInt;
     Uncompressed_Size      :  LongInt;
     Filename_Length        :  Word;
     Extra_Field_Length     :  Word;
   end;

{ Define the Central Directory record types }

Const
   CENTRAL_FILE_HEADER_SIGNATURE = $02014B50;

Type
  Central_File_Header_Type = Packed Record
    Signature            :  LongInt;
    MadeBy_Version       :  Word;
    Extract_Version_Reqd :  Word;
    Bit_Flag             :  Word;
    Compress_Method      :  Word;
    Last_Mod_Time        :  Word;
    Last_Mod_Date        :  Word;
    Crc32                :  LongInt;
    Compressed_Size      :  LongInt;
    Uncompressed_Size    :  LongInt;
    Filename_Length      :  Word;
    Extra_Field_Length   :  Word;
    File_Comment_Length  :  Word;
    Starting_Disk_Num    :  Word;
    Internal_Attributes  :  Word;
    External_Attributes  :  LongInt;
    Local_Header_Offset  :  LongInt;
  End;

Const
  END_OF_CENTRAL_DIR_SIGNATURE = $06054B50;

Type
  End_of_Central_Dir_Type =  Packed Record
    Signature               :  LongInt;
    Disk_Number             :  Word;
    Central_Dir_Start_Disk  :  Word;
    Entries_This_Disk       :  Word;
    Total_Entries           :  Word;
    Central_Dir_Size        :  LongInt;
    Start_Disk_Offset       :  LongInt;
    ZipFile_Comment_Length  :  Word;
  end;

Const
  Crc_32_Tab : Array[0..255] of LongInt = (
    $00000000, $77073096, $ee0e612c, $990951ba, $076dc419, $706af48f, $e963a535, $9e6495a3,
    $0edb8832, $79dcb8a4, $e0d5e91e, $97d2d988, $09b64c2b, $7eb17cbd, $e7b82d07, $90bf1d91,
    $1db71064, $6ab020f2, $f3b97148, $84be41de, $1adad47d, $6ddde4eb, $f4d4b551, $83d385c7,
    $136c9856, $646ba8c0, $fd62f97a, $8a65c9ec, $14015c4f, $63066cd9, $fa0f3d63, $8d080df5,
    $3b6e20c8, $4c69105e, $d56041e4, $a2677172, $3c03e4d1, $4b04d447, $d20d85fd, $a50ab56b,
    $35b5a8fa, $42b2986c, $dbbbc9d6, $acbcf940, $32d86ce3, $45df5c75, $dcd60dcf, $abd13d59,
    $26d930ac, $51de003a, $c8d75180, $bfd06116, $21b4f4b5, $56b3c423, $cfba9599, $b8bda50f,
    $2802b89e, $5f058808, $c60cd9b2, $b10be924, $2f6f7c87, $58684c11, $c1611dab, $b6662d3d,
    $76dc4190, $01db7106, $98d220bc, $efd5102a, $71b18589, $06b6b51f, $9fbfe4a5, $e8b8d433,
    $7807c9a2, $0f00f934, $9609a88e, $e10e9818, $7f6a0dbb, $086d3d2d, $91646c97, $e6635c01,
    $6b6b51f4, $1c6c6162, $856530d8, $f262004e, $6c0695ed, $1b01a57b, $8208f4c1, $f50fc457,
    $65b0d9c6, $12b7e950, $8bbeb8ea, $fcb9887c, $62dd1ddf, $15da2d49, $8cd37cf3, $fbd44c65,
    $4db26158, $3ab551ce, $a3bc0074, $d4bb30e2, $4adfa541, $3dd895d7, $a4d1c46d, $d3d6f4fb,
    $4369e96a, $346ed9fc, $ad678846, $da60b8d0, $44042d73, $33031de5, $aa0a4c5f, $dd0d7cc9,
    $5005713c, $270241aa, $be0b1010, $c90c2086, $5768b525, $206f85b3, $b966d409, $ce61e49f,
    $5edef90e, $29d9c998, $b0d09822, $c7d7a8b4, $59b33d17, $2eb40d81, $b7bd5c3b, $c0ba6cad,
    $edb88320, $9abfb3b6, $03b6e20c, $74b1d29a, $ead54739, $9dd277af, $04db2615, $73dc1683,
    $e3630b12, $94643b84, $0d6d6a3e, $7a6a5aa8, $e40ecf0b, $9309ff9d, $0a00ae27, $7d079eb1,
    $f00f9344, $8708a3d2, $1e01f268, $6906c2fe, $f762575d, $806567cb, $196c3671, $6e6b06e7,
    $fed41b76, $89d32be0, $10da7a5a, $67dd4acc, $f9b9df6f, $8ebeeff9, $17b7be43, $60b08ed5,
    $d6d6a3e8, $a1d1937e, $38d8c2c4, $4fdff252, $d1bb67f1, $a6bc5767, $3fb506dd, $48b2364b,
    $d80d2bda, $af0a1b4c, $36034af6, $41047a60, $df60efc3, $a867df55, $316e8eef, $4669be79,
    $cb61b38c, $bc66831a, $256fd2a0, $5268e236, $cc0c7795, $bb0b4703, $220216b9, $5505262f,
    $c5ba3bbe, $b2bd0b28, $2bb45a92, $5cb36a04, $c2d7ffa7, $b5d0cf31, $2cd99e8b, $5bdeae1d,
    $9b64c2b0, $ec63f226, $756aa39c, $026d930a, $9c0906a9, $eb0e363f, $72076785, $05005713,
    $95bf4a82, $e2b87a14, $7bb12bae, $0cb61b38, $92d28e9b, $e5d5be0d, $7cdcefb7, $0bdbdf21,
    $86d3d2d4, $f1d4e242, $68ddb3f8, $1fda836e, $81be16cd, $f6b9265b, $6fb077e1, $18b74777,
    $88085ae6, $ff0f6a70, $66063bca, $11010b5c, $8f659eff, $f862ae69, $616bffd3, $166ccf45,
    $a00ae278, $d70dd2ee, $4e048354, $3903b3c2, $a7672661, $d06016f7, $4969474d, $3e6e77db,
    $aed16a4a, $d9d65adc, $40df0b66, $37d83bf0, $a9bcae53, $debb9ec5, $47b2cf7f, $30b5ffe9,
    $bdbdf21c, $cabac28a, $53b39330, $24b4a3a6, $bad03605, $cdd70693, $54de5729, $23d967bf,
    $b3667a2e, $c4614ab8, $5d681b02, $2a6f2b94, $b40bbe37, $c30c8ea1, $5a05df1b, $2d02ef8d
  );

Type

  TZipItem   = Class(TObject)
    Path : String;
    Name : String;
    Size : LongInt;
    DateTime : TDateTime;
  end;

  TProgressEvent = Procedure(Sender : TObject; Const Pct : Double) of object;
  TOnEndOfFileEvent = Procedure(Sender : TObject; Const Ratio : Double) of object;   
  TOnStartFileEvent = Procedure(Sender : TObject; Const AFileName : String) of object;
  
Type

  { TCompressor }
  TCompressor = Class(TObject)
  Protected
    FInFile     :  TStream;        { I/O file variables                         }
    FOutFile    :  TStream;
    FCrc32Val    :  LongInt;       { CRC calculation variable                   }
    FBufferSize : Cardinal;
    FOnPercent  : Integer;
    FOnProgress : TProgressEvent;
    Procedure UpdC32(Octet: Byte);
  Public
    Constructor Create(AInFile, AOutFile : TStream; ABufSize : Cardinal); virtual;
    Procedure Compress; Virtual; Abstract;
    Class Function ZipID : Word; virtual; Abstract;
    Property BufferSize : Cardinal read FBufferSize;
    Property OnPercent : Integer Read FOnPercent Write FOnPercent;
    Property OnProgress : TProgressEvent Read FOnProgress Write FOnProgress;
    Property Crc32Val : Longint Read FCrc32Val Write FCrc32Val;
  end;

  { TShrinker }
  
Const
   TABLESIZE   =   8191; 
   FIRSTENTRY  =    257; 

Type
  CodeRec =  Packed Record
    Child   : Smallint;
    Sibling : Smallint;
    Suffix  : Byte;
  end;
  CodeArray   =  Array[0..TABLESIZE] of CodeRec;
  TablePtr    =  ^CodeArray;

  FreeListPtr    =  ^FreeListArray;
  FreeListArray  =  Array[FIRSTENTRY..TABLESIZE] of Word;

  BufPtr      =  PByte;
  
  TShrinker = Class(TCompressor)
  Private
    FBufSize    : Cardinal;
    MaxInBufIdx :  Cardinal;      { Count of valid chars in input buffer       }
    InputEof    :  Boolean;       { End of file indicator                      }
    CodeTable   :  TablePtr;      { Points to code table for LZW compression   }
    FreeList    :  FreeListPtr;   { Table of free code table entries           }
    NextFree    :  Word;          { Index into free list table                 }

    ClearList   :  Array[0..1023] of Byte;  { Bit mapped structure used in     }
                                            {    during adaptive resets        }
    CodeSize    :  Byte;     { Size of codes (in bits) currently being written }
    MaxCode     :  Word;   { Largest code that can be written in CodeSize bits }
    InBufIdx,                     { Points to next char in buffer to be read   }
    OutBufIdx   :  Cardinal;      { Points to next free space in output buffer }
    InBuf,                        { I/O buffers                                }
    OutBuf      :  BufPtr;
    FirstCh     :  Boolean;  { Flag indicating the START of a shrink operation }
    TableFull   :  Boolean;  { Flag indicating a full symbol table             }
    SaveByte    :  Byte;     { Output code buffer                              }
    BitsUsed    :  Byte;     { Index into output code buffer                   }
    BytesIn     :  LongInt;  { Count of input file bytes processed             }
    BytesOut    :  LongInt;  { Count of output bytes                           }
    FOnBytes    : Longint;
    Procedure FillInputBuffer;
    Procedure WriteOutputBuffer;
    Procedure FlushOutput;
    Procedure PutChar(B : Byte);
    procedure PutCode(Code : Smallint);
    Procedure InitializeCodeTable;
    Procedure Prune(Parent : Word);
    Procedure Clear_Table;
    Procedure Table_Add(Prefix : Word; Suffix : Byte);
    function  Table_Lookup(TargetPrefix : Smallint;
                           TargetSuffix : Byte;
                           Var FoundAt  : Smallint) : Boolean;
    Procedure Shrink(Suffix : Smallint);
    Procedure ProcessLine(Const Source : String);
    Procedure DoOnProgress(Const Pct : Double); Virtual;
  Public
    Constructor Create(AInFile, AOutFile : TStream; ABufSize : Cardinal); override;
    Destructor Destroy; override;
    Procedure Compress; override;
    Class Function ZipID : Word; override;
  end;
  
  { TDeflater }

  TDeflater = Class(TCompressor)
  private
    FCompressionLevel: TCompressionlevel;
  Public
    Constructor Create(AInFile, AOutFile : TStream; ABufSize : Cardinal);override;
    Procedure Compress; override;
    Class Function ZipID : Word; override;
    Property CompressionLevel : TCompressionlevel Read FCompressionLevel Write FCompressionLevel;
  end;

  { TZipper }

  TZipper = Class(TObject)
  Private
    FZipping    : Boolean;
    FBufSize    : Cardinal;
    FFileName   :  String;         { Name of resulting Zip file                 }
    FFiles      : TStrings;
    FInMemSize  : Integer;
    FOutFile    : TFileStream;
    FInFile     : TFileStream;     { I/O file variables                         }
    LocalHdr    : Local_File_Header_Type;
    CentralHdr  : Central_File_Header_Type;
    EndHdr      : End_of_Central_Dir_Type;

    FOnPercent  : LongInt;
    FOnProgress : TProgressEvent;
    FOnEndOfFile : TOnEndOfFileEvent;   
    FOnStartFile : TOnStartFileEvent;
  Protected  
    Procedure OpenOutput;
    Procedure CloseOutput;
    Procedure CloseInput;
    Procedure StartZipFile(Item : TZipItem);
    Function  UpdateZipHeader(Item : TZipItem; FZip : TStream; ACRC : Integer;AMethod : Word) : Boolean;
    Procedure BuildZipDirectory;
    Procedure DoEndOfFile;
    Procedure ZipOneFile(Item : TZipItem); virtual;
    Function  OpenInput(InFileName : String) : Boolean;
    Procedure GetFileInfo;
    Procedure SetBufSize(Value : Cardinal);
    Procedure SetFileName(Value : String);
    Function CreateCompressor(Item : TZipItem; AinFile,AZipStream : TStream) : TCompressor; virtual;
  Public
    Constructor Create;
    Destructor Destroy;
    Procedure ZipAllFiles; virtual;
    Procedure ZipFiles(AFileName : String; FileList : TStrings);
    Procedure Clear;
  Public
    Property BufferSize : Cardinal Read FBufSize Write SetBufSize;
    Property OnPercent : Integer Read FOnPercent Write FOnPercent;
    Property OnProgress : TProgressEvent Read FOnProgress Write FOnProgress;
    Property OnStartFile : TOnStartFileEvent Read FOnStartFile Write FOnStartFile;
    Property OnEndFile : TOnEndOfFileEvent Read FOnEndOfFile Write FOnEndOfFile;
    Property FileName : String Read FFileName Write SetFileName;
    Property Files : TStrings Read FFiles;
    Property InMemSize : Integer Read FInMemSize Write FInMemSize;
  end;

  EZipError = Class(Exception);

Implementation

ResourceString
  SErrBufsizeChange = 'Changing buffer size is not allowed while zipping';
  SErrOutputFileChange = 'Changing output file name is not allowed while zipping';

{ ---------------------------------------------------------------------
    Auxiliary
  ---------------------------------------------------------------------}
  
Procedure DateTimeToZipDateTime(DT : TDateTime; Var ZD,ZT : Word);

Var
  Y,M,D,H,N,S,MS : Word;

begin
  DecodeDate(DT,Y,M,D);
  DecodeTime(DT,H,N,S,MS);
  Y:=Y-1980;
  ZD:=d+(32*M)+(512*Y);
  ZT:=(S div 2)+(32*N)+(2048*h);
end;

{ ---------------------------------------------------------------------
    TCompressor
  ---------------------------------------------------------------------}
  

Procedure TCompressor.UpdC32(Octet: Byte);

Begin
  FCrc32Val := Crc_32_Tab[Byte(FCrc32Val XOR LongInt(Octet))] XOR ((FCrc32Val SHR 8) AND $00FFFFFF);
end;

constructor TCompressor.Create(AInFile, AOutFile: TStream; ABufSize: Cardinal);
begin
  FinFile:=AInFile;
  FoutFile:=AOutFile;
  FBufferSize:=ABufSize;
  CRC32Val:=$FFFFFFFF;
end;


{ ---------------------------------------------------------------------
    TDeflater
  ---------------------------------------------------------------------}
  
constructor TDeflater.Create(AInFile, AOutFile: TStream; ABufSize: Cardinal);
begin
  Inherited;
  FCompressionLevel:=clDefault;
end;


procedure TDeflater.Compress;

Var
  Buf : PByte;
  I,Count,NewCount : Integer;
  C : TCompressionStream;
  
begin
  CRC32Val:=$FFFFFFFF;
  Buf:=GetMem(FBufferSize);
  Try
    C:=TCompressionStream.Create(FCompressionLevel,FOutFile,True);
    Try
      Repeat
        Count:=FInFile.Read(Buf^,FBufferSize);
        For I:=0 to Count-1 do
          UpdC32(Buf[i]);
        NewCount:=Count;
        While (NewCount>0) do
          NewCount:=NewCount-C.Write(Buf^,NewCount);
      Until (Count=0);
    Finally
      C.Free;
    end;
  Finally
    FreeMem(Buf);
  end;
  Crc32Val:=NOT Crc32Val;
end;

class function TDeflater.ZipID: Word;
begin
  Result:=8;
end;

{ ---------------------------------------------------------------------
    TShrinker
  ---------------------------------------------------------------------}

Const
   DefaultInMemSize = 256*1024; { Files larger than 256k are processed on disk   }
   DefaultBufSize =  16384;     { Use 16K file buffers                             }
   MINBITS     =      9;        { Starting code size of 9 bits                     }
   MAXBITS     =     13;        { Maximum code size of 13 bits                     }
   SPECIAL     =    256;        { Special function code                            }
   INCSIZE     =      1;        { Code indicating a jump in code size              }
   CLEARCODE   =      2;        { Code indicating code table has been cleared      }
   STDATTR     =    $23;        { Standard file attribute for DOS Find First/Next  }

constructor TShrinker.Create(AInFile, AOutFile : TStream; ABufSize : Cardinal);
begin
  Inherited;
  FBufSize:=ABufSize;
  InBuf:=GetMem(FBUFSIZE);
  OutBuf:=GetMem(FBUFSIZE);
  CodeTable:=GetMem(SizeOf(CodeTable^));
  FreeList:=GetMem(SizeOf(FreeList^));
end;

destructor TShrinker.Destroy;
begin
  FreeMem(CodeTable);
  FreeMem(FreeList);
  FreeMem(InBuf);
  FreeMem(OutBuf);
  inherited Destroy;
end;

Procedure TShrinker.Compress;

Var
   OneString : String;
   Remaining : Word;

begin
  BytesIn := 1;
  BytesOut := 1;
  InitializeCodeTable;
  FillInputBuffer;
  FirstCh:= TRUE;
  Crc32Val:=$FFFFFFFF;
  FOnBytes:=Round((FInFile.Size * FOnPercent) / 100);
  While NOT InputEof do
    begin
    Remaining:=Succ(MaxInBufIdx - InBufIdx);
    If Remaining>255 then
      Remaining:=255;
    If Remaining=0 then
      FillInputBuffer
    else
      begin
      SetLength(OneString,Remaining);
      Move(InBuf[InBufIdx], OneString[1], Remaining);
      Inc(InBufIdx, Remaining);
      ProcessLine(OneString);
      end;
    end;
   Crc32Val := NOT Crc32Val;
   ProcessLine('');
end;

class function TShrinker.ZipID: Word;
begin
  Result:=1;
end;



Procedure TShrinker.FillInputBuffer;

Begin
   MaxInbufIDx:=FInfile.Read(InBuf[0], FBufSize);
   If MaxInbufIDx=0 then
      InputEof := TRUE
   else
      InputEOF := FALSE;
   InBufIdx := 0;
end;


Procedure TShrinker.WriteOutputBuffer;
Begin
  FOutFile.WriteBuffer(OutBuf[0], OutBufIdx);
  OutBufIdx := 0;
end;


Procedure TShrinker.PutChar(B : Byte);

Begin
  OutBuf[OutBufIdx] := B;
  Inc(OutBufIdx);
  If OutBufIdx>=FBufSize then
    WriteOutputBuffer;
  Inc(BytesOut);
end;

Procedure TShrinker.FlushOutput;
Begin
  If OutBufIdx>0 then
    WriteOutputBuffer;
End;


procedure TShrinker.PutCode(Code : Smallint);

var 
  ACode : LongInt;
  XSize : Smallint;
    
begin
  if (Code=-1) then 
    begin
    if BitsUsed>0 then
      PutChar(SaveByte);
    end
  else 
    begin
    ACode := Longint(Code);
    XSize := CodeSize+BitsUsed;
    ACode := (ACode shl BitsUsed) or SaveByte;
    while (XSize div 8) > 0 do 
      begin
      PutChar(Lo(ACode));
      ACode := ACode shr 8;
      Dec(XSize,8);
      end;
    BitsUsed := XSize;
    SaveByte := Lo(ACode);
    end;
end;


Procedure TShrinker.InitializeCodeTable;

Var
   I  :  Word;
Begin
   For I := 0 to TableSize do 
     begin
     With CodeTable^[I] do 
       begin
       Child := -1;
       Sibling := -1;
       If (I<=255) then
         Suffix := I;
       end;
     If (I>=257) then
       FreeList^[I] := I;
     end;
   NextFree  := FIRSTENTRY;
   TableFull := FALSE;
end;


Procedure TShrinker.Prune(Parent : Word);

Var
   CurrChild   : Smallint;
   NextSibling : Smallint;
Begin
  CurrChild := CodeTable^[Parent].Child;
  { Find first Child that has descendants .. clear any that don't }
  While (CurrChild <> -1) AND (CodeTable^[CurrChild].Child = -1) do
    begin
    CodeTable^[Parent].Child := CodeTable^[CurrChild].Sibling;
    CodeTable^[CurrChild].Sibling := -1;
     { Turn on ClearList bit to indicate a cleared entry }
    ClearList[CurrChild DIV 8] := (ClearList[CurrChild DIV 8] OR (1 SHL (CurrChild MOD 8)));
    CurrChild := CodeTable^[Parent].Child;
    end;
  If CurrChild <> -1 then
    begin   { If there are any children left ...}
    Prune(CurrChild);
    NextSibling := CodeTable^[CurrChild].Sibling;
    While NextSibling <> -1 do
      begin
      If CodeTable^[NextSibling].Child = -1 then
        begin
        CodeTable^[CurrChild].Sibling := CodeTable^[NextSibling].Sibling;
        CodeTable^[NextSibling].Sibling := -1;
        { Turn on ClearList bit to indicate a cleared entry }
        ClearList[NextSibling DIV 8] := (ClearList[NextSibling DIV 8] OR (1 SHL (NextSibling MOD 8)));
        NextSibling := CodeTable^[CurrChild].Sibling;
        end
      else
        begin
        CurrChild := NextSibling;
        Prune(CurrChild);
        NextSibling := CodeTable^[CurrChild].Sibling;
        end;
      end;
    end;
end;


Procedure TShrinker.Clear_Table;
Var
   Node : Word;
Begin
   FillChar(ClearList, SizeOf(ClearList), $00);
   For Node := 0 to 255 do
     Prune(Node);
   NextFree := Succ(TABLESIZE);
   For Node := TABLESIZE downto FIRSTENTRY do
     begin
     If (ClearList[Node DIV 8] AND (1 SHL (Node MOD 8))) <> 0 then
       begin
       Dec(NextFree);
       FreeList^[NextFree] := Node;
       end;
     end;
   If NextFree <= TABLESIZE then
     TableFull := FALSE;
end;


Procedure TShrinker.Table_Add(Prefix : Word; Suffix : Byte);
Var
   FreeNode : Word;
Begin
  If NextFree <= TABLESIZE then
    begin
    FreeNode := FreeList^[NextFree];
    Inc(NextFree);
    CodeTable^[FreeNode].Child := -1;
    CodeTable^[FreeNode].Sibling := -1;
    CodeTable^[FreeNode].Suffix := Suffix;
    If CodeTable^[Prefix].Child  = -1 then
      CodeTable^[Prefix].Child := FreeNode
    else
      begin
      Prefix := CodeTable^[Prefix].Child;
      While CodeTable^[Prefix].Sibling <> -1 do
        Prefix := CodeTable^[Prefix].Sibling;
      CodeTable^[Prefix].Sibling := FreeNode;
      end;
    end;
  if NextFree > TABLESIZE then
    TableFull := TRUE;
end;

function TShrinker.Table_Lookup(    TargetPrefix : Smallint;
                          TargetSuffix : Byte;
                      Var FoundAt      : Smallint   ) : Boolean;

var TempPrefix : Smallint;

begin
  TempPrefix := TargetPrefix;
  Table_lookup := False;
  if CodeTable^[TempPrefix].Child <> -1 then 
    begin
    TempPrefix := CodeTable^[TempPrefix].Child;
    repeat
      if CodeTable^[TempPrefix].Suffix = TargetSuffix then 
        begin
        Table_lookup := True;
        break;
        end;
      if CodeTable^[TempPrefix].Sibling = -1 then
        break;
      TempPrefix := CodeTable^[TempPrefix].Sibling;
    until False;
  end;
  if Table_Lookup then 
    FoundAt := TempPrefix
  else 
    FoundAt := -1;
end;

Procedure TShrinker.Shrink(Suffix : Smallint);

Const
  LastCode : Smallint = 0;
  
Var
  WhereFound : Smallint;
   
Begin
  If FirstCh then
    begin
    SaveByte := $00;
    BitsUsed := 0;
    CodeSize := MINBITS;
    MaxCode  := (1 SHL CodeSize) - 1;
    LastCode := Suffix;
    FirstCh  := FALSE;
    end
  else
    begin
    If Suffix <> -1 then
      begin
      If TableFull then
        begin
        Putcode(LastCode);
        PutCode(SPECIAL);
        Putcode(CLEARCODE);
        Clear_Table;
        Table_Add(LastCode, Suffix);
        LastCode := Suffix;
        end
      else
        begin
        If Table_Lookup(LastCode, Suffix, WhereFound) then
          begin
          LastCode  := WhereFound;
          end
        else
          begin
          PutCode(LastCode);
          Table_Add(LastCode, Suffix);
          LastCode := Suffix;
          If (FreeList^[NextFree] > MaxCode) and (CodeSize < MaxBits) then
            begin
            PutCode(SPECIAL);
            PutCode(INCSIZE);
            Inc(CodeSize);
            MaxCode := (1 SHL CodeSize) -1;
            end;
          end;
        end;
      end
    else
      begin
      PutCode(LastCode);
      PutCode(-1);
      FlushOutput;
      end;
    end;
end;

Procedure TShrinker.ProcessLine(Const Source : String);

Var
  I : Word;

Begin
  If Source = '' then
    Shrink(-1)
  else
    For I := 1 to Length(Source) do
      begin
      Inc(BytesIn);
      If (Pred(BytesIn) MOD FOnBytes) = 0 then
        DoOnProgress(100 * ( BytesIn / FInFile.Size));
      UpdC32(Ord(Source[I]));
      Shrink(Ord(Source[I]));
      end;
end;

{ ---------------------------------------------------------------------
    TZipper
  ---------------------------------------------------------------------}
  

Procedure TZipper.GetFileInfo;

Var
   Info : TSearchRec;
   I       : Word;
   NewNode : TZipItem;
   

Begin
   For I := 0 to FFiles.Count-1 do
     If FindFirst(FFiles[I], STDATTR, Info)=0 then
       try
         NewNode:=TZipItem.Create;
         NewNode.Path := ExtractFilePath(FFiles[i]);
         NewNode.Name := Info.Name;
         NewNode.Size := Info.Size;
         NewNode.DateTime:=FileDateToDateTime(Info.Time);
         FFiles.Objects[i]:=NewNode;
       finally
         FindClose(Info);
       end;
end;

Procedure TZipper.OpenOutput;

Begin
  FOutFile:=TFileStream.Create(FFileName,fmCreate);
End;


Function TZipper.OpenInput(InFileName : String) : Boolean;

Begin
  FInFile:=TFileStream.Create(InFileName,fmOpenRead);
  Result:=True;
  If Assigned(FOnStartFile) then
    FOnStartFile(Self,InFileName);
End;


Procedure TZipper.CloseOutput;

Begin
  FreeAndNil(FOutFile);
end;


Procedure TZipper.CloseInput;

Begin
  FreeAndNil(FInFile);
end;


Procedure TZipper.StartZipFile(Item : TZipItem);

Begin
  FillChar(LocalHdr,SizeOf(LocalHdr),0);
  With LocalHdr do
    begin
    Signature := LOCAL_FILE_HEADER_SIGNATURE;
    Extract_Version_Reqd := 10;
    Bit_Flag := 0;
    Compress_Method := 1;
    DateTimeToZipDateTime(Item.DateTime,Last_Mod_Date,Last_Mod_Time);
    Crc32 := 0;
    Compressed_Size := 0;
    Uncompressed_Size := Item.Size;
    FileName_Length := Length(Item.Name);
    Extra_Field_Length := 0;
  end ;
End;


Function TZipper.UpdateZipHeader(Item : TZipItem; FZip : TStream; ACRC : Integer; AMethod : Word) : Boolean;

Begin
  With LocalHdr do
    begin
    Compressed_Size := FZip.Size;
    Crc32 := ACRC;
    Compress_method:=AMethod;
    Result:=Not (Compressed_Size >= Uncompressed_Size);
    If Not Result then
      begin                     { No...                          }
      Compress_Method := 0;                  { ...change stowage type      }
      Compressed_Size := Uncompressed_Size;  { ...update compressed size   }
      end;
    end;
  FOutFile.WriteBuffer(LocalHdr,SizeOf(LocalHdr));
  FOutFile.WriteBuffer(Item.Name[1],Length(Item.Name));
End;


Procedure TZipper.BuildZipDirectory;

Var
   SavePos   : LongInt;
   HdrPos    : LongInt;
   CenDirPos : LongInt;
   Entries   : Word;
   ZFileName  : ShortString;
   
Begin
   Entries := 0;
   CenDirPos := FOutFile.Position;
   FOutFile.Seek(0,soFrombeginning);             { Rewind output file }
   HdrPos := FOutFile.Position;
   FOutFile.ReadBuffer(LocalHdr, SizeOf(LocalHdr));
   Repeat
     SetLength(ZFileName,LocalHdr.FileName_Length);
     FOutFile.ReadBuffer(ZFileName[1], LocalHdr.FileName_Length);
     SavePos := FOutFile.Position;
     FillChar(CentralHdr,SizeOf(CentralHdr),0);
     With CentralHdr do 
       begin
       Signature := CENTRAL_FILE_HEADER_SIGNATURE;
       MadeBy_Version := LocalHdr.Extract_Version_Reqd;
       Move(LocalHdr.Extract_Version_Reqd, Extract_Version_Reqd, 26);
       Last_Mod_Time:=localHdr.Last_Mod_Time;
       Last_Mod_Date:=localHdr.Last_Mod_Date;
       File_Comment_Length := 0;
       Starting_Disk_Num := 0;
       Internal_Attributes := 0;
       External_Attributes := faARCHIVE;
       Local_Header_Offset := HdrPos;
       end;
     FOutFile.Seek(0,soFromEnd);
     FOutFile.WriteBuffer(CentralHdr,SizeOf(CentralHdr));
     FOutFile.WriteBuffer(ZFileName[1],Length(ZFileName));
     Inc(Entries);
     FOutFile.Seek(SavePos + LocalHdr.Compressed_Size,soFromBeginning);
     HdrPos:=FOutFile.Position;
     FOutFile.ReadBuffer(LocalHdr, SizeOf(LocalHdr));
   Until LocalHdr.Signature = CENTRAL_FILE_HEADER_SIGNATURE;
   FOutFile.Seek(0,soFromEnd);
   FillChar(EndHdr,SizeOf(EndHdr),0);
   With EndHdr do 
     begin
     Signature := END_OF_CENTRAL_DIR_SIGNATURE;
     Disk_Number := 0;
     Central_Dir_Start_Disk := 0;
     Entries_This_Disk := Entries;
     Total_Entries := Entries;
     Central_Dir_Size := FOutFile.Size-CenDirPos;
     Start_Disk_Offset := CenDirPos;
     ZipFile_Comment_Length := 0;
     FOutFile.WriteBuffer(EndHdr, SizeOf(EndHdr));
     end;
end;

Function TZipper.CreateCompressor(Item : TZipItem; AInFile,AZipStream : TStream) : TCompressor;

begin
  Result:=TDeflater.Create(AinFile,AZipStream,FBufSize);
end;

Procedure TZipper.ZipOneFile(Item : TZipItem);

Var
  CRC : Integer;
  ZMethod : Word;
  ZipStream : TStream;
  TmpFileName : String;
  
Begin
  OpenInput(Item.Path+Item.Name);
  Try
    StartZipFile(Item);
    If (FInfile.Size<=FInMemSize) then
      ZipStream:=TMemoryStream.Create
    else
      begin
      TmpFileName:=ChangeFileExt(FFileName,'.tmp');
      ZipStream:=TFileStream.Create(TmpFileName,fmCreate);
      end;
    Try
      With CreateCompressor(Item, FinFile,ZipStream) do
        Try
          OnProgress:=Self.OnProgress;
          OnPercent:=Self.OnPercent;
          Compress;
          CRC:=Crc32Val;
          ZMethod:=ZipID;
        Finally
          Free;
        end;
      If UpdateZipHeader(Item,ZipStream,CRC,ZMethod) then
        // Compressed file smaller than original file.
        FOutFile.CopyFrom(ZipStream,0)
      else
        begin
        // Original file smaller than compressed file.
        FInfile.Seek(0,soFromBeginning);
        FOutFile.CopyFrom(FInFile,0);
        end;
    finally
      ZipStream.Free;
      If (TmpFileName<>'') then
        DeleteFile(TmpFileName);
    end;
  Finally
    CloseInput;
  end;  
end;

Procedure TShrinker.DoOnProgress(Const Pct: Double);

begin
  If Assigned(FOnProgress) then
    FOnProgress(Self,Pct);
end;


Procedure TZipper.ZipAllFiles;
Var
   Item : TZipItem;
   I : Integer;
   
Begin
  FZipping:=True;
  Try
    GetFileInfo;
    OpenOutput;
    Try
      For I:=0 to FFiles.Count-1 do
        begin
        Item:=FFiles.Objects[i] as TZipItem;
        ZipOneFile(Item);
        end;
      BuildZipDirectory;
    Finally
       CloseOutput;
    end;
  finally
    FZipping:=False;
  end;
end;

  
Procedure TZipper.SetBufSize(Value : Cardinal);

begin
  If FZipping then
    Raise EZipError.Create(SErrBufsizeChange);
  If Value>=DefaultBufSize then
    FBufSize:=Value;
end;

Procedure TZipper.SetFileName(Value : String);

begin
  If FZipping then
    Raise EZipError.Create(SErrOutputFileChange);
  FFileName:=Value;
end;

Procedure TZipper.ZipFiles(AFileName : String; FileList : TStrings);

begin
  FFiles.Assign(FileList);
  FFileName:=AFileName;
  ZipAllFiles;
end;

Procedure TZipper.DoEndOfFile;

Var
  ComprPct : Double;

begin
  If (LocalHdr.Uncompressed_Size>0) then
    ComprPct := (100.0 * (LocalHdr.Uncompressed_Size - LocalHdr.Compressed_Size)) / LocalHdr.Uncompressed_Size
  else
    ComprPct := 0;
  If Assigned(FOnEndOfFile) then
    FOnEndOfFile(Self,ComprPct);
end;

Constructor TZipper.Create;

begin
  FBufSize:=DefaultBufSize;
  FInMemSize:=DefaultInMemSize;
  FFiles:=TStringList.Create;
  TStringlist(FFiles).Sorted:=True;
  FOnPercent:=1;
end;

Procedure TZipper.Clear;

Var
  I : Integer;

begin
  For I:=0 to FFiles.Count-1 do
    FFiles.Objects[i].Free;
  FFiles.Clear;  
end;

Destructor TZipper.Destroy;
 
begin
  Clear;
  FreeAndNil(FFiles);
  Inherited;
end;

End.