← Back to branch summary

~ubuntu-branches/debian/lenny/fpc/lenny

« back to all changes in this revision

Viewing changes to fpcsrc/packages/fcl-base/src/inc/zipper.pp

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-05-17 17:12:11 UTC
  • mfrom: (3.1.9 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080517171211-9qi33xhd9evfa0kg
Tags: 2.2.0-dfsg1-9
http://bugs.debian.org/477743
[ Torsten Werner ]
* Add Mazen Neifer to Uploaders field.

[ Mazen Neifer ]
* Moved FPC sources into a version dependent directory from /usr/share/fpcsrc
  to /usr/share/fpcsrc/${FPCVERSION}. This allow installing more than on FPC
  release.
* Fixed far call issue in compiler preventing building huge binearies.
  (closes: #477743)
* Updated building dependencies, recomennded and suggested packages.
* Moved fppkg to fp-utils as it is just a helper tool and is not required by
  compiler.

Show diffs side-by-side

added added

removed removed

Lines of Context:
fpcsrc/packages/fcl-base/src/inc/zipper.pp
 
1
{
 
2
    $Id: header,v 1.1 2000/07/13 06:33:45 michael Exp $
 
3
    This file is part of the Free Component Library (FCL)
 
4
    Copyright (c) 1999-2000 by the Free Pascal development team
 
5
 
 
6
    See the file COPYING.FPC, included in this distribution,
 
7
    for details about the copyright.
 
8
 
 
9
    This program is distributed in the hope that it will be useful,
 
10
    but WITHOUT ANY WARRANTY; without even the implied warranty of
 
11
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 
12
 
 
13
 **********************************************************************}
 
14
{$mode objfpc}
 
15
{$h+}
 
16
unit zipper;
 
17
 
 
18
Interface
 
19
 
 
20
Uses
 
21
   SysUtils,Classes,Contnrs,ZStream;
 
22
 
 
23
 
 
24
Const
 
25
  { Signatures }
 
26
{$ifdef FPC_BIG_ENDIAN}
 
27
  END_OF_CENTRAL_DIR_SIGNATURE  = $504B0506;
 
28
  LOCAL_FILE_HEADER_SIGNATURE   = $504B0304;
 
29
  CENTRAL_FILE_HEADER_SIGNATURE = $504B0102;
 
30
{$else FPC_BIG_ENDIAN}
 
31
  END_OF_CENTRAL_DIR_SIGNATURE  = $06054B50;
 
32
  LOCAL_FILE_HEADER_SIGNATURE   = $04034B50;
 
33
  CENTRAL_FILE_HEADER_SIGNATURE = $02014B50;
 
34
{$endif FPC_BIG_ENDIAN}
 
35
 
 
36
Type
 
37
   Local_File_Header_Type = Packed Record
 
38
     Signature              :  LongInt;
 
39
     Extract_Version_Reqd   :  Word;
 
40
     Bit_Flag               :  Word;
 
41
     Compress_Method        :  Word;
 
42
     Last_Mod_Time          :  Word;
 
43
     Last_Mod_Date          :  Word;
 
44
     Crc32                  :  LongWord;
 
45
     Compressed_Size        :  LongInt;
 
46
     Uncompressed_Size      :  LongInt;
 
47
     Filename_Length        :  Word;
 
48
     Extra_Field_Length     :  Word;
 
49
   end;
 
50
 
 
51
  { Define the Central Directory record types }
 
52
 
 
53
  Central_File_Header_Type = Packed Record
 
54
    Signature            :  LongInt;
 
55
    MadeBy_Version       :  Word;
 
56
    Extract_Version_Reqd :  Word;
 
57
    Bit_Flag             :  Word;
 
58
    Compress_Method      :  Word;
 
59
    Last_Mod_Time        :  Word;
 
60
    Last_Mod_Date        :  Word;
 
61
    Crc32                :  LongWord;
 
62
    Compressed_Size      :  LongInt;
 
63
    Uncompressed_Size    :  LongInt;
 
64
    Filename_Length      :  Word;
 
65
    Extra_Field_Length   :  Word;
 
66
    File_Comment_Length  :  Word;
 
67
    Starting_Disk_Num    :  Word;
 
68
    Internal_Attributes  :  Word;
 
69
    External_Attributes  :  LongInt;
 
70
    Local_Header_Offset  :  LongInt;
 
71
  End;
 
72
 
 
73
  End_of_Central_Dir_Type =  Packed Record
 
74
    Signature               :  LongInt;
 
75
    Disk_Number             :  Word;
 
76
    Central_Dir_Start_Disk  :  Word;
 
77
    Entries_This_Disk       :  Word;
 
78
    Total_Entries           :  Word;
 
79
    Central_Dir_Size        :  LongInt;
 
80
    Start_Disk_Offset       :  LongInt;
 
81
    ZipFile_Comment_Length  :  Word;
 
82
  end;
 
83
 
 
84
Const
 
85
  Crc_32_Tab : Array[0..255] of LongWord = (
 
86
    $00000000, $77073096, $ee0e612c, $990951ba, $076dc419, $706af48f, $e963a535, $9e6495a3,
 
87
    $0edb8832, $79dcb8a4, $e0d5e91e, $97d2d988, $09b64c2b, $7eb17cbd, $e7b82d07, $90bf1d91,
 
88
    $1db71064, $6ab020f2, $f3b97148, $84be41de, $1adad47d, $6ddde4eb, $f4d4b551, $83d385c7,
 
89
    $136c9856, $646ba8c0, $fd62f97a, $8a65c9ec, $14015c4f, $63066cd9, $fa0f3d63, $8d080df5,
 
90
    $3b6e20c8, $4c69105e, $d56041e4, $a2677172, $3c03e4d1, $4b04d447, $d20d85fd, $a50ab56b,
 
91
    $35b5a8fa, $42b2986c, $dbbbc9d6, $acbcf940, $32d86ce3, $45df5c75, $dcd60dcf, $abd13d59,
 
92
    $26d930ac, $51de003a, $c8d75180, $bfd06116, $21b4f4b5, $56b3c423, $cfba9599, $b8bda50f,
 
93
    $2802b89e, $5f058808, $c60cd9b2, $b10be924, $2f6f7c87, $58684c11, $c1611dab, $b6662d3d,
 
94
    $76dc4190, $01db7106, $98d220bc, $efd5102a, $71b18589, $06b6b51f, $9fbfe4a5, $e8b8d433,
 
95
    $7807c9a2, $0f00f934, $9609a88e, $e10e9818, $7f6a0dbb, $086d3d2d, $91646c97, $e6635c01,
 
96
    $6b6b51f4, $1c6c6162, $856530d8, $f262004e, $6c0695ed, $1b01a57b, $8208f4c1, $f50fc457,
 
97
    $65b0d9c6, $12b7e950, $8bbeb8ea, $fcb9887c, $62dd1ddf, $15da2d49, $8cd37cf3, $fbd44c65,
 
98
    $4db26158, $3ab551ce, $a3bc0074, $d4bb30e2, $4adfa541, $3dd895d7, $a4d1c46d, $d3d6f4fb,
 
99
    $4369e96a, $346ed9fc, $ad678846, $da60b8d0, $44042d73, $33031de5, $aa0a4c5f, $dd0d7cc9,
 
100
    $5005713c, $270241aa, $be0b1010, $c90c2086, $5768b525, $206f85b3, $b966d409, $ce61e49f,
 
101
    $5edef90e, $29d9c998, $b0d09822, $c7d7a8b4, $59b33d17, $2eb40d81, $b7bd5c3b, $c0ba6cad,
 
102
    $edb88320, $9abfb3b6, $03b6e20c, $74b1d29a, $ead54739, $9dd277af, $04db2615, $73dc1683,
 
103
    $e3630b12, $94643b84, $0d6d6a3e, $7a6a5aa8, $e40ecf0b, $9309ff9d, $0a00ae27, $7d079eb1,
 
104
    $f00f9344, $8708a3d2, $1e01f268, $6906c2fe, $f762575d, $806567cb, $196c3671, $6e6b06e7,
 
105
    $fed41b76, $89d32be0, $10da7a5a, $67dd4acc, $f9b9df6f, $8ebeeff9, $17b7be43, $60b08ed5,
 
106
    $d6d6a3e8, $a1d1937e, $38d8c2c4, $4fdff252, $d1bb67f1, $a6bc5767, $3fb506dd, $48b2364b,
 
107
    $d80d2bda, $af0a1b4c, $36034af6, $41047a60, $df60efc3, $a867df55, $316e8eef, $4669be79,
 
108
    $cb61b38c, $bc66831a, $256fd2a0, $5268e236, $cc0c7795, $bb0b4703, $220216b9, $5505262f,
 
109
    $c5ba3bbe, $b2bd0b28, $2bb45a92, $5cb36a04, $c2d7ffa7, $b5d0cf31, $2cd99e8b, $5bdeae1d,
 
110
    $9b64c2b0, $ec63f226, $756aa39c, $026d930a, $9c0906a9, $eb0e363f, $72076785, $05005713,
 
111
    $95bf4a82, $e2b87a14, $7bb12bae, $0cb61b38, $92d28e9b, $e5d5be0d, $7cdcefb7, $0bdbdf21,
 
112
    $86d3d2d4, $f1d4e242, $68ddb3f8, $1fda836e, $81be16cd, $f6b9265b, $6fb077e1, $18b74777,
 
113
    $88085ae6, $ff0f6a70, $66063bca, $11010b5c, $8f659eff, $f862ae69, $616bffd3, $166ccf45,
 
114
    $a00ae278, $d70dd2ee, $4e048354, $3903b3c2, $a7672661, $d06016f7, $4969474d, $3e6e77db,
 
115
    $aed16a4a, $d9d65adc, $40df0b66, $37d83bf0, $a9bcae53, $debb9ec5, $47b2cf7f, $30b5ffe9,
 
116
    $bdbdf21c, $cabac28a, $53b39330, $24b4a3a6, $bad03605, $cdd70693, $54de5729, $23d967bf,
 
117
    $b3667a2e, $c4614ab8, $5d681b02, $2a6f2b94, $b40bbe37, $c30c8ea1, $5a05df1b, $2d02ef8d
 
118
  );
 
119
 
 
120
Type
 
121
 
 
122
  TZipItem   = Class(TObject)
 
123
    Path : String;
 
124
    Name : String;
 
125
    Size : LongInt;
 
126
    DateTime : TDateTime;
 
127
    HdrPos : Longint;
 
128
  end;
 
129
 
 
130
  TProgressEvent = Procedure(Sender : TObject; Const Pct : Double) of object;
 
131
  TOnEndOfFileEvent = Procedure(Sender : TObject; Const Ratio : Double) of object;
 
132
  TOnStartFileEvent = Procedure(Sender : TObject; Const AFileName : String) of object;
 
133
 
 
134
Type
 
135
 
 
136
  { TCompressor }
 
137
  TCompressor = Class(TObject)
 
138
  Protected
 
139
    FInFile     : TStream;        { I/O file variables                         }
 
140
    FOutFile    : TStream;
 
141
    FCrc32Val   : LongWord;       { CRC calculation variable                   }
 
142
    FBufferSize : LongWord;
 
143
    FOnPercent  : Integer;
 
144
    FOnProgress : TProgressEvent;
 
145
    Procedure UpdC32(Octet: Byte);
 
146
  Public
 
147
    Constructor Create(AInFile, AOutFile : TStream; ABufSize : LongWord); virtual;
 
148
    Procedure Compress; Virtual; Abstract;
 
149
    Class Function ZipID : Word; virtual; Abstract;
 
150
    Property BufferSize : LongWord read FBufferSize;
 
151
    Property OnPercent : Integer Read FOnPercent Write FOnPercent;
 
152
    Property OnProgress : TProgressEvent Read FOnProgress Write FOnProgress;
 
153
    Property Crc32Val : LongWord Read FCrc32Val Write FCrc32Val;
 
154
  end;
 
155
 
 
156
  { TDeCompressor }
 
157
  TDeCompressor = Class(TObject)
 
158
  Protected
 
159
    FInFile     : TStream;        { I/O file variables                         }
 
160
    FOutFile    : TStream;
 
161
    FCrc32Val   : LongWord;       { CRC calculation variable                   }
 
162
    FBufferSize : LongWord;
 
163
    FOnPercent  : Integer;
 
164
    FOnProgress : TProgressEvent;
 
165
    Procedure UpdC32(Octet: Byte);
 
166
  Public
 
167
    Constructor Create(AInFile, AOutFile : TStream; ABufSize : LongWord); virtual;
 
168
    Procedure DeCompress; Virtual; Abstract;
 
169
    Class Function ZipID : Word; virtual; Abstract;
 
170
    Property BufferSize : LongWord read FBufferSize;
 
171
    Property OnPercent : Integer Read FOnPercent Write FOnPercent;
 
172
    Property OnProgress : TProgressEvent Read FOnProgress Write FOnProgress;
 
173
    Property Crc32Val : LongWord Read FCrc32Val Write FCrc32Val;
 
174
  end;
 
175
 
 
176
  { TShrinker }
 
177
 
 
178
Const
 
179
   TABLESIZE   =   8191;
 
180
   FIRSTENTRY  =    257;
 
181
 
 
182
Type
 
183
  CodeRec =  Packed Record
 
184
    Child   : Smallint;
 
185
    Sibling : Smallint;
 
186
    Suffix  : Byte;
 
187
  end;
 
188
  CodeArray   =  Array[0..TABLESIZE] of CodeRec;
 
189
  TablePtr    =  ^CodeArray;
 
190
 
 
191
  FreeListPtr    =  ^FreeListArray;
 
192
  FreeListArray  =  Array[FIRSTENTRY..TABLESIZE] of Word;
 
193
 
 
194
  BufPtr      =  PByte;
 
195
 
 
196
  TShrinker = Class(TCompressor)
 
197
  Private
 
198
    FBufSize    : LongWord;
 
199
    MaxInBufIdx :  LongWord;      { Count of valid chars in input buffer       }
 
200
    InputEof    :  Boolean;       { End of file indicator                      }
 
201
    CodeTable   :  TablePtr;      { Points to code table for LZW compression   }
 
202
    FreeList    :  FreeListPtr;   { Table of free code table entries           }
 
203
    NextFree    :  Word;          { Index into free list table                 }
 
204
 
 
205
    ClearList   :  Array[0..1023] of Byte;  { Bit mapped structure used in     }
 
206
                                            {    during adaptive resets        }
 
207
    CodeSize    :  Byte;     { Size of codes (in bits) currently being written }
 
208
    MaxCode     :  Word;   { Largest code that can be written in CodeSize bits }
 
209
    InBufIdx,                     { Points to next char in buffer to be read   }
 
210
    OutBufIdx   :  LongWord;      { Points to next free space in output buffer }
 
211
    InBuf,                        { I/O buffers                                }
 
212
    OutBuf      :  BufPtr;
 
213
    FirstCh     :  Boolean;  { Flag indicating the START of a shrink operation }
 
214
    TableFull   :  Boolean;  { Flag indicating a full symbol table             }
 
215
    SaveByte    :  Byte;     { Output code buffer                              }
 
216
    BitsUsed    :  Byte;     { Index into output code buffer                   }
 
217
    BytesIn     :  LongInt;  { Count of input file bytes processed             }
 
218
    BytesOut    :  LongInt;  { Count of output bytes                           }
 
219
    FOnBytes    : Longint;
 
220
    Procedure FillInputBuffer;
 
221
    Procedure WriteOutputBuffer;
 
222
    Procedure FlushOutput;
 
223
    Procedure PutChar(B : Byte);
 
224
    procedure PutCode(Code : Smallint);
 
225
    Procedure InitializeCodeTable;
 
226
    Procedure Prune(Parent : Word);
 
227
    Procedure Clear_Table;
 
228
    Procedure Table_Add(Prefix : Word; Suffix : Byte);
 
229
    function  Table_Lookup(TargetPrefix : Smallint;
 
230
                           TargetSuffix : Byte;
 
231
                           Out FoundAt  : Smallint) : Boolean;
 
232
    Procedure Shrink(Suffix : Smallint);
 
233
    Procedure ProcessLine(Const Source : String);
 
234
    Procedure DoOnProgress(Const Pct : Double); Virtual;
 
235
  Public
 
236
    Constructor Create(AInFile, AOutFile : TStream; ABufSize : LongWord); override;
 
237
    Destructor Destroy; override;
 
238
    Procedure Compress; override;
 
239
    Class Function ZipID : Word; override;
 
240
  end;
 
241
 
 
242
  { TDeflater }
 
243
 
 
244
  TDeflater = Class(TCompressor)
 
245
  private
 
246
    FCompressionLevel: TCompressionlevel;
 
247
  Public
 
248
    Constructor Create(AInFile, AOutFile : TStream; ABufSize : LongWord);override;
 
249
    Procedure Compress; override;
 
250
    Class Function ZipID : Word; override;
 
251
    Property CompressionLevel : TCompressionlevel Read FCompressionLevel Write FCompressionLevel;
 
252
  end;
 
253
 
 
254
  { TInflater }
 
255
 
 
256
  TInflater = Class(TDeCompressor)
 
257
  Public
 
258
    Constructor Create(AInFile, AOutFile : TStream; ABufSize : LongWord);override;
 
259
    Procedure DeCompress; override;
 
260
    Class Function ZipID : Word; override;
 
261
  end;
 
262
 
 
263
  { TZipper }
 
264
 
 
265
  TZipper = Class(TObject)
 
266
  Private
 
267
    FZipping    : Boolean;
 
268
    FBufSize    : LongWord;
 
269
    FFileName   :  String;         { Name of resulting Zip file                 }
 
270
    FFiles      : TStrings;
 
271
    FInMemSize  : Integer;
 
272
    FOutFile    : TFileStream;
 
273
    FInFile     : TFileStream;     { I/O file variables                         }
 
274
    LocalHdr    : Local_File_Header_Type;
 
275
    CentralHdr  : Central_File_Header_Type;
 
276
    EndHdr      : End_of_Central_Dir_Type;
 
277
    FOnPercent  : LongInt;
 
278
    FOnProgress : TProgressEvent;
 
279
    FOnEndOfFile : TOnEndOfFileEvent;
 
280
    FOnStartFile : TOnStartFileEvent;
 
281
  Protected
 
282
    Procedure OpenOutput;
 
283
    Procedure CloseOutput;
 
284
    Procedure CloseInput;
 
285
    Procedure StartZipFile(Item : TZipItem);
 
286
    Function  UpdateZipHeader(Item : TZipItem; FZip : TStream; ACRC : LongWord;AMethod : Word) : Boolean;
 
287
    Procedure BuildZipDirectory;
 
288
    Procedure DoEndOfFile;
 
289
    Procedure ZipOneFile(Item : TZipItem); virtual;
 
290
    Function  OpenInput(InFileName : String) : Boolean;
 
291
    Procedure GetFileInfo;
 
292
    Procedure SetBufSize(Value : LongWord);
 
293
    Procedure SetFileName(Value : String);
 
294
    Function CreateCompressor(Item : TZipItem; AinFile,AZipStream : TStream) : TCompressor; virtual;
 
295
  Public
 
296
    Constructor Create;
 
297
    Destructor Destroy;override;
 
298
    Procedure ZipAllFiles; virtual;
 
299
    Procedure ZipFiles(AFileName : String; FileList : TStrings);
 
300
    Procedure Clear;
 
301
  Public
 
302
    Property BufferSize : LongWord Read FBufSize Write SetBufSize;
 
303
    Property OnPercent : Integer Read FOnPercent Write FOnPercent;
 
304
    Property OnProgress : TProgressEvent Read FOnProgress Write FOnProgress;
 
305
    Property OnStartFile : TOnStartFileEvent Read FOnStartFile Write FOnStartFile;
 
306
    Property OnEndFile : TOnEndOfFileEvent Read FOnEndOfFile Write FOnEndOfFile;
 
307
    Property FileName : String Read FFileName Write SetFileName;
 
308
    Property Files : TStrings Read FFiles;
 
309
    Property InMemSize : Integer Read FInMemSize Write FInMemSize;
 
310
  end;
 
311
 
 
312
  { TYbZipper }
 
313
 
 
314
  { TUnZipper }
 
315
 
 
316
  TUnZipper = Class(TObject)
 
317
  Private
 
318
    FUnZipping  : Boolean;
 
319
    FBufSize    : LongWord;
 
320
    FFileName   :  String;         { Name of resulting Zip file                 }
 
321
    FOutputPath : String;
 
322
    FFiles      : TStrings;
 
323
    FZipEntries : TFPObjectList;
 
324
    FOutFile    : TFileStream;
 
325
    FZipFile     : TFileStream;     { I/O file variables                         }
 
326
    LocalHdr    : Local_File_Header_Type;
 
327
    CentralHdr  : Central_File_Header_Type;
 
328
    EndHdr      : End_of_Central_Dir_Type;
 
329
 
 
330
    FOnPercent  : LongInt;
 
331
    FOnProgress : TProgressEvent;
 
332
    FOnEndOfFile : TOnEndOfFileEvent;
 
333
    FOnStartFile : TOnStartFileEvent;
 
334
  Protected
 
335
    Procedure OpenInput;
 
336
    Procedure CloseOutput;
 
337
    Procedure CloseInput;
 
338
    Procedure ReadZipHeader(Item : TZipItem; out ACRC : LongWord;out AMethod : Word);
 
339
    Procedure ReadZipDirectory;
 
340
    Procedure DoEndOfFile;
 
341
    Procedure UnZipOneFile(Item : TZipItem); virtual;
 
342
    Function  OpenOutput(OutFileName : String) : Boolean;
 
343
    Procedure SetBufSize(Value : LongWord);
 
344
    Procedure SetFileName(Value : String);
 
345
    Procedure SetOutputPath(Value:String);
 
346
    Function CreateDeCompressor(Item : TZipItem; AMethod : Word;AZipFile,AOutFile : TStream) : TDeCompressor; virtual;
 
347
  Public
 
348
    Constructor Create;
 
349
    Destructor Destroy;override;
 
350
    Procedure UnZipAllFiles; virtual;
 
351
    Procedure UnZipFiles(AFileName : String; FileList : TStrings);
 
352
    Procedure UnZipAllFiles(AFileName : String);
 
353
    Procedure Clear;
 
354
  Public
 
355
    Property BufferSize : LongWord Read FBufSize Write SetBufSize;
 
356
    Property OnPercent : Integer Read FOnPercent Write FOnPercent;
 
357
    Property OnProgress : TProgressEvent Read FOnProgress Write FOnProgress;
 
358
    Property OnStartFile : TOnStartFileEvent Read FOnStartFile Write FOnStartFile;
 
359
    Property OnEndFile : TOnEndOfFileEvent Read FOnEndOfFile Write FOnEndOfFile;
 
360
    Property FileName : String Read FFileName Write SetFileName;
 
361
    Property OutputPath : String Read FOutputPath Write SetOutputPath;
 
362
    Property Files : TStrings Read FFiles;
 
363
  end;
 
364
 
 
365
  EZipError = Class(Exception);
 
366
 
 
367
Implementation
 
368
 
 
369
ResourceString
 
370
  SErrBufsizeChange = 'Changing buffer size is not allowed while (un)zipping';
 
371
  SErrFileChange = 'Changing output file name is not allowed while (un)zipping';
 
372
  SErrInvalidCRC = 'Invalid CRC checksum while unzipping %s';
 
373
  SErrCorruptZIP = 'Corrupt ZIP file %s';
 
374
  SErrUnsupportedCompressionFormat = 'Unsupported compression format %d';
 
375
 
 
376
{ ---------------------------------------------------------------------
 
377
    Auxiliary
 
378
  ---------------------------------------------------------------------}
 
379
 
 
380
Procedure DateTimeToZipDateTime(DT : TDateTime; out ZD,ZT : Word);
 
381
 
 
382
Var
 
383
  Y,M,D,H,N,S,MS : Word;
 
384
 
 
385
begin
 
386
  DecodeDate(DT,Y,M,D);
 
387
  DecodeTime(DT,H,N,S,MS);
 
388
  Y:=Y-1980;
 
389
  ZD:=d+(32*M)+(512*Y);
 
390
  ZT:=(S div 2)+(32*N)+(2048*h);
 
391
end;
 
392
 
 
393
Procedure ZipDateTimeToDateTime(ZD,ZT : Word;out DT : TDateTime);
 
394
 
 
395
Var
 
396
  Y,M,D,H,N,S,MS : Word;
 
397
 
 
398
begin
 
399
  MS:=0;
 
400
  S:=(ZT and 31) shl 1;
 
401
  N:=(ZT shr 5) and 63;
 
402
  H:=(ZT shr 12) and 31;
 
403
  D:=ZD and 31;
 
404
  M:=(ZD shr 5) and 15;
 
405
  Y:=((ZD shr 9) and 127)+1980;
 
406
  DT:=ComposeDateTime(EncodeDate(Y,M,D),EncodeTime(H,N,S,MS));
 
407
end;
 
408
 
 
409
{ ---------------------------------------------------------------------
 
410
    TDeCompressor
 
411
  ---------------------------------------------------------------------}
 
412
 
 
413
 
 
414
Procedure TDeCompressor.UpdC32(Octet: Byte);
 
415
 
 
416
Begin
 
417
  FCrc32Val := Crc_32_Tab[Byte(FCrc32Val XOR LongInt(Octet))] XOR ((FCrc32Val SHR 8) AND $00FFFFFF);
 
418
end;
 
419
 
 
420
constructor TDeCompressor.Create(AInFile, AOutFile: TStream; ABufSize: LongWord);
 
421
begin
 
422
  FinFile:=AInFile;
 
423
  FoutFile:=AOutFile;
 
424
  FBufferSize:=ABufSize;
 
425
  CRC32Val:=$FFFFFFFF;
 
426
end;
 
427
 
 
428
 
 
429
{ ---------------------------------------------------------------------
 
430
    TCompressor
 
431
  ---------------------------------------------------------------------}
 
432
 
 
433
 
 
434
Procedure TCompressor.UpdC32(Octet: Byte);
 
435
 
 
436
Begin
 
437
  FCrc32Val := Crc_32_Tab[Byte(FCrc32Val XOR LongInt(Octet))] XOR ((FCrc32Val SHR 8) AND $00FFFFFF);
 
438
end;
 
439
 
 
440
constructor TCompressor.Create(AInFile, AOutFile: TStream; ABufSize: LongWord);
 
441
begin
 
442
  FinFile:=AInFile;
 
443
  FoutFile:=AOutFile;
 
444
  FBufferSize:=ABufSize;
 
445
  CRC32Val:=$FFFFFFFF;
 
446
end;
 
447
 
 
448
 
 
449
{ ---------------------------------------------------------------------
 
450
    TDeflater
 
451
  ---------------------------------------------------------------------}
 
452
 
 
453
constructor TDeflater.Create(AInFile, AOutFile: TStream; ABufSize: LongWord);
 
454
begin
 
455
  Inherited;
 
456
  FCompressionLevel:=clDefault;
 
457
end;
 
458
 
 
459
 
 
460
procedure TDeflater.Compress;
 
461
 
 
462
Var
 
463
  Buf : PByte;
 
464
  I,Count,NewCount : Integer;
 
465
  C : TCompressionStream;
 
466
 
 
467
begin
 
468
  CRC32Val:=$FFFFFFFF;
 
469
  Buf:=GetMem(FBufferSize);
 
470
  Try
 
471
    C:=TCompressionStream.Create(FCompressionLevel,FOutFile,True);
 
472
    Try
 
473
      Repeat
 
474
        Count:=FInFile.Read(Buf^,FBufferSize);
 
475
        For I:=0 to Count-1 do
 
476
          UpdC32(Buf[i]);
 
477
        NewCount:=Count;
 
478
        While (NewCount>0) do
 
479
          NewCount:=NewCount-C.Write(Buf^,NewCount);
 
480
      Until (Count=0);
 
481
    Finally
 
482
      C.Free;
 
483
    end;
 
484
  Finally
 
485
    FreeMem(Buf);
 
486
  end;
 
487
  Crc32Val:=NOT Crc32Val;
 
488
end;
 
489
 
 
490
class function TDeflater.ZipID: Word;
 
491
begin
 
492
  Result:=8;
 
493
end;
 
494
 
 
495
{ ---------------------------------------------------------------------
 
496
    TInflater
 
497
  ---------------------------------------------------------------------}
 
498
 
 
499
constructor TInflater.Create(AInFile, AOutFile: TStream; ABufSize: LongWord);
 
500
begin
 
501
  Inherited;
 
502
end;
 
503
 
 
504
 
 
505
procedure TInflater.DeCompress;
 
506
 
 
507
Var
 
508
  Buf : PByte;
 
509
  I,Count : Integer;
 
510
  C : TDeCompressionStream;
 
511
 
 
512
begin
 
513
  CRC32Val:=$FFFFFFFF;
 
514
  Buf:=GetMem(FBufferSize);
 
515
  Try
 
516
    C:=TDeCompressionStream.Create(FInFile,True);
 
517
    Try
 
518
      Repeat
 
519
        Count:=C.Read(Buf^,FBufferSize);
 
520
        For I:=0 to Count-1 do
 
521
          UpdC32(Buf[i]);
 
522
        FOutFile.Write(Buf^,Count);
 
523
      Until (Count=0);
 
524
    Finally
 
525
      C.Free;
 
526
    end;
 
527
  Finally
 
528
    FreeMem(Buf);
 
529
  end;
 
530
  Crc32Val:=NOT Crc32Val;
 
531
end;
 
532
 
 
533
class function TInflater.ZipID: Word;
 
534
begin
 
535
  Result:=8;
 
536
end;
 
537
 
 
538
 
 
539
{ ---------------------------------------------------------------------
 
540
    TShrinker
 
541
  ---------------------------------------------------------------------}
 
542
 
 
543
Const
 
544
   DefaultInMemSize = 256*1024; { Files larger than 256k are processed on disk   }
 
545
   DefaultBufSize =  16384;     { Use 16K file buffers                             }
 
546
   MINBITS     =      9;        { Starting code size of 9 bits                     }
 
547
   MAXBITS     =     13;        { Maximum code size of 13 bits                     }
 
548
   SPECIAL     =    256;        { Special function code                            }
 
549
   INCSIZE     =      1;        { Code indicating a jump in code size              }
 
550
   CLEARCODE   =      2;        { Code indicating code table has been cleared      }
 
551
   STDATTR     =    $23;        { Standard file attribute for DOS Find First/Next  }
 
552
 
 
553
constructor TShrinker.Create(AInFile, AOutFile : TStream; ABufSize : LongWord);
 
554
begin
 
555
  Inherited;
 
556
  FBufSize:=ABufSize;
 
557
  InBuf:=GetMem(FBUFSIZE);
 
558
  OutBuf:=GetMem(FBUFSIZE);
 
559
  CodeTable:=GetMem(SizeOf(CodeTable^));
 
560
  FreeList:=GetMem(SizeOf(FreeList^));
 
561
end;
 
562
 
 
563
destructor TShrinker.Destroy;
 
564
begin
 
565
  FreeMem(CodeTable);
 
566
  FreeMem(FreeList);
 
567
  FreeMem(InBuf);
 
568
  FreeMem(OutBuf);
 
569
  inherited Destroy;
 
570
end;
 
571
 
 
572
Procedure TShrinker.Compress;
 
573
 
 
574
Var
 
575
   OneString : String;
 
576
   Remaining : Word;
 
577
 
 
578
begin
 
579
  BytesIn := 1;
 
580
  BytesOut := 1;
 
581
  InitializeCodeTable;
 
582
  FillInputBuffer;
 
583
  FirstCh:= TRUE;
 
584
  Crc32Val:=$FFFFFFFF;
 
585
  FOnBytes:=Round((FInFile.Size * FOnPercent) / 100);
 
586
  While NOT InputEof do
 
587
    begin
 
588
    Remaining:=Succ(MaxInBufIdx - InBufIdx);
 
589
    If Remaining>255 then
 
590
      Remaining:=255;
 
591
    If Remaining=0 then
 
592
      FillInputBuffer
 
593
    else
 
594
      begin
 
595
      SetLength(OneString,Remaining);
 
596
      Move(InBuf[InBufIdx], OneString[1], Remaining);
 
597
      Inc(InBufIdx, Remaining);
 
598
      ProcessLine(OneString);
 
599
      end;
 
600
    end;
 
601
   Crc32Val := NOT Crc32Val;
 
602
   ProcessLine('');
 
603
end;
 
604
 
 
605
class function TShrinker.ZipID: Word;
 
606
begin
 
607
  Result:=1;
 
608
end;
 
609
 
 
610
 
 
611
Procedure TShrinker.DoOnProgress(Const Pct: Double);
 
612
 
 
613
begin
 
614
  If Assigned(FOnProgress) then
 
615
    FOnProgress(Self,Pct);
 
616
end;
 
617
 
 
618
 
 
619
Procedure TShrinker.FillInputBuffer;
 
620
 
 
621
Begin
 
622
   MaxInbufIDx:=FInfile.Read(InBuf[0], FBufSize);
 
623
   If MaxInbufIDx=0 then
 
624
      InputEof := TRUE
 
625
   else
 
626
      InputEOF := FALSE;
 
627
   InBufIdx := 0;
 
628
end;
 
629
 
 
630
 
 
631
Procedure TShrinker.WriteOutputBuffer;
 
632
Begin
 
633
  FOutFile.WriteBuffer(OutBuf[0], OutBufIdx);
 
634
  OutBufIdx := 0;
 
635
end;
 
636
 
 
637
 
 
638
Procedure TShrinker.PutChar(B : Byte);
 
639
 
 
640
Begin
 
641
  OutBuf[OutBufIdx] := B;
 
642
  Inc(OutBufIdx);
 
643
  If OutBufIdx>=FBufSize then
 
644
    WriteOutputBuffer;
 
645
  Inc(BytesOut);
 
646
end;
 
647
 
 
648
Procedure TShrinker.FlushOutput;
 
649
Begin
 
650
  If OutBufIdx>0 then
 
651
    WriteOutputBuffer;
 
652
End;
 
653
 
 
654
 
 
655
procedure TShrinker.PutCode(Code : Smallint);
 
656
 
 
657
var
 
658
  ACode : LongInt;
 
659
  XSize : Smallint;
 
660
 
 
661
begin
 
662
  if (Code=-1) then
 
663
    begin
 
664
    if BitsUsed>0 then
 
665
      PutChar(SaveByte);
 
666
    end
 
667
  else
 
668
    begin
 
669
    ACode := Longint(Code);
 
670
    XSize := CodeSize+BitsUsed;
 
671
    ACode := (ACode shl BitsUsed) or SaveByte;
 
672
    while (XSize div 8) > 0 do
 
673
      begin
 
674
      PutChar(Lo(ACode));
 
675
      ACode := ACode shr 8;
 
676
      Dec(XSize,8);
 
677
      end;
 
678
    BitsUsed := XSize;
 
679
    SaveByte := Lo(ACode);
 
680
    end;
 
681
end;
 
682
 
 
683
 
 
684
Procedure TShrinker.InitializeCodeTable;
 
685
 
 
686
Var
 
687
   I  :  Word;
 
688
Begin
 
689
   For I := 0 to TableSize do
 
690
     begin
 
691
     With CodeTable^[I] do
 
692
       begin
 
693
       Child := -1;
 
694
       Sibling := -1;
 
695
       If (I<=255) then
 
696
         Suffix := I;
 
697
       end;
 
698
     If (I>=257) then
 
699
       FreeList^[I] := I;
 
700
     end;
 
701
   NextFree  := FIRSTENTRY;
 
702
   TableFull := FALSE;
 
703
end;
 
704
 
 
705
 
 
706
Procedure TShrinker.Prune(Parent : Word);
 
707
 
 
708
Var
 
709
   CurrChild   : Smallint;
 
710
   NextSibling : Smallint;
 
711
Begin
 
712
  CurrChild := CodeTable^[Parent].Child;
 
713
  { Find first Child that has descendants .. clear any that don't }
 
714
  While (CurrChild <> -1) AND (CodeTable^[CurrChild].Child = -1) do
 
715
    begin
 
716
    CodeTable^[Parent].Child := CodeTable^[CurrChild].Sibling;
 
717
    CodeTable^[CurrChild].Sibling := -1;
 
718
     { Turn on ClearList bit to indicate a cleared entry }
 
719
    ClearList[CurrChild DIV 8] := (ClearList[CurrChild DIV 8] OR (1 SHL (CurrChild MOD 8)));
 
720
    CurrChild := CodeTable^[Parent].Child;
 
721
    end;
 
722
  If CurrChild <> -1 then
 
723
    begin   { If there are any children left ...}
 
724
    Prune(CurrChild);
 
725
    NextSibling := CodeTable^[CurrChild].Sibling;
 
726
    While NextSibling <> -1 do
 
727
      begin
 
728
      If CodeTable^[NextSibling].Child = -1 then
 
729
        begin
 
730
        CodeTable^[CurrChild].Sibling := CodeTable^[NextSibling].Sibling;
 
731
        CodeTable^[NextSibling].Sibling := -1;
 
732
        { Turn on ClearList bit to indicate a cleared entry }
 
733
        ClearList[NextSibling DIV 8] := (ClearList[NextSibling DIV 8] OR (1 SHL (NextSibling MOD 8)));
 
734
        NextSibling := CodeTable^[CurrChild].Sibling;
 
735
        end
 
736
      else
 
737
        begin
 
738
        CurrChild := NextSibling;
 
739
        Prune(CurrChild);
 
740
        NextSibling := CodeTable^[CurrChild].Sibling;
 
741
        end;
 
742
      end;
 
743
    end;
 
744
end;
 
745
 
 
746
 
 
747
Procedure TShrinker.Clear_Table;
 
748
Var
 
749
   Node : Word;
 
750
Begin
 
751
   FillChar(ClearList, SizeOf(ClearList), $00);
 
752
   For Node := 0 to 255 do
 
753
     Prune(Node);
 
754
   NextFree := Succ(TABLESIZE);
 
755
   For Node := TABLESIZE downto FIRSTENTRY do
 
756
     begin
 
757
     If (ClearList[Node DIV 8] AND (1 SHL (Node MOD 8))) <> 0 then
 
758
       begin
 
759
       Dec(NextFree);
 
760
       FreeList^[NextFree] := Node;
 
761
       end;
 
762
     end;
 
763
   If NextFree <= TABLESIZE then
 
764
     TableFull := FALSE;
 
765
end;
 
766
 
 
767
 
 
768
Procedure TShrinker.Table_Add(Prefix : Word; Suffix : Byte);
 
769
Var
 
770
   FreeNode : Word;
 
771
Begin
 
772
  If NextFree <= TABLESIZE then
 
773
    begin
 
774
    FreeNode := FreeList^[NextFree];
 
775
    Inc(NextFree);
 
776
    CodeTable^[FreeNode].Child := -1;
 
777
    CodeTable^[FreeNode].Sibling := -1;
 
778
    CodeTable^[FreeNode].Suffix := Suffix;
 
779
    If CodeTable^[Prefix].Child  = -1 then
 
780
      CodeTable^[Prefix].Child := FreeNode
 
781
    else
 
782
      begin
 
783
      Prefix := CodeTable^[Prefix].Child;
 
784
      While CodeTable^[Prefix].Sibling <> -1 do
 
785
        Prefix := CodeTable^[Prefix].Sibling;
 
786
      CodeTable^[Prefix].Sibling := FreeNode;
 
787
      end;
 
788
    end;
 
789
  if NextFree > TABLESIZE then
 
790
    TableFull := TRUE;
 
791
end;
 
792
 
 
793
function TShrinker.Table_Lookup(    TargetPrefix : Smallint;
 
794
                          TargetSuffix : Byte;
 
795
                      Out FoundAt      : Smallint   ) : Boolean;
 
796
 
 
797
var TempPrefix : Smallint;
 
798
 
 
799
begin
 
800
  TempPrefix := TargetPrefix;
 
801
  Table_lookup := False;
 
802
  if CodeTable^[TempPrefix].Child <> -1 then
 
803
    begin
 
804
    TempPrefix := CodeTable^[TempPrefix].Child;
 
805
    repeat
 
806
      if CodeTable^[TempPrefix].Suffix = TargetSuffix then
 
807
        begin
 
808
        Table_lookup := True;
 
809
        break;
 
810
        end;
 
811
      if CodeTable^[TempPrefix].Sibling = -1 then
 
812
        break;
 
813
      TempPrefix := CodeTable^[TempPrefix].Sibling;
 
814
    until False;
 
815
  end;
 
816
  if Table_Lookup then
 
817
    FoundAt := TempPrefix
 
818
  else
 
819
    FoundAt := -1;
 
820
end;
 
821
 
 
822
Procedure TShrinker.Shrink(Suffix : Smallint);
 
823
 
 
824
Const
 
825
  LastCode : Smallint = 0;
 
826
 
 
827
Var
 
828
  WhereFound : Smallint;
 
829
 
 
830
Begin
 
831
  If FirstCh then
 
832
    begin
 
833
    SaveByte := $00;
 
834
    BitsUsed := 0;
 
835
    CodeSize := MINBITS;
 
836
    MaxCode  := (1 SHL CodeSize) - 1;
 
837
    LastCode := Suffix;
 
838
    FirstCh  := FALSE;
 
839
    end
 
840
  else
 
841
    begin
 
842
    If Suffix <> -1 then
 
843
      begin
 
844
      If TableFull then
 
845
        begin
 
846
        Putcode(LastCode);
 
847
        PutCode(SPECIAL);
 
848
        Putcode(CLEARCODE);
 
849
        Clear_Table;
 
850
        Table_Add(LastCode, Suffix);
 
851
        LastCode := Suffix;
 
852
        end
 
853
      else
 
854
        begin
 
855
        If Table_Lookup(LastCode, Suffix, WhereFound) then
 
856
          begin
 
857
          LastCode  := WhereFound;
 
858
          end
 
859
        else
 
860
          begin
 
861
          PutCode(LastCode);
 
862
          Table_Add(LastCode, Suffix);
 
863
          LastCode := Suffix;
 
864
          If (FreeList^[NextFree] > MaxCode) and (CodeSize < MaxBits) then
 
865
            begin
 
866
            PutCode(SPECIAL);
 
867
            PutCode(INCSIZE);
 
868
            Inc(CodeSize);
 
869
            MaxCode := (1 SHL CodeSize) -1;
 
870
            end;
 
871
          end;
 
872
        end;
 
873
      end
 
874
    else
 
875
      begin
 
876
      PutCode(LastCode);
 
877
      PutCode(-1);
 
878
      FlushOutput;
 
879
      end;
 
880
    end;
 
881
end;
 
882
 
 
883
Procedure TShrinker.ProcessLine(Const Source : String);
 
884
 
 
885
Var
 
886
  I : Word;
 
887
 
 
888
Begin
 
889
  If Source = '' then
 
890
    Shrink(-1)
 
891
  else
 
892
    For I := 1 to Length(Source) do
 
893
      begin
 
894
      Inc(BytesIn);
 
895
      If (Pred(BytesIn) MOD FOnBytes) = 0 then
 
896
        DoOnProgress(100 * ( BytesIn / FInFile.Size));
 
897
      UpdC32(Ord(Source[I]));
 
898
      Shrink(Ord(Source[I]));
 
899
      end;
 
900
end;
 
901
 
 
902
{ ---------------------------------------------------------------------
 
903
    TZipper
 
904
  ---------------------------------------------------------------------}
 
905
 
 
906
 
 
907
Procedure TZipper.GetFileInfo;
 
908
 
 
909
Var
 
910
   Info : TSearchRec;
 
911
   I       : Longint;
 
912
   NewNode : TZipItem;
 
913
 
 
914
 
 
915
Begin
 
916
   For I := 0 to FFiles.Count-1 do
 
917
    begin
 
918
     If FindFirst(FFiles[I], STDATTR, Info)=0 then
 
919
       try
 
920
         NewNode:=TZipItem.Create;
 
921
         NewNode.Path := ExtractFilePath(FFiles[i]);
 
922
         NewNode.Name := Info.Name;
 
923
         NewNode.Size := Info.Size;
 
924
         NewNode.DateTime:=FileDateToDateTime(Info.Time);
 
925
         FFiles.Objects[i]:=NewNode;
 
926
       finally
 
927
         FindClose(Info);
 
928
       end;
 
929
     end;  
 
930
end;
 
931
 
 
932
Procedure TZipper.OpenOutput;
 
933
 
 
934
Begin
 
935
  FOutFile:=TFileStream.Create(FFileName,fmCreate);
 
936
End;
 
937
 
 
938
 
 
939
Function TZipper.OpenInput(InFileName : String) : Boolean;
 
940
 
 
941
Begin
 
942
  FInFile:=TFileStream.Create(InFileName,fmOpenRead);
 
943
  Result:=True;
 
944
  If Assigned(FOnStartFile) then
 
945
    FOnStartFile(Self,InFileName);
 
946
End;
 
947
 
 
948
 
 
949
Procedure TZipper.CloseOutput;
 
950
 
 
951
Begin
 
952
  FreeAndNil(FOutFile);
 
953
end;
 
954
 
 
955
 
 
956
Procedure TZipper.CloseInput;
 
957
 
 
958
Begin
 
959
  FreeAndNil(FInFile);
 
960
end;
 
961
 
 
962
 
 
963
Procedure TZipper.StartZipFile(Item : TZipItem);
 
964
 
 
965
Begin
 
966
  FillChar(LocalHdr,SizeOf(LocalHdr),0);
 
967
  With LocalHdr do
 
968
    begin
 
969
    Signature := LOCAL_FILE_HEADER_SIGNATURE;
 
970
    Extract_Version_Reqd := 10;
 
971
    Bit_Flag := 0;
 
972
    Compress_Method := 1;
 
973
    DateTimeToZipDateTime(Item.DateTime,Last_Mod_Date,Last_Mod_Time);
 
974
    Crc32 := 0;
 
975
    Compressed_Size := 0;
 
976
    Uncompressed_Size := Item.Size;
 
977
    FileName_Length := 0;
 
978
    Extra_Field_Length := 0;
 
979
  end ;
 
980
End;
 
981
 
 
982
 
 
983
Function TZipper.UpdateZipHeader(Item : TZipItem; FZip : TStream; ACRC : LongWord; AMethod : Word) : Boolean;
 
984
var
 
985
  ZFileName  : ShortString;
 
986
Begin
 
987
  ZFileName:=Item.Path+Item.Name;
 
988
  With LocalHdr do
 
989
    begin
 
990
    FileName_Length := Length(ZFileName);
 
991
    Compressed_Size := FZip.Size;
 
992
    Crc32 := ACRC;
 
993
    Compress_method:=AMethod;
 
994
    Result:=Not (Compressed_Size >= Uncompressed_Size);
 
995
    If Not Result then
 
996
      begin                     { No...                          }
 
997
      Compress_Method := 0;                  { ...change stowage type      }
 
998
      Compressed_Size := Uncompressed_Size;  { ...update compressed size   }
 
999
      end;
 
1000
    end;
 
1001
  FOutFile.WriteBuffer(LocalHdr,SizeOf(LocalHdr));
 
1002
  FOutFile.WriteBuffer(ZFileName[1],Length(ZFileName));
 
1003
End;
 
1004
 
 
1005
 
 
1006
Procedure TZipper.BuildZipDirectory;
 
1007
 
 
1008
Var
 
1009
   SavePos   : LongInt;
 
1010
   HdrPos    : LongInt;
 
1011
   CenDirPos : LongInt;
 
1012
   Entries   : Word;
 
1013
   ZFileName  : ShortString;
 
1014
 
 
1015
Begin
 
1016
   Entries := 0;
 
1017
   CenDirPos := FOutFile.Position;
 
1018
   FOutFile.Seek(0,soFrombeginning);             { Rewind output file }
 
1019
   HdrPos := FOutFile.Position;
 
1020
   FOutFile.ReadBuffer(LocalHdr, SizeOf(LocalHdr));
 
1021
   Repeat
 
1022
     SetLength(ZFileName,LocalHdr.FileName_Length);
 
1023
     FOutFile.ReadBuffer(ZFileName[1], LocalHdr.FileName_Length);
 
1024
     SavePos := FOutFile.Position;
 
1025
     FillChar(CentralHdr,SizeOf(CentralHdr),0);
 
1026
     With CentralHdr do
 
1027
       begin
 
1028
       Signature := CENTRAL_FILE_HEADER_SIGNATURE;
 
1029
       MadeBy_Version := LocalHdr.Extract_Version_Reqd;
 
1030
       Move(LocalHdr.Extract_Version_Reqd, Extract_Version_Reqd, 26);
 
1031
       Last_Mod_Time:=localHdr.Last_Mod_Time;
 
1032
       Last_Mod_Date:=localHdr.Last_Mod_Date;
 
1033
       File_Comment_Length := 0;
 
1034
       Starting_Disk_Num := 0;
 
1035
       Internal_Attributes := 0;
 
1036
       External_Attributes := faARCHIVE;
 
1037
       Local_Header_Offset := HdrPos;
 
1038
       end;
 
1039
     FOutFile.Seek(0,soFromEnd);
 
1040
     FOutFile.WriteBuffer(CentralHdr,SizeOf(CentralHdr));
 
1041
     FOutFile.WriteBuffer(ZFileName[1],Length(ZFileName));
 
1042
     Inc(Entries);
 
1043
     FOutFile.Seek(SavePos + LocalHdr.Compressed_Size,soFromBeginning);
 
1044
     HdrPos:=FOutFile.Position;
 
1045
     FOutFile.ReadBuffer(LocalHdr, SizeOf(LocalHdr));
 
1046
   Until LocalHdr.Signature = CENTRAL_FILE_HEADER_SIGNATURE;
 
1047
   FOutFile.Seek(0,soFromEnd);
 
1048
   FillChar(EndHdr,SizeOf(EndHdr),0);
 
1049
   With EndHdr do
 
1050
     begin
 
1051
     Signature := END_OF_CENTRAL_DIR_SIGNATURE;
 
1052
     Disk_Number := 0;
 
1053
     Central_Dir_Start_Disk := 0;
 
1054
     Entries_This_Disk := Entries;
 
1055
     Total_Entries := Entries;
 
1056
     Central_Dir_Size := FOutFile.Size-CenDirPos;
 
1057
     Start_Disk_Offset := CenDirPos;
 
1058
     ZipFile_Comment_Length := 0;
 
1059
     FOutFile.WriteBuffer(EndHdr, SizeOf(EndHdr));
 
1060
     end;
 
1061
end;
 
1062
 
 
1063
Function TZipper.CreateCompressor(Item : TZipItem; AInFile,AZipStream : TStream) : TCompressor;
 
1064
 
 
1065
begin
 
1066
  Result:=TDeflater.Create(AinFile,AZipStream,FBufSize);
 
1067
end;
 
1068
 
 
1069
Procedure TZipper.ZipOneFile(Item : TZipItem);
 
1070
 
 
1071
Var
 
1072
  CRC : LongWord;
 
1073
  ZMethod : Word;
 
1074
  ZipStream : TStream;
 
1075
  TmpFileName : String;
 
1076
 
 
1077
Begin
 
1078
  OpenInput(Item.Path+Item.Name);
 
1079
  Try
 
1080
    StartZipFile(Item);
 
1081
    If (FInfile.Size<=FInMemSize) then
 
1082
      ZipStream:=TMemoryStream.Create
 
1083
    else
 
1084
      begin
 
1085
      TmpFileName:=ChangeFileExt(FFileName,'.tmp');
 
1086
      ZipStream:=TFileStream.Create(TmpFileName,fmCreate);
 
1087
      end;
 
1088
    Try
 
1089
      With CreateCompressor(Item, FinFile,ZipStream) do
 
1090
        Try
 
1091
          OnProgress:=Self.OnProgress;
 
1092
          OnPercent:=Self.OnPercent;
 
1093
          Compress;
 
1094
          CRC:=Crc32Val;
 
1095
          ZMethod:=ZipID;
 
1096
        Finally
 
1097
          Free;
 
1098
        end;
 
1099
      If UpdateZipHeader(Item,ZipStream,CRC,ZMethod) then
 
1100
        // Compressed file smaller than original file.
 
1101
        FOutFile.CopyFrom(ZipStream,0)
 
1102
      else
 
1103
        begin
 
1104
        // Original file smaller than compressed file.
 
1105
        FInfile.Seek(0,soFromBeginning);
 
1106
        FOutFile.CopyFrom(FInFile,0);
 
1107
        end;
 
1108
    finally
 
1109
      ZipStream.Free;
 
1110
      If (TmpFileName<>'') then
 
1111
        DeleteFile(TmpFileName);
 
1112
    end;
 
1113
  Finally
 
1114
    CloseInput;
 
1115
  end;
 
1116
end;
 
1117
 
 
1118
Procedure TZipper.ZipAllFiles;
 
1119
Var
 
1120
   Item : TZipItem;
 
1121
   I : Integer;
 
1122
   filecnt : integer;
 
1123
Begin
 
1124
  if FFiles.Count=0 then
 
1125
    exit;
 
1126
  FZipping:=True;
 
1127
  Try
 
1128
    GetFileInfo;
 
1129
    OpenOutput;
 
1130
    Try
 
1131
      filecnt:=0;
 
1132
      For I:=0 to FFiles.Count-1 do
 
1133
        begin
 
1134
          Item:=FFiles.Objects[i] as TZipItem;
 
1135
          if assigned(Item) then
 
1136
            begin
 
1137
              ZipOneFile(Item);
 
1138
              inc(filecnt);
 
1139
            end;  
 
1140
        end;
 
1141
      if filecnt>0 then 
 
1142
        BuildZipDirectory;
 
1143
    finally
 
1144
      CloseOutput;
 
1145
    end;
 
1146
  finally
 
1147
    FZipping:=False;
 
1148
  end;
 
1149
end;
 
1150
 
 
1151
 
 
1152
Procedure TZipper.SetBufSize(Value : LongWord);
 
1153
 
 
1154
begin
 
1155
  If FZipping then
 
1156
    Raise EZipError.Create(SErrBufsizeChange);
 
1157
  If Value>=DefaultBufSize then
 
1158
    FBufSize:=Value;
 
1159
end;
 
1160
 
 
1161
Procedure TZipper.SetFileName(Value : String);
 
1162
 
 
1163
begin
 
1164
  If FZipping then
 
1165
    Raise EZipError.Create(SErrFileChange);
 
1166
  FFileName:=Value;
 
1167
end;
 
1168
 
 
1169
Procedure TZipper.ZipFiles(AFileName : String; FileList : TStrings);
 
1170
 
 
1171
begin
 
1172
  FFiles.Assign(FileList);
 
1173
  FFileName:=AFileName;
 
1174
  ZipAllFiles;
 
1175
end;
 
1176
 
 
1177
Procedure TZipper.DoEndOfFile;
 
1178
 
 
1179
Var
 
1180
  ComprPct : Double;
 
1181
 
 
1182
begin
 
1183
  If (LocalHdr.Uncompressed_Size>0) then
 
1184
    ComprPct := (100.0 * (LocalHdr.Uncompressed_Size - LocalHdr.Compressed_Size)) / LocalHdr.Uncompressed_Size
 
1185
  else
 
1186
    ComprPct := 0;
 
1187
  If Assigned(FOnEndOfFile) then
 
1188
    FOnEndOfFile(Self,ComprPct);
 
1189
end;
 
1190
 
 
1191
Constructor TZipper.Create;
 
1192
 
 
1193
begin
 
1194
  FBufSize:=DefaultBufSize;
 
1195
  FInMemSize:=DefaultInMemSize;
 
1196
  FFiles:=TStringList.Create;
 
1197
  TStringlist(FFiles).Sorted:=True;
 
1198
  FOnPercent:=1;
 
1199
end;
 
1200
 
 
1201
Procedure TZipper.Clear;
 
1202
 
 
1203
Var
 
1204
  I : Integer;
 
1205
 
 
1206
begin
 
1207
  For I:=0 to FFiles.Count-1 do
 
1208
    FFiles.Objects[i].Free;
 
1209
  FFiles.Clear;
 
1210
end;
 
1211
 
 
1212
Destructor TZipper.Destroy;
 
1213
 
 
1214
begin
 
1215
  Clear;
 
1216
  FreeAndNil(FFiles);
 
1217
  Inherited;
 
1218
end;
 
1219
 
 
1220
 
 
1221
{ ---------------------------------------------------------------------
 
1222
    TUnZipper
 
1223
  ---------------------------------------------------------------------}
 
1224
 
 
1225
Procedure TUnZipper.OpenInput;
 
1226
 
 
1227
Begin
 
1228
  FZipFile:=TFileStream.Create(FFileName,fmOpenRead);
 
1229
End;
 
1230
 
 
1231
 
 
1232
Function TUnZipper.OpenOutput(OutFileName : String) : Boolean;
 
1233
 
 
1234
Begin
 
1235
  FOutFile:=TFileStream.Create(OutFileName,fmCreate);
 
1236
  Result:=True;
 
1237
  If Assigned(FOnStartFile) then
 
1238
    FOnStartFile(Self,OutFileName);
 
1239
End;
 
1240
 
 
1241
 
 
1242
Procedure TUnZipper.CloseOutput;
 
1243
 
 
1244
Begin
 
1245
  FreeAndNil(FOutFile);
 
1246
end;
 
1247
 
 
1248
 
 
1249
Procedure TUnZipper.CloseInput;
 
1250
 
 
1251
Begin
 
1252
  FreeAndNil(FZipFile);
 
1253
end;
 
1254
 
 
1255
 
 
1256
Procedure TUnZipper.ReadZipHeader(Item : TZipItem; out ACRC : LongWord; out AMethod : Word);
 
1257
 
 
1258
Begin
 
1259
  FZipFile.Seek(Item.HdrPos,soFromBeginning);
 
1260
  FZipFile.ReadBuffer(LocalHdr,SizeOf(LocalHdr));
 
1261
  With LocalHdr do
 
1262
    begin
 
1263
      SetLength(Item.Name,Filename_Length);
 
1264
      FZipFile.ReadBuffer(Item.Name[1],Filename_Length);
 
1265
      FZipFile.Seek(Extra_Field_Length,soCurrent);
 
1266
      Item.Size:=Uncompressed_Size;
 
1267
      ZipDateTimeToDateTime(Last_Mod_Date,Last_Mod_Time,Item.DateTime);
 
1268
      ACrc:=Crc32;
 
1269
      AMethod:=Compress_method;
 
1270
    end;
 
1271
End;
 
1272
 
 
1273
 
 
1274
Procedure TUnZipper.ReadZipDirectory;
 
1275
 
 
1276
Var
 
1277
   i,
 
1278
   EndHdrPos,
 
1279
   CenDirPos : LongInt;
 
1280
   NewNode   : TZipItem;
 
1281
Begin
 
1282
   EndHdrPos:=FZipFile.Size-SizeOf(EndHdr);
 
1283
   if EndHdrPos < 0 then
 
1284
     raise EZipError.CreateFmt(SErrCorruptZIP,[FZipFile.FileName]);
 
1285
   FZipFile.Seek(EndHdrPos,soFromBeginning);
 
1286
   FZipFile.ReadBuffer(EndHdr, SizeOf(EndHdr));
 
1287
   With EndHdr do
 
1288
     begin
 
1289
       if Signature <> END_OF_CENTRAL_DIR_SIGNATURE then
 
1290
         raise EZipError.CreateFmt(SErrCorruptZIP,[FZipFile.FileName]);
 
1291
       CenDirPos:=Start_Disk_Offset;
 
1292
     end;
 
1293
   FZipFile.Seek(CenDirPos,soFrombeginning);
 
1294
   for i:=0 to EndHdr.Entries_This_Disk-1 do
 
1295
     begin
 
1296
       FZipFile.ReadBuffer(CentralHdr, SizeOf(CentralHdr));
 
1297
       With CentralHdr do
 
1298
         begin
 
1299
           if Signature<>CENTRAL_FILE_HEADER_SIGNATURE then
 
1300
             raise EZipError.CreateFmt(SErrCorruptZIP,[FZipFile.FileName]);
 
1301
           NewNode:=TZipItem.Create;
 
1302
           NewNode.HdrPos := Local_Header_Offset;
 
1303
           SetLength(NewNode.Name,Filename_Length);
 
1304
           FZipFile.ReadBuffer(NewNode.Name[1],Filename_Length);
 
1305
           FZipFile.Seek(Extra_Field_Length+File_Comment_Length,soCurrent);
 
1306
           FZipEntries.Add(NewNode);
 
1307
         end;
 
1308
     end;
 
1309
end;
 
1310
 
 
1311
Function TUnZipper.CreateDeCompressor(Item : TZipItem; AMethod : Word;AZipFile,AOutFile : TStream) : TDeCompressor;
 
1312
var
 
1313
  Count : Int64;
 
1314
begin
 
1315
  case AMethod of
 
1316
    8 :
 
1317
      Result:=TInflater.Create(AZipFile,AOutFile,FBufSize);
 
1318
  else
 
1319
    raise EZipError.CreateFmt(SErrUnsupportedCompressionFormat,[AMethod]);
 
1320
  end;
 
1321
end;
 
1322
 
 
1323
Procedure TUnZipper.UnZipOneFile(Item : TZipItem);
 
1324
 
 
1325
Var
 
1326
  Count : Longint;
 
1327
  CRC : LongWord;
 
1328
  ZMethod : Word;
 
1329
  OutputFileName : string;
 
1330
Begin
 
1331
  Try
 
1332
    ReadZipHeader(Item,CRC,ZMethod);
 
1333
    OutputFileName:=Item.Name;
 
1334
    if FOutputPath<>'' then
 
1335
      OutputFileName:=IncludeTrailingPathDelimiter(FOutputPath)+OutputFileName;
 
1336
    OpenOutput(OutputFileName);  
 
1337
    if ZMethod=0 then
 
1338
      begin
 
1339
        Count:=FOutFile.CopyFrom(FZipFile,LocalHdr.Compressed_Size);
 
1340
{$warning TODO: Implement CRC Check}
 
1341
      end
 
1342
    else
 
1343
      With CreateDecompressor(Item, ZMethod, FZipFile, FOutFile) do
 
1344
        Try
 
1345
          OnProgress:=Self.OnProgress;
 
1346
          OnPercent:=Self.OnPercent;
 
1347
          DeCompress;
 
1348
          if CRC<>Crc32Val then
 
1349
            raise EZipError.CreateFmt(SErrInvalidCRC,[Item.Name]);
 
1350
        Finally
 
1351
          Free;
 
1352
        end;
 
1353
  Finally
 
1354
    CloseOutput;
 
1355
  end;
 
1356
end;
 
1357
 
 
1358
 
 
1359
Procedure TUnZipper.UnZipAllFiles;
 
1360
Var
 
1361
   Item : TZipItem;
 
1362
   I : Integer;
 
1363
 
 
1364
Begin
 
1365
  FUnZipping:=True;
 
1366
  Try
 
1367
    OpenInput;
 
1368
    Try
 
1369
      ReadZipDirectory;
 
1370
      For I:=0 to FZipEntries.Count-1 do
 
1371
        begin
 
1372
          Item:=FZipEntries[i] as TZipItem;
 
1373
          if (FFiles=nil) or
 
1374
             (FFiles.IndexOf(Item.Name)<>-1) then
 
1375
            UnZipOneFile(Item);
 
1376
        end;
 
1377
    Finally
 
1378
       CloseInput;
 
1379
    end;
 
1380
  finally
 
1381
    FUnZipping:=False;
 
1382
  end;
 
1383
end;
 
1384
 
 
1385
 
 
1386
Procedure TUnZipper.SetBufSize(Value : LongWord);
 
1387
 
 
1388
begin
 
1389
  If FUnZipping then
 
1390
    Raise EZipError.Create(SErrBufsizeChange);
 
1391
  If Value>=DefaultBufSize then
 
1392
    FBufSize:=Value;
 
1393
end;
 
1394
 
 
1395
Procedure TUnZipper.SetFileName(Value : String);
 
1396
 
 
1397
begin
 
1398
  If FUnZipping then
 
1399
    Raise EZipError.Create(SErrFileChange);
 
1400
  FFileName:=Value;
 
1401
end;
 
1402
 
 
1403
Procedure TUnZipper.SetOutputPath(Value:String);
 
1404
begin
 
1405
  If FUnZipping then
 
1406
    Raise EZipError.Create(SErrFileChange);
 
1407
  FOutputPath:=Value;
 
1408
end;
 
1409
 
 
1410
Procedure TUnZipper.UnZipFiles(AFileName : String; FileList : TStrings);
 
1411
 
 
1412
begin
 
1413
  FFiles.Assign(FileList);
 
1414
  FFileName:=AFileName;
 
1415
  UnZipAllFiles;
 
1416
end;
 
1417
 
 
1418
Procedure TUnZipper.UnZipAllFiles(AFileName : String);
 
1419
 
 
1420
begin
 
1421
  FFileName:=AFileName;
 
1422
  UnZipAllFiles;
 
1423
end;
 
1424
 
 
1425
Procedure TUnZipper.DoEndOfFile;
 
1426
 
 
1427
Var
 
1428
  ComprPct : Double;
 
1429
 
 
1430
begin
 
1431
  If (LocalHdr.Uncompressed_Size>0) then
 
1432
    ComprPct := (100.0 * (LocalHdr.Uncompressed_Size - LocalHdr.Compressed_Size)) / LocalHdr.Uncompressed_Size
 
1433
  else
 
1434
    ComprPct := 0;
 
1435
  If Assigned(FOnEndOfFile) then
 
1436
    FOnEndOfFile(Self,ComprPct);
 
1437
end;
 
1438
 
 
1439
Constructor TUnZipper.Create;
 
1440
 
 
1441
begin
 
1442
  FBufSize:=DefaultBufSize;
 
1443
  FFiles:=TStringList.Create;
 
1444
  FZipEntries:=TFPObjectList.Create(true);
 
1445
  TStringlist(FFiles).Sorted:=True;
 
1446
  FOnPercent:=1;
 
1447
end;
 
1448
 
 
1449
Procedure TUnZipper.Clear;
 
1450
 
 
1451
Var
 
1452
  I : Integer;
 
1453
 
 
1454
begin
 
1455
  For I:=0 to FFiles.Count-1 do
 
1456
    FFiles.Objects[i].Free;
 
1457
  FFiles.Clear;
 
1458
  FZipEntries.Clear;
 
1459
end;
 
1460
 
 
1461
Destructor TUnZipper.Destroy;
 
1462
 
 
1463
begin
 
1464
  Clear;
 
1465
  FreeAndNil(FFiles);
 
1466
  FreeAndNil(FZipEntries);
 
1467
  Inherited;
 
1468
end;
 
1469
 
 
1470
End.