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

   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.