source: rtems/cpukit/zlib/contrib/delphi/ZLib.pas @ 28f0f60a

4.115
Last change on this file since 28f0f60a was 28f0f60a, checked in by Ralf Corsepius <ralf.corsepius@…>, on 03/18/11 at 10:11:17

Import from zlib-1.2.4

  • Property mode set to 100644
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 <cosmint@cs.ubbcluj.ro> }
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.4';
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.