VirtualBox

source: vbox/trunk/src/libs/zlib-1.2.11/contrib/delphi/ZLib.pas@ 76163

Last change on this file since 76163 was 76163, checked in by vboxsync, 6 years ago

zlib-1.2.11 initial commit

  • Property svn:eol-style set to native
File size: 16.0 KB
Line 
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 <[email protected]> }
11
12unit ZLib;
13
14interface
15
16uses SysUtils, Classes;
17
18type
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 }
133procedure 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 }
143procedure 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 }
151procedure DecompressToUserBuf(const InBuf: Pointer; InBytes: Integer;
152 const OutBuf: Pointer; BufSize: Integer);
153
154const
155 zlib_version = '1.2.11';
156
157type
158 EZlibError = class(Exception);
159 ECompressionError = class(EZlibError);
160 EDecompressionError = class(EZlibError);
161
162implementation
163
164uses ZLibConst;
165
166const
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
212procedure adler32; external;
213procedure compressBound; external;
214procedure crc32; external;
215procedure deflateInit2_; external;
216procedure deflateParams; external;
217
218function _malloc(Size: Integer): Pointer; cdecl;
219begin
220 Result := AllocMem(Size);
221end;
222
223procedure _free(Block: Pointer); cdecl;
224begin
225 FreeMem(Block);
226end;
227
228procedure _memset(P: Pointer; B: Byte; count: Integer); cdecl;
229begin
230 FillChar(P^, count, B);
231end;
232
233procedure _memcpy(dest, source: Pointer; count: Integer); cdecl;
234begin
235 Move(source^, dest^, count);
236end;
237
238
239
240// deflate compresses data
241function deflateInit_(var strm: TZStreamRec; level: Integer; version: PChar;
242 recsize: Integer): Integer; external;
243function deflate(var strm: TZStreamRec; flush: Integer): Integer; external;
244function deflateEnd(var strm: TZStreamRec): Integer; external;
245
246// inflate decompresses data
247function inflateInit_(var strm: TZStreamRec; version: PChar;
248 recsize: Integer): Integer; external;
249function inflate(var strm: TZStreamRec; flush: Integer): Integer; external;
250function inflateEnd(var strm: TZStreamRec): Integer; external;
251function inflateReset(var strm: TZStreamRec): Integer; external;
252
253
254function zlibAllocMem(AppData: Pointer; Items, Size: Integer): Pointer; cdecl;
255begin
256// GetMem(Result, Items*Size);
257 Result := AllocMem(Items * Size);
258end;
259
260procedure zlibFreeMem(AppData, Block: Pointer); cdecl;
261begin
262 FreeMem(Block);
263end;
264
265{function zlibCheck(code: Integer): Integer;
266begin
267 Result := code;
268 if code < 0 then
269 raise EZlibError.Create('error'); //!!
270end;}
271
272function CCheck(code: Integer): Integer;
273begin
274 Result := code;
275 if code < 0 then
276 raise ECompressionError.Create('error'); //!!
277end;
278
279function DCheck(code: Integer): Integer;
280begin
281 Result := code;
282 if code < 0 then
283 raise EDecompressionError.Create('error'); //!!
284end;
285
286procedure CompressBuf(const InBuf: Pointer; InBytes: Integer;
287 out OutBuf: Pointer; out OutBytes: Integer);
288var
289 strm: TZStreamRec;
290 P: Pointer;
291begin
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;
321end;
322
323
324procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer;
325 OutEstimate: Integer; out OutBuf: Pointer; out OutBytes: Integer);
326var
327 strm: TZStreamRec;
328 P: Pointer;
329 BufInc: Integer;
330begin
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;
364end;
365
366procedure DecompressToUserBuf(const InBuf: Pointer; InBytes: Integer;
367 const OutBuf: Pointer; BufSize: Integer);
368var
369 strm: TZStreamRec;
370begin
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;
385end;
386
387// TCustomZlibStream
388
389constructor TCustomZLibStream.Create(Strm: TStream);
390begin
391 inherited Create;
392 FStrm := Strm;
393 FStrmPos := Strm.Position;
394 FZRec.zalloc := zlibAllocMem;
395 FZRec.zfree := zlibFreeMem;
396end;
397
398procedure TCustomZLibStream.Progress(Sender: TObject);
399begin
400 if Assigned(FOnProgress) then FOnProgress(Sender);
401end;
402
403
404// TCompressionStream
405
406constructor TCompressionStream.Create(CompressionLevel: TCompressionLevel;
407 Dest: TStream);
408const
409 Levels: array [TCompressionLevel] of ShortInt =
410 (Z_NO_COMPRESSION, Z_BEST_SPEED, Z_DEFAULT_COMPRESSION, Z_BEST_COMPRESSION);
411begin
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)));
416end;
417
418destructor TCompressionStream.Destroy;
419begin
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;
437end;
438
439function TCompressionStream.Read(var Buffer; Count: Longint): Longint;
440begin
441 raise ECompressionError.CreateRes(@sInvalidStreamOp);
442end;
443
444function TCompressionStream.Write(const Buffer; Count: Longint): Longint;
445begin
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;
462end;
463
464function TCompressionStream.Seek(Offset: Longint; Origin: Word): Longint;
465begin
466 if (Offset = 0) and (Origin = soFromCurrent) then
467 Result := FZRec.total_in
468 else
469 raise ECompressionError.CreateRes(@sInvalidStreamOp);
470end;
471
472function TCompressionStream.GetCompressionRate: Single;
473begin
474 if FZRec.total_in = 0 then
475 Result := 0
476 else
477 Result := (1.0 - (FZRec.total_out / FZRec.total_in)) * 100.0;
478end;
479
480
481// TDecompressionStream
482
483constructor TDecompressionStream.Create(Source: TStream);
484begin
485 inherited Create(Source);
486 FZRec.next_in := FBuffer;
487 FZRec.avail_in := 0;
488 DCheck(inflateInit_(FZRec, zlib_version, sizeof(FZRec)));
489end;
490
491destructor TDecompressionStream.Destroy;
492begin
493 FStrm.Seek(-FZRec.avail_in, 1);
494 inflateEnd(FZRec);
495 inherited Destroy;
496end;
497
498function TDecompressionStream.Read(var Buffer; Count: Longint): Longint;
499begin
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;
520end;
521
522function TDecompressionStream.Write(const Buffer; Count: Longint): Longint;
523begin
524 raise EDecompressionError.CreateRes(@sInvalidStreamOp);
525end;
526
527function TDecompressionStream.Seek(Offset: Longint; Origin: Word): Longint;
528var
529 I: Integer;
530 Buf: array [0..4095] of Char;
531begin
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;
554end;
555
556
557end.
Note: See TracBrowser for help on using the repository browser.

© 2024 Oracle Support Privacy / Do Not Sell My Info Terms of Use Trademark Policy Automated Access Etiquette