lib/zlib/contrib/delphi2/zlib.pas

   1 {*******************************************************}
   2 {                                                       }
   3 {       Delphi Supplemental Components                  }
   4 {       ZLIB Data Compression Interface Unit            }
   5 {                                                       }
   6 {       Copyright (c) 1997 Borland International        }
   7 {                                                       }
   8 {*******************************************************}
   9
  10 { Modified for zlib 1.1.3 by Davide Moretti <dave@rimini.com }
  11
  12 unit zlib;
  13
  14 interface
  15
  16 uses Sysutils, Classes;
  17
  18 type
  19   TAlloc = function (AppData: Pointer; Items, Size: Integer): Pointer;
  20   TFree = procedure (AppData, Block: Pointer);
  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: Integer;    // 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: Integer;   // 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: Integer;       // adler32 value of the uncompressed data
  41     reserved: Integer;    // 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 const
 147   zlib_version = '1.1.3';
 148
 149 type
 150   EZlibError = class(Exception);
 151   ECompressionError = class(EZlibError);
 152   EDecompressionError = class(EZlibError);
 153
 154 function adler32(adler: Integer; buf: PChar; len: Integer): Integer;
 155
 156 implementation
 157
 158 const
 159   Z_NO_FLUSH      = 0;
 160   Z_PARTIAL_FLUSH = 1;
 161   Z_SYNC_FLUSH    = 2;
 162   Z_FULL_FLUSH    = 3;
 163   Z_FINISH        = 4;
 164
 165   Z_OK            = 0;
 166   Z_STREAM_END    = 1;
 167   Z_NEED_DICT     = 2;
 168   Z_ERRNO         = (-1);
 169   Z_STREAM_ERROR  = (-2);
 170   Z_DATA_ERROR    = (-3);
 171   Z_MEM_ERROR     = (-4);
 172   Z_BUF_ERROR     = (-5);
 173   Z_VERSION_ERROR = (-6);
 174
 175   Z_NO_COMPRESSION       =   0;
 176   Z_BEST_SPEED           =   1;
 177   Z_BEST_COMPRESSION     =   9;
 178   Z_DEFAULT_COMPRESSION  = (-1);
 179
 180   Z_FILTERED            = 1;
 181   Z_HUFFMAN_ONLY        = 2;
 182   Z_DEFAULT_STRATEGY    = 0;
 183
 184   Z_BINARY   = 0;
 185   Z_ASCII    = 1;
 186   Z_UNKNOWN  = 2;
 187
 188   Z_DEFLATED = 8;
 189
 190   _z_errmsg: array[0..9] of PChar = (
 191     'need dictionary',      // Z_NEED_DICT      (2)
 192     'stream end',           // Z_STREAM_END     (1)
 193     '',                     // Z_OK             (0)
 194     'file error',           // Z_ERRNO          (-1)
 195     'stream error',         // Z_STREAM_ERROR   (-2)
 196     'data error',           // Z_DATA_ERROR     (-3)
 197     'insufficient memory',  // Z_MEM_ERROR      (-4)
 198     'buffer error',         // Z_BUF_ERROR      (-5)
 199     'incompatible version', // Z_VERSION_ERROR  (-6)
 200     ''
 201   );
 202
 203 {$L deflate.obj}
 204 {$L inflate.obj}
 205 {$L inftrees.obj}
 206 {$L trees.obj}
 207 {$L adler32.obj}
 208 {$L infblock.obj}
 209 {$L infcodes.obj}
 210 {$L infutil.obj}
 211 {$L inffast.obj}
 212
 213 procedure _tr_init; external;
 214 procedure _tr_tally; external;
 215 procedure _tr_flush_block; external;
 216 procedure _tr_align; external;
 217 procedure _tr_stored_block; external;
 218 function adler32; external;
 219 procedure inflate_blocks_new; external;
 220 procedure inflate_blocks; external;
 221 procedure inflate_blocks_reset; external;
 222 procedure inflate_blocks_free; external;
 223 procedure inflate_set_dictionary; external;
 224 procedure inflate_trees_bits; external;
 225 procedure inflate_trees_dynamic; external;
 226 procedure inflate_trees_fixed; external;
 227 procedure inflate_codes_new; external;
 228 procedure inflate_codes; external;
 229 procedure inflate_codes_free; external;
 230 procedure _inflate_mask; external;
 231 procedure inflate_flush; external;
 232 procedure inflate_fast; external;
 233
 234 procedure _memset(P: Pointer; B: Byte; count: Integer);cdecl;
 235 begin
 236   FillChar(P^, count, B);
 237 end;
 238
 239 procedure _memcpy(dest, source: Pointer; count: Integer);cdecl;
 240 begin
 241   Move(source^, dest^, count);
 242 end;
 243
 244
 245
 246 // deflate compresses data
 247 function deflateInit_(var strm: TZStreamRec; level: Integer; version: PChar;
 248   recsize: Integer): Integer; external;
 249 function deflate(var strm: TZStreamRec; flush: Integer): Integer; external;
 250 function deflateEnd(var strm: TZStreamRec): Integer; external;
 251
 252 // inflate decompresses data
 253 function inflateInit_(var strm: TZStreamRec; version: PChar;
 254   recsize: Integer): Integer; external;
 255 function inflate(var strm: TZStreamRec; flush: Integer): Integer; external;
 256 function inflateEnd(var strm: TZStreamRec): Integer; external;
 257 function inflateReset(var strm: TZStreamRec): Integer; external;
 258
 259
 260 function zcalloc(AppData: Pointer; Items, Size: Integer): Pointer;
 261 begin
 262   GetMem(Result, Items*Size);
 263 end;
 264
 265 procedure zcfree(AppData, Block: Pointer);
 266 begin
 267   FreeMem(Block);
 268 end;
 269
 270 function zlibCheck(code: Integer): Integer;
 271 begin
 272   Result := code;
 273   if code < 0 then
 274     raise EZlibError.Create('error');    //!!
 275 end;
 276
 277 function CCheck(code: Integer): Integer;
 278 begin
 279   Result := code;
 280   if code < 0 then
 281     raise ECompressionError.Create('error'); //!!
 282 end;
 283
 284 function DCheck(code: Integer): Integer;
 285 begin
 286   Result := code;
 287   if code < 0 then
 288     raise EDecompressionError.Create('error');  //!!
 289 end;
 290
 291 procedure CompressBuf(const InBuf: Pointer; InBytes: Integer;
 292                       out OutBuf: Pointer; out OutBytes: Integer);
 293 var
 294   strm: TZStreamRec;
 295   P: Pointer;
 296 begin
 297   FillChar(strm, sizeof(strm), 0);
 298   OutBytes := ((InBytes + (InBytes div 10) + 12) + 255) and not 255;
 299   GetMem(OutBuf, OutBytes);
 300   try
 301     strm.next_in := InBuf;
 302     strm.avail_in := InBytes;
 303     strm.next_out := OutBuf;
 304     strm.avail_out := OutBytes;
 305     CCheck(deflateInit_(strm, Z_BEST_COMPRESSION, zlib_version, sizeof(strm)));
 306     try
 307       while CCheck(deflate(strm, Z_FINISH)) <> Z_STREAM_END do
 308       begin
 309         P := OutBuf;
 310         Inc(OutBytes, 256);
 311         ReallocMem(OutBuf, OutBytes);
 312         strm.next_out := PChar(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P)));
 313         strm.avail_out := 256;
 314       end;
 315     finally
 316       CCheck(deflateEnd(strm));
 317     end;
 318     ReallocMem(OutBuf, strm.total_out);
 319     OutBytes := strm.total_out;
 320   except
 321     FreeMem(OutBuf);
 322     raise
 323   end;
 324 end;
 325
 326
 327 procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer;
 328   OutEstimate: Integer; out OutBuf: Pointer; out OutBytes: Integer);
 329 var
 330   strm: TZStreamRec;
 331   P: Pointer;
 332   BufInc: Integer;
 333 begin
 334   FillChar(strm, sizeof(strm), 0);
 335   BufInc := (InBytes + 255) and not 255;
 336   if OutEstimate = 0 then
 337     OutBytes := BufInc
 338   else
 339     OutBytes := OutEstimate;
 340   GetMem(OutBuf, OutBytes);
 341   try
 342     strm.next_in := InBuf;
 343     strm.avail_in := InBytes;
 344     strm.next_out := OutBuf;
 345     strm.avail_out := OutBytes;
 346     DCheck(inflateInit_(strm, zlib_version, sizeof(strm)));
 347     try
 348       while DCheck(inflate(strm, Z_FINISH)) <> Z_STREAM_END do
 349       begin
 350         P := OutBuf;
 351         Inc(OutBytes, BufInc);
 352         ReallocMem(OutBuf, OutBytes);
 353         strm.next_out := PChar(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P)));
 354         strm.avail_out := BufInc;
 355       end;
 356     finally
 357       DCheck(inflateEnd(strm));
 358     end;
 359     ReallocMem(OutBuf, strm.total_out);
 360     OutBytes := strm.total_out;
 361   except
 362     FreeMem(OutBuf);
 363     raise
 364   end;
 365 end;
 366
 367
 368 // TCustomZlibStream
 369
 370 constructor TCustomZLibStream.Create(Strm: TStream);
 371 begin
 372   inherited Create;
 373   FStrm := Strm;
 374   FStrmPos := Strm.Position;
 375 end;
 376
 377 procedure TCustomZLibStream.Progress(Sender: TObject);
 378 begin
 379   if Assigned(FOnProgress) then FOnProgress(Sender);
 380 end;
 381
 382
 383 // TCompressionStream
 384
 385 constructor TCompressionStream.Create(CompressionLevel: TCompressionLevel;
 386   Dest: TStream);
 387 const
 388   Levels: array [TCompressionLevel] of ShortInt =
 389     (Z_NO_COMPRESSION, Z_BEST_SPEED, Z_DEFAULT_COMPRESSION, Z_BEST_COMPRESSION);
 390 begin
 391   inherited Create(Dest);
 392   FZRec.next_out := FBuffer;
 393   FZRec.avail_out := sizeof(FBuffer);
 394   CCheck(deflateInit_(FZRec, Levels[CompressionLevel], zlib_version, sizeof(FZRec)));
 395 end;
 396
 397 destructor TCompressionStream.Destroy;
 398 begin
 399   FZRec.next_in := nil;
 400   FZRec.avail_in := 0;
 401   try
 402     if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;
 403     while (CCheck(deflate(FZRec, Z_FINISH)) <> Z_STREAM_END)
 404       and (FZRec.avail_out = 0) do
 405     begin
 406       FStrm.WriteBuffer(FBuffer, sizeof(FBuffer));
 407       FZRec.next_out := FBuffer;
 408       FZRec.avail_out := sizeof(FBuffer);
 409     end;
 410     if FZRec.avail_out < sizeof(FBuffer) then
 411       FStrm.WriteBuffer(FBuffer, sizeof(FBuffer) - FZRec.avail_out);
 412   finally
 413     deflateEnd(FZRec);
 414   end;
 415   inherited Destroy;
 416 end;
 417
 418 function TCompressionStream.Read(var Buffer; Count: Longint): Longint;
 419 begin
 420   raise ECompressionError.Create('Invalid stream operation');
 421 end;
 422
 423 function TCompressionStream.Write(const Buffer; Count: Longint): Longint;
 424 begin
 425   FZRec.next_in := @Buffer;
 426   FZRec.avail_in := Count;
 427   if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;
 428   while (FZRec.avail_in > 0) do
 429   begin
 430     CCheck(deflate(FZRec, 0));
 431     if FZRec.avail_out = 0 then
 432     begin
 433       FStrm.WriteBuffer(FBuffer, sizeof(FBuffer));
 434       FZRec.next_out := FBuffer;
 435       FZRec.avail_out := sizeof(FBuffer);
 436       FStrmPos := FStrm.Position;
 437       Progress(Self);
 438     end;
 439   end;
 440   Result := Count;
 441 end;
 442
 443 function TCompressionStream.Seek(Offset: Longint; Origin: Word): Longint;
 444 begin
 445   if (Offset = 0) and (Origin = soFromCurrent) then
 446     Result := FZRec.total_in
 447   else
 448     raise ECompressionError.Create('Invalid stream operation');
 449 end;
 450
 451 function TCompressionStream.GetCompressionRate: Single;
 452 begin
 453   if FZRec.total_in = 0 then
 454     Result := 0
 455   else
 456     Result := (1.0 - (FZRec.total_out / FZRec.total_in)) * 100.0;
 457 end;
 458
 459
 460 // TDecompressionStream
 461
 462 constructor TDecompressionStream.Create(Source: TStream);
 463 begin
 464   inherited Create(Source);
 465   FZRec.next_in := FBuffer;
 466   FZRec.avail_in := 0;
 467   DCheck(inflateInit_(FZRec, zlib_version, sizeof(FZRec)));
 468 end;
 469
 470 destructor TDecompressionStream.Destroy;
 471 begin
 472   inflateEnd(FZRec);
 473   inherited Destroy;
 474 end;
 475
 476 function TDecompressionStream.Read(var Buffer; Count: Longint): Longint;
 477 begin
 478   FZRec.next_out := @Buffer;
 479   FZRec.avail_out := Count;
 480   if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;
 481   while (FZRec.avail_out > 0) do
 482   begin
 483     if FZRec.avail_in = 0 then
 484     begin
 485       FZRec.avail_in := FStrm.Read(FBuffer, sizeof(FBuffer));
 486       if FZRec.avail_in = 0 then
 487         begin
 488           Result := Count - FZRec.avail_out;
 489           Exit;
 490         end;
 491       FZRec.next_in := FBuffer;
 492       FStrmPos := FStrm.Position;
 493       Progress(Self);
 494     end;
 495     DCheck(inflate(FZRec, 0));
 496   end;
 497   Result := Count;
 498 end;
 499
 500 function TDecompressionStream.Write(const Buffer; Count: Longint): Longint;
 501 begin
 502   raise EDecompressionError.Create('Invalid stream operation');
 503 end;
 504
 505 function TDecompressionStream.Seek(Offset: Longint; Origin: Word): Longint;
 506 var
 507   I: Integer;
 508   Buf: array [0..4095] of Char;
 509 begin
 510   if (Offset = 0) and (Origin = soFromBeginning) then
 511   begin
 512     DCheck(inflateReset(FZRec));
 513     FZRec.next_in := FBuffer;
 514     FZRec.avail_in := 0;
 515     FStrm.Position := 0;
 516     FStrmPos := 0;
 517   end
 518   else if ( (Offset >= 0) and (Origin = soFromCurrent)) or
 519           ( ((Offset - FZRec.total_out) > 0) and (Origin = soFromBeginning)) then
 520   begin
 521     if Origin = soFromBeginning then Dec(Offset, FZRec.total_out);
 522     if Offset > 0 then
 523     begin
 524       for I := 1 to Offset div sizeof(Buf) do
 525         ReadBuffer(Buf, sizeof(Buf));
 526       ReadBuffer(Buf, Offset mod sizeof(Buf));
 527     end;
 528   end
 529   else
 530     raise EDecompressionError.Create('Invalid stream operation');
 531   Result := FZRec.total_out;
 532 end;
 533
 534 end.