"Fossies" - the Fresh Open Source Software Archive

Member "muscle/zlib/zlib/contrib/delphi/ZLib.pas" (21 Nov 2020, 16413 Bytes) of package /linux/privat/muscle7.62.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) delphi source code syntax highlighting (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "ZLib.pas": 7.61_vs_7.62.

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