src/lib/vampimg/ZLib/dzlib.pas

   1 {*******************************************************}
   2 {                                                       }
   3 {       Delphi Supplemental Components                  }
   4 {       ZLIB Data Compression Interface Unit            }
   5 {                                                       }
   6 {       Copyright (c) 1997 Borland International        }
   7 {       Copyright (c) 1998 Jacques Nomssi Nzali         }
   8 {                                                       }
   9 {*******************************************************}
  10
  11 {
  12   Modified for
  13   Vampyre Imaging Library
  14   by Marek Mauder
  15   http://imaginglib.sourceforge.net
  16
  17   You can choose which pascal zlib implementation will be
  18   used. IMPASZLIB and FPCPASZLIB are translations of zlib
  19   to pascal so they don't need any *.obj files.
  20   The others are interfaces to *.obj files (Windows) or
  21   *.so libraries (Linux).
  22     Default implementation is IMPASZLIB because it can be compiled
  23   by all supported compilers and works on all supported platforms.
  24   I usually use implementation with the fastest decompression
  25   when building release Win32 binaries.
  26     FPCPASZLIB is useful for Lazarus applications. FPC's zlib is linked
  27   to exe by default so there is no need to link additional (and almost identical)
  28   IMPASZLIB.
  29
  30   There is a small speed comparison table of some of the
  31   supported implementations (TGA image 28 311 570 bytes, compression level = 6,
  32   Delphi 9, Win32, Athlon XP 1900).
  33
  34                  ZLib version Decompression  Compression   Comp. Size
  35   IMPASZLIB     |   1.1.2   |    824 ms    |  4 280 ms  |  18 760 133 B
  36   ZLIBEX        |   1.2.2   |    710 ms    |  1 590 ms* |  19 056 621 B
  37   DELPHIZLIB    |   1.0.4   |    976 ms    |  9 190 ms  |  18 365 562 B
  38   ZLIBPAS       |   1.2.3   |    680 ms    |  3 790  ms |  18 365 387 B
  39     * obj files are compiled with compression level hardcoded to 1 (fastest)
  40 }
  41
  42 unit dzlib;
  43
  44 {$I ImagingOptions.inc}
  45
  46 interface
  47
  48 { $DEFINE ZLIBEX}
  49 { $DEFINE DELPHIZLIB}
  50 { $DEFINE ZLIBPAS}
  51 {$DEFINE IMPASZLIB}
  52 { $DEFINE FPCPASZLIB}
  53
  54 { Automatically use FPC's PasZLib when compiling with Lazarus.}
  55
  56 {$IFDEF LCL}
  57   {$UNDEF IMPASZLIB}
  58   {$DEFINE FPCPASZLIB}
  59 {$ENDIF}
  60
  61 uses
  62 {$IF Defined(ZLIBEX)}
  63   { Use ZlibEx unit.}
  64   ZLibEx,
  65 {$ELSEIF Defined(DELPHIZLIB)}
  66   { Use ZLib unit shipped with Delphi.}
  67   ZLib,
  68 {$ELSEIF Defined(ZLIBPAS)}
  69   { Pascal interface to ZLib shipped with ZLib C source.}
  70   zlibpas,
  71 {$ELSEIF Defined(IMPASZLIB)}
  72   { Use paszlib modified by me for Delphi and FPC.}
  73   imzdeflate, imzinflate, impaszlib,
  74 {$ELSEIF Defined(FPCPASZLIB)}
  75   { Use FPC's paszlib.}
  76   zbase, paszlib,
  77 {$IFEND}
  78   SysUtils, Classes;
  79
  80 {$IF Defined(IMPASZLIB) or Defined(FPCPASZLIB) or Defined(ZLIBPAS)}
  81 type
  82   TZStreamRec = z_stream;
  83 {$IFEND}
  84 {$IFDEF ZLIBEX}
  85 const
  86   Z_NO_FLUSH      = 0;
  87   Z_PARTIAL_FLUSH = 1;
  88   Z_SYNC_FLUSH    = 2;
  89   Z_FULL_FLUSH    = 3;
  90   Z_FINISH        = 4;
  91
  92   Z_OK            =  0;
  93   Z_STREAM_END    =  1;
  94   Z_NEED_DICT     =  2;
  95   Z_ERRNO         = -1;
  96   Z_STREAM_ERROR  = -2;
  97   Z_DATA_ERROR    = -3;
  98   Z_MEM_ERROR     = -4;
  99   Z_BUF_ERROR     = -5;
 100   Z_VERSION_ERROR = -6;
 101
 102   Z_NO_COMPRESSION       =  0;
 103   Z_BEST_SPEED           =  1;
 104   Z_BEST_COMPRESSION     =  9;
 105   Z_DEFAULT_COMPRESSION  = -1;
 106
 107   Z_FILTERED            = 1;
 108   Z_HUFFMAN_ONLY        = 2;
 109   Z_RLE                 = 3;
 110   Z_DEFAULT_STRATEGY    = 0;
 111
 112   Z_BINARY   = 0;
 113   Z_ASCII    = 1;
 114   Z_UNKNOWN  = 2;
 115
 116   Z_DEFLATED = 8;
 117 {$ENDIF}
 118
 119 type
 120   { Abstract ancestor class }
 121   TCustomZlibStream = class(TStream)
 122   private
 123     FStrm: TStream;
 124     FStrmPos: Integer;
 125     FOnProgress: TNotifyEvent;
 126     FZRec: TZStreamRec;
 127     FBuffer: array [Word] of Byte;
 128   protected
 129     procedure Progress(Sender: TObject); dynamic;
 130     property OnProgress: TNotifyEvent read FOnProgress write FOnProgress;
 131     constructor Create(Strm: TStream);
 132   end;
 133
 134 { TCompressionStream compresses data on the fly as data is written to it, and
 135   stores the compressed data to another stream.
 136
 137   TCompressionStream is write-only and strictly sequential. Reading from the
 138   stream will raise an exception. Using Seek to move the stream pointer
 139   will raise an exception.
 140
 141   Output data is cached internally, written to the output stream only when
 142   the internal output buffer is full.  All pending output data is flushed
 143   when the stream is destroyed.
 144
 145   The Position property returns the number of uncompressed bytes of
 146   data that have been written to the stream so far.
 147
 148   CompressionRate returns the on-the-fly percentage by which the original
 149   data has been compressed:  (1 - (CompressedBytes / UncompressedBytes)) * 100
 150   If raw data size = 100 and compressed data size = 25, the CompressionRate
 151   is 75%
 152
 153   The OnProgress event is called each time the output buffer is filled and
 154   written to the output stream.  This is useful for updating a progress
 155   indicator when you are writing a large chunk of data to the compression
 156   stream in a single call.}
 157
 158
 159   TCompressionLevel = (clNone, clFastest, clDefault, clMax);
 160
 161   TCompressionStream = class(TCustomZlibStream)
 162   private
 163     function GetCompressionRate: Single;
 164   public
 165     constructor Create(CompressionLevel: TCompressionLevel; Dest: TStream);
 166     destructor Destroy; override;
 167     function Read(var Buffer; Count: Longint): Longint; override;
 168     function Write(const Buffer; Count: Longint): Longint; override;
 169     function Seek(Offset: Longint; Origin: Word): Longint; override;
 170     property CompressionRate: Single read GetCompressionRate;
 171     property OnProgress;
 172   end;
 173
 174 { TDecompressionStream decompresses data on the fly as data is read from it.
 175
 176   Compressed data comes from a separate source stream.  TDecompressionStream
 177   is read-only and unidirectional; you can seek forward in the stream, but not
 178   backwards.  The special case of setting the stream position to zero is
 179   allowed.  Seeking forward decompresses data until the requested position in
 180   the uncompressed data has been reached.  Seeking backwards, seeking relative
 181   to the end of the stream, requesting the size of the stream, and writing to
 182   the stream will raise an exception.
 183
 184   The Position property returns the number of bytes of uncompressed data that
 185   have been read from the stream so far.
 186
 187   The OnProgress event is called each time the internal input buffer of
 188   compressed data is exhausted and the next block is read from the input stream.
 189   This is useful for updating a progress indicator when you are reading a
 190   large chunk of data from the decompression stream in a single call.}
 191
 192   TDecompressionStream = class(TCustomZlibStream)
 193   public
 194     constructor Create(Source: TStream);
 195     destructor Destroy; override;
 196     function Read(var Buffer; Count: Longint): Longint; override;
 197     function Write(const Buffer; Count: Longint): Longint; override;
 198     function Seek(Offset: Longint; Origin: Word): Longint; override;
 199     property OnProgress;
 200   end;
 201
 202
 203
 204 { CompressBuf compresses data, buffer to buffer, in one call.
 205    In: InBuf = ptr to compressed data
 206        InBytes = number of bytes in InBuf
 207   Out: OutBuf = ptr to newly allocated buffer containing decompressed data
 208        OutBytes = number of bytes in OutBuf   }
 209 procedure CompressBuf(const InBuf: Pointer; InBytes: Integer;
 210                       var OutBuf: Pointer; var OutBytes: Integer;
 211                       CompressLevel: Integer = Z_DEFAULT_COMPRESSION);
 212
 213 { DecompressBuf decompresses data, buffer to buffer, in one call.
 214    In: InBuf = ptr to compressed data
 215        InBytes = number of bytes in InBuf
 216        OutEstimate = zero, or est. size of the decompressed data
 217   Out: OutBuf = ptr to newly allocated buffer containing decompressed data
 218        OutBytes = number of bytes in OutBuf   }
 219 procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer;
 220  OutEstimate: Integer; var OutBuf: Pointer; var OutBytes: Integer);
 221
 222
 223 type
 224   EZlibError = class(Exception);
 225   ECompressionError = class(EZlibError);
 226   EDecompressionError = class(EZlibError);
 227
 228 implementation
 229
 230 const
 231   ZErrorMessages: array[0..9] of PAnsiChar = (
 232     'need dictionary',        // Z_NEED_DICT      (2)
 233     'stream end',             // Z_STREAM_END     (1)
 234     '',                       // Z_OK             (0)
 235     'file error',             // Z_ERRNO          (-1)
 236     'stream error',           // Z_STREAM_ERROR   (-2)
 237     'data error',             // Z_DATA_ERROR     (-3)
 238     'insufficient memory',    // Z_MEM_ERROR      (-4)
 239     'buffer error',           // Z_BUF_ERROR      (-5)
 240     'incompatible version',   // Z_VERSION_ERROR  (-6)
 241     '');
 242
 243 function zlibAllocMem(AppData: Pointer; Items, Size: Cardinal): Pointer;
 244 begin
 245   GetMem(Result, Items*Size);
 246 end;
 247
 248 procedure zlibFreeMem(AppData, Block: Pointer);
 249 begin
 250   FreeMem(Block);
 251 end;
 252
 253 function CCheck(code: Integer): Integer;
 254 begin
 255   Result := code;
 256   if code < 0 then
 257     raise ECompressionError.Create('zlib: ' + ZErrorMessages[2 - code]);
 258 end;
 259
 260 function DCheck(code: Integer): Integer;
 261 begin
 262   Result := code;
 263   if code < 0 then
 264     raise EDecompressionError.Create('zlib: ' + ZErrorMessages[2 - code]);
 265 end;
 266
 267 procedure CompressBuf(const InBuf: Pointer; InBytes: Integer;
 268                       var OutBuf: Pointer; var OutBytes: Integer;
 269                       CompressLevel: Integer);
 270 var
 271   strm: TZStreamRec;
 272   P: Pointer;
 273 begin
 274   FillChar(strm, sizeof(strm), 0);
 275 {$IFNDEF FPCPASZLIB}
 276   strm.zalloc := @zlibAllocMem;
 277   strm.zfree := @zlibFreeMem;
 278 {$ENDIF}
 279   OutBytes := ((InBytes + (InBytes div 10) + 12) + 255) and not 255;
 280   GetMem(OutBuf, OutBytes);
 281   try
 282     strm.next_in := InBuf;
 283     strm.avail_in := InBytes;
 284     strm.next_out := OutBuf;
 285     strm.avail_out := OutBytes;
 286     CCheck(deflateInit_(strm, CompressLevel, zlib_version, sizeof(strm)));
 287     try
 288       while CCheck(deflate(strm, Z_FINISH)) <> Z_STREAM_END do
 289       begin
 290         P := OutBuf;
 291         Inc(OutBytes, 256);
 292         ReallocMem(OutBuf, OutBytes);
 293         strm.next_out := Pointer(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P)));
 294         strm.avail_out := 256;
 295       end;
 296     finally
 297       CCheck(deflateEnd(strm));
 298     end;
 299     ReallocMem(OutBuf, strm.total_out);
 300     OutBytes := strm.total_out;
 301   except
 302     zlibFreeMem(nil, OutBuf);
 303     raise
 304   end;
 305 end;
 306
 307 procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer;
 308  OutEstimate: Integer; var OutBuf: Pointer; var OutBytes: Integer);
 309 var
 310   strm: TZStreamRec;
 311   P: Pointer;
 312   BufInc: Integer;
 313 begin
 314   FillChar(strm, sizeof(strm), 0);
 315 {$IFNDEF FPCPASZLIB}
 316   strm.zalloc := @zlibAllocMem;
 317   strm.zfree := @zlibFreeMem;
 318 {$ENDIF}
 319   BufInc := (InBytes + 255) and not 255;
 320   if OutEstimate = 0 then
 321     OutBytes := BufInc
 322   else
 323     OutBytes := OutEstimate;
 324   GetMem(OutBuf, OutBytes);
 325   try
 326     strm.next_in := InBuf;
 327     strm.avail_in := InBytes;
 328     strm.next_out := OutBuf;
 329     strm.avail_out := OutBytes;
 330     DCheck(inflateInit_(strm, zlib_version, sizeof(strm)));
 331     try
 332       while DCheck(inflate(strm, Z_NO_FLUSH)) <> Z_STREAM_END do
 333       begin
 334         P := OutBuf;
 335         Inc(OutBytes, BufInc);
 336         ReallocMem(OutBuf, OutBytes);
 337         strm.next_out := Pointer(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P)));
 338         strm.avail_out := BufInc;
 339       end;
 340     finally
 341       DCheck(inflateEnd(strm));
 342     end;
 343     ReallocMem(OutBuf, strm.total_out);
 344     OutBytes := strm.total_out;
 345   except
 346     zlibFreeMem(nil, OutBuf);
 347     raise
 348   end;
 349 end;
 350
 351
 352 { TCustomZlibStream }
 353
 354 constructor TCustomZLibStream.Create(Strm: TStream);
 355 begin
 356   inherited Create;
 357   FStrm := Strm;
 358   FStrmPos := Strm.Position;
 359 {$IFNDEF FPCPASZLIB}
 360   FZRec.zalloc := @zlibAllocMem;
 361   FZRec.zfree := @zlibFreeMem;
 362 {$ENDIF}
 363 end;
 364
 365 procedure TCustomZLibStream.Progress(Sender: TObject);
 366 begin
 367   if Assigned(FOnProgress) then FOnProgress(Sender);
 368 end;
 369
 370 { TCompressionStream }
 371
 372 constructor TCompressionStream.Create(CompressionLevel: TCompressionLevel;
 373   Dest: TStream);
 374 const
 375   Levels: array [TCompressionLevel] of ShortInt =
 376     (Z_NO_COMPRESSION, Z_BEST_SPEED, Z_DEFAULT_COMPRESSION, Z_BEST_COMPRESSION);
 377 begin
 378   inherited Create(Dest);
 379   FZRec.next_out := @FBuffer;
 380   FZRec.avail_out := sizeof(FBuffer);
 381   CCheck(deflateInit_(FZRec, Levels[CompressionLevel], zlib_version, sizeof(FZRec)));
 382 end;
 383
 384 destructor TCompressionStream.Destroy;
 385 begin
 386   FZRec.next_in := nil;
 387   FZRec.avail_in := 0;
 388   try
 389     if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;
 390     while (CCheck(deflate(FZRec, Z_FINISH)) <> Z_STREAM_END)
 391       and (FZRec.avail_out = 0) do
 392     begin
 393       FStrm.WriteBuffer(FBuffer, sizeof(FBuffer));
 394       FZRec.next_out := @FBuffer;
 395       FZRec.avail_out := sizeof(FBuffer);
 396     end;
 397     if FZRec.avail_out < sizeof(FBuffer) then
 398       FStrm.WriteBuffer(FBuffer, sizeof(FBuffer) - FZRec.avail_out);
 399   finally
 400     deflateEnd(FZRec);
 401   end;
 402   inherited Destroy;
 403 end;
 404
 405 function TCompressionStream.Read(var Buffer; Count: Longint): Longint;
 406 begin
 407   raise ECompressionError.Create('Invalid stream operation');
 408 end;
 409
 410 function TCompressionStream.Write(const Buffer; Count: Longint): Longint;
 411 begin
 412   FZRec.next_in := @Buffer;
 413   FZRec.avail_in := Count;
 414   if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;
 415   while (FZRec.avail_in > 0) do
 416   begin
 417     CCheck(deflate(FZRec, 0));
 418     if FZRec.avail_out = 0 then
 419     begin
 420       FStrm.WriteBuffer(FBuffer, sizeof(FBuffer));
 421       FZRec.next_out := @FBuffer;
 422       FZRec.avail_out := sizeof(FBuffer);
 423       FStrmPos := FStrm.Position;
 424       Progress(Self);
 425     end;
 426   end;
 427   Result := Count;
 428 end;
 429
 430 function TCompressionStream.Seek(Offset: Longint; Origin: Word): Longint;
 431 begin
 432   if (Offset = 0) and (Origin = soFromCurrent) then
 433     Result := FZRec.total_in
 434   else
 435     raise ECompressionError.Create('Invalid stream operation');
 436 end;
 437
 438 function TCompressionStream.GetCompressionRate: Single;
 439 begin
 440   if FZRec.total_in = 0 then
 441     Result := 0
 442   else
 443     Result := (1.0 - (FZRec.total_out / FZRec.total_in)) * 100.0;
 444 end;
 445
 446 { TDecompressionStream }
 447
 448 constructor TDecompressionStream.Create(Source: TStream);
 449 begin
 450   inherited Create(Source);
 451   FZRec.next_in := @FBuffer;
 452   FZRec.avail_in := 0;
 453   DCheck(inflateInit_(FZRec, zlib_version, sizeof(FZRec)));
 454 end;
 455
 456 destructor TDecompressionStream.Destroy;
 457 begin
 458   inflateEnd(FZRec);
 459   inherited Destroy;
 460 end;
 461
 462 function TDecompressionStream.Read(var Buffer; Count: Longint): Longint;
 463 begin
 464   FZRec.next_out := @Buffer;
 465   FZRec.avail_out := Count;
 466   if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;
 467   while (FZRec.avail_out > 0) do
 468   begin
 469     if FZRec.avail_in = 0 then
 470     begin
 471       FZRec.avail_in := FStrm.Read(FBuffer, sizeof(FBuffer));
 472       if FZRec.avail_in = 0 then
 473         begin
 474           Result := Count - Integer(FZRec.avail_out);
 475           Exit;
 476         end;
 477       FZRec.next_in := @FBuffer;
 478       FStrmPos := FStrm.Position;
 479       Progress(Self);
 480     end;
 481     CCheck(inflate(FZRec, 0));
 482   end;
 483   Result := Count;
 484 end;
 485
 486 function TDecompressionStream.Write(const Buffer; Count: Longint): Longint;
 487 begin
 488   raise EDecompressionError.Create('Invalid stream operation');
 489 end;
 490
 491 function TDecompressionStream.Seek(Offset: Longint; Origin: Word): Longint;
 492 var
 493   I: Integer;
 494   Buf: array [0..4095] of Byte;
 495 begin
 496   if (Offset = 0) and (Origin = soFromBeginning) then
 497   begin
 498     DCheck(inflateReset(FZRec));
 499     FZRec.next_in := @FBuffer;
 500     FZRec.avail_in := 0;
 501     FStrm.Position := 0;
 502     FStrmPos := 0;
 503   end
 504   else if ( (Offset >= 0) and (Origin = soFromCurrent)) or
 505           ( ((Offset - Integer(FZRec.total_out)) > 0) and (Origin = soFromBeginning)) then
 506   begin
 507     if Origin = soFromBeginning then Dec(Offset, FZRec.total_out);
 508     if Offset > 0 then
 509     begin
 510       for I := 1 to Offset div sizeof(Buf) do
 511         ReadBuffer(Buf, sizeof(Buf));
 512       ReadBuffer(Buf, Offset mod sizeof(Buf));
 513     end;
 514   end
 515   else
 516     raise EDecompressionError.Create('Invalid stream operation');
 517   Result := FZRec.total_out;
 518 end;
 519
 520 end.