common/dist/zlib/contrib/delphi/ZLib.pas

   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.