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.8';
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.