Home | History | Annotate | Download | only in delphi
      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 (a] 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.6';
    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.
    558