]> git.jsancho.org Git - lugaru.git/blob - Dependencies/zlib/contrib/delphi/ZLib.pas
Remove more commented-out code. Out of sight, out of mind
[lugaru.git] / Dependencies / zlib / contrib / delphi / ZLib.pas
1 {*******************************************************}
2 {                                                       }
3 {       Borland Delphi Supplemental Components          }
4 {       ZLIB Data Compression Interface Unit            }
5 {                                                       }
6 {       Copyright (c) 1997,99 Borland Corporation       }
7 {                                                       }
8 {*******************************************************}
9
10 { Updated for zlib 1.2.x by Cosmin Truta <cosmint@cs.ubbcluj.ro> }
11
12 unit ZLib;
13
14 interface
15
16 uses SysUtils, Classes;
17
18 type
19   TAlloc = function (AppData: Pointer; Items, Size: Integer): Pointer; cdecl;
20   TFree = procedure (AppData, Block: Pointer); cdecl;
21
22   // Internal structure.  Ignore.
23   TZStreamRec = packed record
24     next_in: PChar;       // next input byte
25     avail_in: Integer;    // number of bytes available at next_in
26     total_in: Longint;    // total nb of input bytes read so far
27
28     next_out: PChar;      // next output byte should be put here
29     avail_out: Integer;   // remaining free space at next_out
30     total_out: Longint;   // total nb of bytes output so far
31
32     msg: PChar;           // last error message, NULL if no error
33     internal: Pointer;    // not visible by applications
34
35     zalloc: TAlloc;       // used to allocate the internal state
36     zfree: TFree;         // used to free the internal state
37     AppData: Pointer;     // private data object passed to zalloc and zfree
38
39     data_type: Integer;   // best guess about the data type: ascii or binary
40     adler: Longint;       // adler32 value of the uncompressed data
41     reserved: Longint;    // reserved for future use
42   end;
43
44   // Abstract ancestor class
45   TCustomZlibStream = class(TStream)
46   private
47     FStrm: TStream;
48     FStrmPos: Integer;
49     FOnProgress: TNotifyEvent;
50     FZRec: TZStreamRec;
51     FBuffer: array [Word] of Char;
52   protected
53     procedure Progress(Sender: TObject); dynamic;
54     property OnProgress: TNotifyEvent read FOnProgress write FOnProgress;
55     constructor Create(Strm: TStream);
56   end;
57
58 { TCompressionStream compresses data on the fly as data is written to it, and
59   stores the compressed data to another stream.
60
61   TCompressionStream is write-only and strictly sequential. Reading from the
62   stream will raise an exception. Using Seek to move the stream pointer
63   will raise an exception.
64
65   Output data is cached internally, written to the output stream only when
66   the internal output buffer is full.  All pending output data is flushed
67   when the stream is destroyed.
68
69   The Position property returns the number of uncompressed bytes of
70   data that have been written to the stream so far.
71
72   CompressionRate returns the on-the-fly percentage by which the original
73   data has been compressed:  (1 - (CompressedBytes / UncompressedBytes)) * 100
74   If raw data size = 100 and compressed data size = 25, the CompressionRate
75   is 75%
76
77   The OnProgress event is called each time the output buffer is filled and
78   written to the output stream.  This is useful for updating a progress
79   indicator when you are writing a large chunk of data to the compression
80   stream in a single call.}
81
82
83   TCompressionLevel = (clNone, clFastest, clDefault, clMax);
84
85   TCompressionStream = class(TCustomZlibStream)
86   private
87     function GetCompressionRate: Single;
88   public
89     constructor Create(CompressionLevel: TCompressionLevel; Dest: TStream);
90     destructor Destroy; override;
91     function Read(var Buffer; Count: Longint): Longint; override;
92     function Write(const Buffer; Count: Longint): Longint; override;
93     function Seek(Offset: Longint; Origin: Word): Longint; override;
94     property CompressionRate: Single read GetCompressionRate;
95     property OnProgress;
96   end;
97
98 { TDecompressionStream decompresses data on the fly as data is read from it.
99
100   Compressed data comes from a separate source stream.  TDecompressionStream
101   is read-only and unidirectional; you can seek forward in the stream, but not
102   backwards.  The special case of setting the stream position to zero is
103   allowed.  Seeking forward decompresses data until the requested position in
104   the uncompressed data has been reached.  Seeking backwards, seeking relative
105   to the end of the stream, requesting the size of the stream, and writing to
106   the stream will raise an exception.
107
108   The Position property returns the number of bytes of uncompressed data that
109   have been read from the stream so far.
110
111   The OnProgress event is called each time the internal input buffer of
112   compressed data is exhausted and the next block is read from the input stream.
113   This is useful for updating a progress indicator when you are reading a
114   large chunk of data from the decompression stream in a single call.}
115
116   TDecompressionStream = class(TCustomZlibStream)
117   public
118     constructor Create(Source: TStream);
119     destructor Destroy; override;
120     function Read(var Buffer; Count: Longint): Longint; override;
121     function Write(const Buffer; Count: Longint): Longint; override;
122     function Seek(Offset: Longint; Origin: Word): Longint; override;
123     property OnProgress;
124   end;
125
126
127
128 { CompressBuf compresses data, buffer to buffer, in one call.
129    In: InBuf = ptr to compressed data
130        InBytes = number of bytes in InBuf
131   Out: OutBuf = ptr to newly allocated buffer containing decompressed data
132        OutBytes = number of bytes in OutBuf   }
133 procedure CompressBuf(const InBuf: Pointer; InBytes: Integer;
134                       out OutBuf: Pointer; out OutBytes: Integer);
135
136
137 { DecompressBuf decompresses data, buffer to buffer, in one call.
138    In: InBuf = ptr to compressed data
139        InBytes = number of bytes in InBuf
140        OutEstimate = zero, or est. size of the decompressed data
141   Out: OutBuf = ptr to newly allocated buffer containing decompressed data
142        OutBytes = number of bytes in OutBuf   }
143 procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer;
144  OutEstimate: Integer; out OutBuf: Pointer; out OutBytes: Integer);
145
146 { DecompressToUserBuf decompresses data, buffer to buffer, in one call.
147    In: InBuf = ptr to compressed data
148        InBytes = number of bytes in InBuf
149   Out: OutBuf = ptr to user-allocated buffer to contain decompressed data
150        BufSize = number of bytes in OutBuf   }
151 procedure DecompressToUserBuf(const InBuf: Pointer; InBytes: Integer;
152   const OutBuf: Pointer; BufSize: Integer);
153
154 const
155   zlib_version = '1.2.5';
156
157 type
158   EZlibError = class(Exception);
159   ECompressionError = class(EZlibError);
160   EDecompressionError = class(EZlibError);
161
162 implementation
163
164 uses ZLibConst;
165
166 const
167   Z_NO_FLUSH      = 0;
168   Z_PARTIAL_FLUSH = 1;
169   Z_SYNC_FLUSH    = 2;
170   Z_FULL_FLUSH    = 3;
171   Z_FINISH        = 4;
172
173   Z_OK            = 0;
174   Z_STREAM_END    = 1;
175   Z_NEED_DICT     = 2;
176   Z_ERRNO         = (-1);
177   Z_STREAM_ERROR  = (-2);
178   Z_DATA_ERROR    = (-3);
179   Z_MEM_ERROR     = (-4);
180   Z_BUF_ERROR     = (-5);
181   Z_VERSION_ERROR = (-6);
182
183   Z_NO_COMPRESSION       =   0;
184   Z_BEST_SPEED           =   1;
185   Z_BEST_COMPRESSION     =   9;
186   Z_DEFAULT_COMPRESSION  = (-1);
187
188   Z_FILTERED            = 1;
189   Z_HUFFMAN_ONLY        = 2;
190   Z_RLE                 = 3;
191   Z_DEFAULT_STRATEGY    = 0;
192
193   Z_BINARY   = 0;
194   Z_ASCII    = 1;
195   Z_UNKNOWN  = 2;
196
197   Z_DEFLATED = 8;
198
199
200 {$L adler32.obj}
201 {$L compress.obj}
202 {$L crc32.obj}
203 {$L deflate.obj}
204 {$L infback.obj}
205 {$L inffast.obj}
206 {$L inflate.obj}
207 {$L inftrees.obj}
208 {$L trees.obj}
209 {$L uncompr.obj}
210 {$L zutil.obj}
211
212 procedure adler32; external;
213 procedure compressBound; external;
214 procedure crc32; external;
215 procedure deflateInit2_; external;
216 procedure deflateParams; external;
217
218 function _malloc(Size: Integer): Pointer; cdecl;
219 begin
220   Result := AllocMem(Size);
221 end;
222
223 procedure _free(Block: Pointer); cdecl;
224 begin
225   FreeMem(Block);
226 end;
227
228 procedure _memset(P: Pointer; B: Byte; count: Integer); cdecl;
229 begin
230   FillChar(P^, count, B);
231 end;
232
233 procedure _memcpy(dest, source: Pointer; count: Integer); cdecl;
234 begin
235   Move(source^, dest^, count);
236 end;
237
238
239
240 // deflate compresses data
241 function deflateInit_(var strm: TZStreamRec; level: Integer; version: PChar;
242   recsize: Integer): Integer; external;
243 function deflate(var strm: TZStreamRec; flush: Integer): Integer; external;
244 function deflateEnd(var strm: TZStreamRec): Integer; external;
245
246 // inflate decompresses data
247 function inflateInit_(var strm: TZStreamRec; version: PChar;
248   recsize: Integer): Integer; external;
249 function inflate(var strm: TZStreamRec; flush: Integer): Integer; external;
250 function inflateEnd(var strm: TZStreamRec): Integer; external;
251 function inflateReset(var strm: TZStreamRec): Integer; external;
252
253
254 function zlibAllocMem(AppData: Pointer; Items, Size: Integer): Pointer; cdecl;
255 begin
256 //  GetMem(Result, Items*Size);
257   Result := AllocMem(Items * Size);
258 end;
259
260 procedure zlibFreeMem(AppData, Block: Pointer); cdecl;
261 begin
262   FreeMem(Block);
263 end;
264
265 {function zlibCheck(code: Integer): Integer;
266 begin
267   Result := code;
268   if code < 0 then
269     raise EZlibError.Create('error');    //!!
270 end;}
271
272 function CCheck(code: Integer): Integer;
273 begin
274   Result := code;
275   if code < 0 then
276     raise ECompressionError.Create('error'); //!!
277 end;
278
279 function DCheck(code: Integer): Integer;
280 begin
281   Result := code;
282   if code < 0 then
283     raise EDecompressionError.Create('error');  //!!
284 end;
285
286 procedure CompressBuf(const InBuf: Pointer; InBytes: Integer;
287                       out OutBuf: Pointer; out OutBytes: Integer);
288 var
289   strm: TZStreamRec;
290   P: Pointer;
291 begin
292   FillChar(strm, sizeof(strm), 0);
293   strm.zalloc := zlibAllocMem;
294   strm.zfree := zlibFreeMem;
295   OutBytes := ((InBytes + (InBytes div 10) + 12) + 255) and not 255;
296   GetMem(OutBuf, OutBytes);
297   try
298     strm.next_in := InBuf;
299     strm.avail_in := InBytes;
300     strm.next_out := OutBuf;
301     strm.avail_out := OutBytes;
302     CCheck(deflateInit_(strm, Z_BEST_COMPRESSION, zlib_version, sizeof(strm)));
303     try
304       while CCheck(deflate(strm, Z_FINISH)) <> Z_STREAM_END do
305       begin
306         P := OutBuf;
307         Inc(OutBytes, 256);
308         ReallocMem(OutBuf, OutBytes);
309         strm.next_out := PChar(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P)));
310         strm.avail_out := 256;
311       end;
312     finally
313       CCheck(deflateEnd(strm));
314     end;
315     ReallocMem(OutBuf, strm.total_out);
316     OutBytes := strm.total_out;
317   except
318     FreeMem(OutBuf);
319     raise
320   end;
321 end;
322
323
324 procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer;
325   OutEstimate: Integer; out OutBuf: Pointer; out OutBytes: Integer);
326 var
327   strm: TZStreamRec;
328   P: Pointer;
329   BufInc: Integer;
330 begin
331   FillChar(strm, sizeof(strm), 0);
332   strm.zalloc := zlibAllocMem;
333   strm.zfree := zlibFreeMem;
334   BufInc := (InBytes + 255) and not 255;
335   if OutEstimate = 0 then
336     OutBytes := BufInc
337   else
338     OutBytes := OutEstimate;
339   GetMem(OutBuf, OutBytes);
340   try
341     strm.next_in := InBuf;
342     strm.avail_in := InBytes;
343     strm.next_out := OutBuf;
344     strm.avail_out := OutBytes;
345     DCheck(inflateInit_(strm, zlib_version, sizeof(strm)));
346     try
347       while DCheck(inflate(strm, Z_NO_FLUSH)) <> Z_STREAM_END do
348       begin
349         P := OutBuf;
350         Inc(OutBytes, BufInc);
351         ReallocMem(OutBuf, OutBytes);
352         strm.next_out := PChar(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P)));
353         strm.avail_out := BufInc;
354       end;
355     finally
356       DCheck(inflateEnd(strm));
357     end;
358     ReallocMem(OutBuf, strm.total_out);
359     OutBytes := strm.total_out;
360   except
361     FreeMem(OutBuf);
362     raise
363   end;
364 end;
365
366 procedure DecompressToUserBuf(const InBuf: Pointer; InBytes: Integer;
367   const OutBuf: Pointer; BufSize: Integer);
368 var
369   strm: TZStreamRec;
370 begin
371   FillChar(strm, sizeof(strm), 0);
372   strm.zalloc := zlibAllocMem;
373   strm.zfree := zlibFreeMem;
374   strm.next_in := InBuf;
375   strm.avail_in := InBytes;
376   strm.next_out := OutBuf;
377   strm.avail_out := BufSize;
378   DCheck(inflateInit_(strm, zlib_version, sizeof(strm)));
379   try
380     if DCheck(inflate(strm, Z_FINISH)) <> Z_STREAM_END then
381       raise EZlibError.CreateRes(@sTargetBufferTooSmall);
382   finally
383     DCheck(inflateEnd(strm));
384   end;
385 end;
386
387 // TCustomZlibStream
388
389 constructor TCustomZLibStream.Create(Strm: TStream);
390 begin
391   inherited Create;
392   FStrm := Strm;
393   FStrmPos := Strm.Position;
394   FZRec.zalloc := zlibAllocMem;
395   FZRec.zfree := zlibFreeMem;
396 end;
397
398 procedure TCustomZLibStream.Progress(Sender: TObject);
399 begin
400   if Assigned(FOnProgress) then FOnProgress(Sender);
401 end;
402
403
404 // TCompressionStream
405
406 constructor TCompressionStream.Create(CompressionLevel: TCompressionLevel;
407   Dest: TStream);
408 const
409   Levels: array [TCompressionLevel] of ShortInt =
410     (Z_NO_COMPRESSION, Z_BEST_SPEED, Z_DEFAULT_COMPRESSION, Z_BEST_COMPRESSION);
411 begin
412   inherited Create(Dest);
413   FZRec.next_out := FBuffer;
414   FZRec.avail_out := sizeof(FBuffer);
415   CCheck(deflateInit_(FZRec, Levels[CompressionLevel], zlib_version, sizeof(FZRec)));
416 end;
417
418 destructor TCompressionStream.Destroy;
419 begin
420   FZRec.next_in := nil;
421   FZRec.avail_in := 0;
422   try
423     if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;
424     while (CCheck(deflate(FZRec, Z_FINISH)) <> Z_STREAM_END)
425       and (FZRec.avail_out = 0) do
426     begin
427       FStrm.WriteBuffer(FBuffer, sizeof(FBuffer));
428       FZRec.next_out := FBuffer;
429       FZRec.avail_out := sizeof(FBuffer);
430     end;
431     if FZRec.avail_out < sizeof(FBuffer) then
432       FStrm.WriteBuffer(FBuffer, sizeof(FBuffer) - FZRec.avail_out);
433   finally
434     deflateEnd(FZRec);
435   end;
436   inherited Destroy;
437 end;
438
439 function TCompressionStream.Read(var Buffer; Count: Longint): Longint;
440 begin
441   raise ECompressionError.CreateRes(@sInvalidStreamOp);
442 end;
443
444 function TCompressionStream.Write(const Buffer; Count: Longint): Longint;
445 begin
446   FZRec.next_in := @Buffer;
447   FZRec.avail_in := Count;
448   if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;
449   while (FZRec.avail_in > 0) do
450   begin
451     CCheck(deflate(FZRec, 0));
452     if FZRec.avail_out = 0 then
453     begin
454       FStrm.WriteBuffer(FBuffer, sizeof(FBuffer));
455       FZRec.next_out := FBuffer;
456       FZRec.avail_out := sizeof(FBuffer);
457       FStrmPos := FStrm.Position;
458       Progress(Self);
459     end;
460   end;
461   Result := Count;
462 end;
463
464 function TCompressionStream.Seek(Offset: Longint; Origin: Word): Longint;
465 begin
466   if (Offset = 0) and (Origin = soFromCurrent) then
467     Result := FZRec.total_in
468   else
469     raise ECompressionError.CreateRes(@sInvalidStreamOp);
470 end;
471
472 function TCompressionStream.GetCompressionRate: Single;
473 begin
474   if FZRec.total_in = 0 then
475     Result := 0
476   else
477     Result := (1.0 - (FZRec.total_out / FZRec.total_in)) * 100.0;
478 end;
479
480
481 // TDecompressionStream
482
483 constructor TDecompressionStream.Create(Source: TStream);
484 begin
485   inherited Create(Source);
486   FZRec.next_in := FBuffer;
487   FZRec.avail_in := 0;
488   DCheck(inflateInit_(FZRec, zlib_version, sizeof(FZRec)));
489 end;
490
491 destructor TDecompressionStream.Destroy;
492 begin
493   FStrm.Seek(-FZRec.avail_in, 1);
494   inflateEnd(FZRec);
495   inherited Destroy;
496 end;
497
498 function TDecompressionStream.Read(var Buffer; Count: Longint): Longint;
499 begin
500   FZRec.next_out := @Buffer;
501   FZRec.avail_out := Count;
502   if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;
503   while (FZRec.avail_out > 0) do
504   begin
505     if FZRec.avail_in = 0 then
506     begin
507       FZRec.avail_in := FStrm.Read(FBuffer, sizeof(FBuffer));
508       if FZRec.avail_in = 0 then
509       begin
510         Result := Count - FZRec.avail_out;
511         Exit;
512       end;
513       FZRec.next_in := FBuffer;
514       FStrmPos := FStrm.Position;
515       Progress(Self);
516     end;
517     CCheck(inflate(FZRec, 0));
518   end;
519   Result := Count;
520 end;
521
522 function TDecompressionStream.Write(const Buffer; Count: Longint): Longint;
523 begin
524   raise EDecompressionError.CreateRes(@sInvalidStreamOp);
525 end;
526
527 function TDecompressionStream.Seek(Offset: Longint; Origin: Word): Longint;
528 var
529   I: Integer;
530   Buf: array [0..4095] of Char;
531 begin
532   if (Offset = 0) and (Origin = soFromBeginning) then
533   begin
534     DCheck(inflateReset(FZRec));
535     FZRec.next_in := FBuffer;
536     FZRec.avail_in := 0;
537     FStrm.Position := 0;
538     FStrmPos := 0;
539   end
540   else if ( (Offset >= 0) and (Origin = soFromCurrent)) or
541           ( ((Offset - FZRec.total_out) > 0) and (Origin = soFromBeginning)) then
542   begin
543     if Origin = soFromBeginning then Dec(Offset, FZRec.total_out);
544     if Offset > 0 then
545     begin
546       for I := 1 to Offset div sizeof(Buf) do
547         ReadBuffer(Buf, sizeof(Buf));
548       ReadBuffer(Buf, Offset mod sizeof(Buf));
549     end;
550   end
551   else
552     raise EDecompressionError.CreateRes(@sInvalidStreamOp);
553   Result := FZRec.total_out;
554 end;
555
556
557 end.