Chris@4: {*******************************************************} Chris@4: { } Chris@4: { Borland Delphi Supplemental Components } Chris@4: { ZLIB Data Compression Interface Unit } Chris@4: { } Chris@4: { Copyright (c) 1997,99 Borland Corporation } Chris@4: { } Chris@4: {*******************************************************} Chris@4: Chris@4: { Updated for zlib 1.2.x by Cosmin Truta } Chris@4: Chris@4: unit ZLib; Chris@4: Chris@4: interface Chris@4: Chris@4: uses SysUtils, Classes; Chris@4: Chris@4: type Chris@4: TAlloc = function (AppData: Pointer; Items, Size: Integer): Pointer; cdecl; Chris@4: TFree = procedure (AppData, Block: Pointer); cdecl; Chris@4: Chris@4: // Internal structure. Ignore. Chris@4: TZStreamRec = packed record Chris@4: next_in: PChar; // next input byte Chris@4: avail_in: Integer; // number of bytes available at next_in Chris@4: total_in: Longint; // total nb of input bytes read so far Chris@4: Chris@4: next_out: PChar; // next output byte should be put here Chris@4: avail_out: Integer; // remaining free space at next_out Chris@4: total_out: Longint; // total nb of bytes output so far Chris@4: Chris@4: msg: PChar; // last error message, NULL if no error Chris@4: internal: Pointer; // not visible by applications Chris@4: Chris@4: zalloc: TAlloc; // used to allocate the internal state Chris@4: zfree: TFree; // used to free the internal state Chris@4: AppData: Pointer; // private data object passed to zalloc and zfree Chris@4: Chris@4: data_type: Integer; // best guess about the data type: ascii or binary Chris@4: adler: Longint; // adler32 value of the uncompressed data Chris@4: reserved: Longint; // reserved for future use Chris@4: end; Chris@4: Chris@4: // Abstract ancestor class Chris@4: TCustomZlibStream = class(TStream) Chris@4: private Chris@4: FStrm: TStream; Chris@4: FStrmPos: Integer; Chris@4: FOnProgress: TNotifyEvent; Chris@4: FZRec: TZStreamRec; Chris@4: FBuffer: array [Word] of Char; Chris@4: protected Chris@4: procedure Progress(Sender: TObject); dynamic; Chris@4: property OnProgress: TNotifyEvent read FOnProgress write FOnProgress; Chris@4: constructor Create(Strm: TStream); Chris@4: end; Chris@4: Chris@4: { TCompressionStream compresses data on the fly as data is written to it, and Chris@4: stores the compressed data to another stream. Chris@4: Chris@4: TCompressionStream is write-only and strictly sequential. Reading from the Chris@4: stream will raise an exception. Using Seek to move the stream pointer Chris@4: will raise an exception. Chris@4: Chris@4: Output data is cached internally, written to the output stream only when Chris@4: the internal output buffer is full. All pending output data is flushed Chris@4: when the stream is destroyed. Chris@4: Chris@4: The Position property returns the number of uncompressed bytes of Chris@4: data that have been written to the stream so far. Chris@4: Chris@4: CompressionRate returns the on-the-fly percentage by which the original Chris@4: data has been compressed: (1 - (CompressedBytes / UncompressedBytes)) * 100 Chris@4: If raw data size = 100 and compressed data size = 25, the CompressionRate Chris@4: is 75% Chris@4: Chris@4: The OnProgress event is called each time the output buffer is filled and Chris@4: written to the output stream. This is useful for updating a progress Chris@4: indicator when you are writing a large chunk of data to the compression Chris@4: stream in a single call.} Chris@4: Chris@4: Chris@4: TCompressionLevel = (clNone, clFastest, clDefault, clMax); Chris@4: Chris@4: TCompressionStream = class(TCustomZlibStream) Chris@4: private Chris@4: function GetCompressionRate: Single; Chris@4: public Chris@4: constructor Create(CompressionLevel: TCompressionLevel; Dest: TStream); Chris@4: destructor Destroy; override; Chris@4: function Read(var Buffer; Count: Longint): Longint; override; Chris@4: function Write(const Buffer; Count: Longint): Longint; override; Chris@4: function Seek(Offset: Longint; Origin: Word): Longint; override; Chris@4: property CompressionRate: Single read GetCompressionRate; Chris@4: property OnProgress; Chris@4: end; Chris@4: Chris@4: { TDecompressionStream decompresses data on the fly as data is read from it. Chris@4: Chris@4: Compressed data comes from a separate source stream. TDecompressionStream Chris@4: is read-only and unidirectional; you can seek forward in the stream, but not Chris@4: backwards. The special case of setting the stream position to zero is Chris@4: allowed. Seeking forward decompresses data until the requested position in Chris@4: the uncompressed data has been reached. Seeking backwards, seeking relative Chris@4: to the end of the stream, requesting the size of the stream, and writing to Chris@4: the stream will raise an exception. Chris@4: Chris@4: The Position property returns the number of bytes of uncompressed data that Chris@4: have been read from the stream so far. Chris@4: Chris@4: The OnProgress event is called each time the internal input buffer of Chris@4: compressed data is exhausted and the next block is read from the input stream. Chris@4: This is useful for updating a progress indicator when you are reading a Chris@4: large chunk of data from the decompression stream in a single call.} Chris@4: Chris@4: TDecompressionStream = class(TCustomZlibStream) Chris@4: public Chris@4: constructor Create(Source: TStream); Chris@4: destructor Destroy; override; Chris@4: function Read(var Buffer; Count: Longint): Longint; override; Chris@4: function Write(const Buffer; Count: Longint): Longint; override; Chris@4: function Seek(Offset: Longint; Origin: Word): Longint; override; Chris@4: property OnProgress; Chris@4: end; Chris@4: Chris@4: Chris@4: Chris@4: { CompressBuf compresses data, buffer to buffer, in one call. Chris@4: In: InBuf = ptr to compressed data Chris@4: InBytes = number of bytes in InBuf Chris@4: Out: OutBuf = ptr to newly allocated buffer containing decompressed data Chris@4: OutBytes = number of bytes in OutBuf } Chris@4: procedure CompressBuf(const InBuf: Pointer; InBytes: Integer; Chris@4: out OutBuf: Pointer; out OutBytes: Integer); Chris@4: Chris@4: Chris@4: { DecompressBuf decompresses data, buffer to buffer, in one call. Chris@4: In: InBuf = ptr to compressed data Chris@4: InBytes = number of bytes in InBuf Chris@4: OutEstimate = zero, or est. size of the decompressed data Chris@4: Out: OutBuf = ptr to newly allocated buffer containing decompressed data Chris@4: OutBytes = number of bytes in OutBuf } Chris@4: procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer; Chris@4: OutEstimate: Integer; out OutBuf: Pointer; out OutBytes: Integer); Chris@4: Chris@4: { DecompressToUserBuf decompresses data, buffer to buffer, in one call. Chris@4: In: InBuf = ptr to compressed data Chris@4: InBytes = number of bytes in InBuf Chris@4: Out: OutBuf = ptr to user-allocated buffer to contain decompressed data Chris@4: BufSize = number of bytes in OutBuf } Chris@4: procedure DecompressToUserBuf(const InBuf: Pointer; InBytes: Integer; Chris@4: const OutBuf: Pointer; BufSize: Integer); Chris@4: Chris@4: const Chris@4: zlib_version = '1.2.7'; Chris@4: Chris@4: type Chris@4: EZlibError = class(Exception); Chris@4: ECompressionError = class(EZlibError); Chris@4: EDecompressionError = class(EZlibError); Chris@4: Chris@4: implementation Chris@4: Chris@4: uses ZLibConst; Chris@4: Chris@4: const Chris@4: Z_NO_FLUSH = 0; Chris@4: Z_PARTIAL_FLUSH = 1; Chris@4: Z_SYNC_FLUSH = 2; Chris@4: Z_FULL_FLUSH = 3; Chris@4: Z_FINISH = 4; Chris@4: Chris@4: Z_OK = 0; Chris@4: Z_STREAM_END = 1; Chris@4: Z_NEED_DICT = 2; Chris@4: Z_ERRNO = (-1); Chris@4: Z_STREAM_ERROR = (-2); Chris@4: Z_DATA_ERROR = (-3); Chris@4: Z_MEM_ERROR = (-4); Chris@4: Z_BUF_ERROR = (-5); Chris@4: Z_VERSION_ERROR = (-6); Chris@4: Chris@4: Z_NO_COMPRESSION = 0; Chris@4: Z_BEST_SPEED = 1; Chris@4: Z_BEST_COMPRESSION = 9; Chris@4: Z_DEFAULT_COMPRESSION = (-1); Chris@4: Chris@4: Z_FILTERED = 1; Chris@4: Z_HUFFMAN_ONLY = 2; Chris@4: Z_RLE = 3; Chris@4: Z_DEFAULT_STRATEGY = 0; Chris@4: Chris@4: Z_BINARY = 0; Chris@4: Z_ASCII = 1; Chris@4: Z_UNKNOWN = 2; Chris@4: Chris@4: Z_DEFLATED = 8; Chris@4: Chris@4: Chris@4: {$L adler32.obj} Chris@4: {$L compress.obj} Chris@4: {$L crc32.obj} Chris@4: {$L deflate.obj} Chris@4: {$L infback.obj} Chris@4: {$L inffast.obj} Chris@4: {$L inflate.obj} Chris@4: {$L inftrees.obj} Chris@4: {$L trees.obj} Chris@4: {$L uncompr.obj} Chris@4: {$L zutil.obj} Chris@4: Chris@4: procedure adler32; external; Chris@4: procedure compressBound; external; Chris@4: procedure crc32; external; Chris@4: procedure deflateInit2_; external; Chris@4: procedure deflateParams; external; Chris@4: Chris@4: function _malloc(Size: Integer): Pointer; cdecl; Chris@4: begin Chris@4: Result := AllocMem(Size); Chris@4: end; Chris@4: Chris@4: procedure _free(Block: Pointer); cdecl; Chris@4: begin Chris@4: FreeMem(Block); Chris@4: end; Chris@4: Chris@4: procedure _memset(P: Pointer; B: Byte; count: Integer); cdecl; Chris@4: begin Chris@4: FillChar(P^, count, B); Chris@4: end; Chris@4: Chris@4: procedure _memcpy(dest, source: Pointer; count: Integer); cdecl; Chris@4: begin Chris@4: Move(source^, dest^, count); Chris@4: end; Chris@4: Chris@4: Chris@4: Chris@4: // deflate compresses data Chris@4: function deflateInit_(var strm: TZStreamRec; level: Integer; version: PChar; Chris@4: recsize: Integer): Integer; external; Chris@4: function deflate(var strm: TZStreamRec; flush: Integer): Integer; external; Chris@4: function deflateEnd(var strm: TZStreamRec): Integer; external; Chris@4: Chris@4: // inflate decompresses data Chris@4: function inflateInit_(var strm: TZStreamRec; version: PChar; Chris@4: recsize: Integer): Integer; external; Chris@4: function inflate(var strm: TZStreamRec; flush: Integer): Integer; external; Chris@4: function inflateEnd(var strm: TZStreamRec): Integer; external; Chris@4: function inflateReset(var strm: TZStreamRec): Integer; external; Chris@4: Chris@4: Chris@4: function zlibAllocMem(AppData: Pointer; Items, Size: Integer): Pointer; cdecl; Chris@4: begin Chris@4: // GetMem(Result, Items*Size); Chris@4: Result := AllocMem(Items * Size); Chris@4: end; Chris@4: Chris@4: procedure zlibFreeMem(AppData, Block: Pointer); cdecl; Chris@4: begin Chris@4: FreeMem(Block); Chris@4: end; Chris@4: Chris@4: {function zlibCheck(code: Integer): Integer; Chris@4: begin Chris@4: Result := code; Chris@4: if code < 0 then Chris@4: raise EZlibError.Create('error'); //!! Chris@4: end;} Chris@4: Chris@4: function CCheck(code: Integer): Integer; Chris@4: begin Chris@4: Result := code; Chris@4: if code < 0 then Chris@4: raise ECompressionError.Create('error'); //!! Chris@4: end; Chris@4: Chris@4: function DCheck(code: Integer): Integer; Chris@4: begin Chris@4: Result := code; Chris@4: if code < 0 then Chris@4: raise EDecompressionError.Create('error'); //!! Chris@4: end; Chris@4: Chris@4: procedure CompressBuf(const InBuf: Pointer; InBytes: Integer; Chris@4: out OutBuf: Pointer; out OutBytes: Integer); Chris@4: var Chris@4: strm: TZStreamRec; Chris@4: P: Pointer; Chris@4: begin Chris@4: FillChar(strm, sizeof(strm), 0); Chris@4: strm.zalloc := zlibAllocMem; Chris@4: strm.zfree := zlibFreeMem; Chris@4: OutBytes := ((InBytes + (InBytes div 10) + 12) + 255) and not 255; Chris@4: GetMem(OutBuf, OutBytes); Chris@4: try Chris@4: strm.next_in := InBuf; Chris@4: strm.avail_in := InBytes; Chris@4: strm.next_out := OutBuf; Chris@4: strm.avail_out := OutBytes; Chris@4: CCheck(deflateInit_(strm, Z_BEST_COMPRESSION, zlib_version, sizeof(strm))); Chris@4: try Chris@4: while CCheck(deflate(strm, Z_FINISH)) <> Z_STREAM_END do Chris@4: begin Chris@4: P := OutBuf; Chris@4: Inc(OutBytes, 256); Chris@4: ReallocMem(OutBuf, OutBytes); Chris@4: strm.next_out := PChar(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P))); Chris@4: strm.avail_out := 256; Chris@4: end; Chris@4: finally Chris@4: CCheck(deflateEnd(strm)); Chris@4: end; Chris@4: ReallocMem(OutBuf, strm.total_out); Chris@4: OutBytes := strm.total_out; Chris@4: except Chris@4: FreeMem(OutBuf); Chris@4: raise Chris@4: end; Chris@4: end; Chris@4: Chris@4: Chris@4: procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer; Chris@4: OutEstimate: Integer; out OutBuf: Pointer; out OutBytes: Integer); Chris@4: var Chris@4: strm: TZStreamRec; Chris@4: P: Pointer; Chris@4: BufInc: Integer; Chris@4: begin Chris@4: FillChar(strm, sizeof(strm), 0); Chris@4: strm.zalloc := zlibAllocMem; Chris@4: strm.zfree := zlibFreeMem; Chris@4: BufInc := (InBytes + 255) and not 255; Chris@4: if OutEstimate = 0 then Chris@4: OutBytes := BufInc Chris@4: else Chris@4: OutBytes := OutEstimate; Chris@4: GetMem(OutBuf, OutBytes); Chris@4: try Chris@4: strm.next_in := InBuf; Chris@4: strm.avail_in := InBytes; Chris@4: strm.next_out := OutBuf; Chris@4: strm.avail_out := OutBytes; Chris@4: DCheck(inflateInit_(strm, zlib_version, sizeof(strm))); Chris@4: try Chris@4: while DCheck(inflate(strm, Z_NO_FLUSH)) <> Z_STREAM_END do Chris@4: begin Chris@4: P := OutBuf; Chris@4: Inc(OutBytes, BufInc); Chris@4: ReallocMem(OutBuf, OutBytes); Chris@4: strm.next_out := PChar(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P))); Chris@4: strm.avail_out := BufInc; Chris@4: end; Chris@4: finally Chris@4: DCheck(inflateEnd(strm)); Chris@4: end; Chris@4: ReallocMem(OutBuf, strm.total_out); Chris@4: OutBytes := strm.total_out; Chris@4: except Chris@4: FreeMem(OutBuf); Chris@4: raise Chris@4: end; Chris@4: end; Chris@4: Chris@4: procedure DecompressToUserBuf(const InBuf: Pointer; InBytes: Integer; Chris@4: const OutBuf: Pointer; BufSize: Integer); Chris@4: var Chris@4: strm: TZStreamRec; Chris@4: begin Chris@4: FillChar(strm, sizeof(strm), 0); Chris@4: strm.zalloc := zlibAllocMem; Chris@4: strm.zfree := zlibFreeMem; Chris@4: strm.next_in := InBuf; Chris@4: strm.avail_in := InBytes; Chris@4: strm.next_out := OutBuf; Chris@4: strm.avail_out := BufSize; Chris@4: DCheck(inflateInit_(strm, zlib_version, sizeof(strm))); Chris@4: try Chris@4: if DCheck(inflate(strm, Z_FINISH)) <> Z_STREAM_END then Chris@4: raise EZlibError.CreateRes(@sTargetBufferTooSmall); Chris@4: finally Chris@4: DCheck(inflateEnd(strm)); Chris@4: end; Chris@4: end; Chris@4: Chris@4: // TCustomZlibStream Chris@4: Chris@4: constructor TCustomZLibStream.Create(Strm: TStream); Chris@4: begin Chris@4: inherited Create; Chris@4: FStrm := Strm; Chris@4: FStrmPos := Strm.Position; Chris@4: FZRec.zalloc := zlibAllocMem; Chris@4: FZRec.zfree := zlibFreeMem; Chris@4: end; Chris@4: Chris@4: procedure TCustomZLibStream.Progress(Sender: TObject); Chris@4: begin Chris@4: if Assigned(FOnProgress) then FOnProgress(Sender); Chris@4: end; Chris@4: Chris@4: Chris@4: // TCompressionStream Chris@4: Chris@4: constructor TCompressionStream.Create(CompressionLevel: TCompressionLevel; Chris@4: Dest: TStream); Chris@4: const Chris@4: Levels: array [TCompressionLevel] of ShortInt = Chris@4: (Z_NO_COMPRESSION, Z_BEST_SPEED, Z_DEFAULT_COMPRESSION, Z_BEST_COMPRESSION); Chris@4: begin Chris@4: inherited Create(Dest); Chris@4: FZRec.next_out := FBuffer; Chris@4: FZRec.avail_out := sizeof(FBuffer); Chris@4: CCheck(deflateInit_(FZRec, Levels[CompressionLevel], zlib_version, sizeof(FZRec))); Chris@4: end; Chris@4: Chris@4: destructor TCompressionStream.Destroy; Chris@4: begin Chris@4: FZRec.next_in := nil; Chris@4: FZRec.avail_in := 0; Chris@4: try Chris@4: if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos; Chris@4: while (CCheck(deflate(FZRec, Z_FINISH)) <> Z_STREAM_END) Chris@4: and (FZRec.avail_out = 0) do Chris@4: begin Chris@4: FStrm.WriteBuffer(FBuffer, sizeof(FBuffer)); Chris@4: FZRec.next_out := FBuffer; Chris@4: FZRec.avail_out := sizeof(FBuffer); Chris@4: end; Chris@4: if FZRec.avail_out < sizeof(FBuffer) then Chris@4: FStrm.WriteBuffer(FBuffer, sizeof(FBuffer) - FZRec.avail_out); Chris@4: finally Chris@4: deflateEnd(FZRec); Chris@4: end; Chris@4: inherited Destroy; Chris@4: end; Chris@4: Chris@4: function TCompressionStream.Read(var Buffer; Count: Longint): Longint; Chris@4: begin Chris@4: raise ECompressionError.CreateRes(@sInvalidStreamOp); Chris@4: end; Chris@4: Chris@4: function TCompressionStream.Write(const Buffer; Count: Longint): Longint; Chris@4: begin Chris@4: FZRec.next_in := @Buffer; Chris@4: FZRec.avail_in := Count; Chris@4: if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos; Chris@4: while (FZRec.avail_in > 0) do Chris@4: begin Chris@4: CCheck(deflate(FZRec, 0)); Chris@4: if FZRec.avail_out = 0 then Chris@4: begin Chris@4: FStrm.WriteBuffer(FBuffer, sizeof(FBuffer)); Chris@4: FZRec.next_out := FBuffer; Chris@4: FZRec.avail_out := sizeof(FBuffer); Chris@4: FStrmPos := FStrm.Position; Chris@4: Progress(Self); Chris@4: end; Chris@4: end; Chris@4: Result := Count; Chris@4: end; Chris@4: Chris@4: function TCompressionStream.Seek(Offset: Longint; Origin: Word): Longint; Chris@4: begin Chris@4: if (Offset = 0) and (Origin = soFromCurrent) then Chris@4: Result := FZRec.total_in Chris@4: else Chris@4: raise ECompressionError.CreateRes(@sInvalidStreamOp); Chris@4: end; Chris@4: Chris@4: function TCompressionStream.GetCompressionRate: Single; Chris@4: begin Chris@4: if FZRec.total_in = 0 then Chris@4: Result := 0 Chris@4: else Chris@4: Result := (1.0 - (FZRec.total_out / FZRec.total_in)) * 100.0; Chris@4: end; Chris@4: Chris@4: Chris@4: // TDecompressionStream Chris@4: Chris@4: constructor TDecompressionStream.Create(Source: TStream); Chris@4: begin Chris@4: inherited Create(Source); Chris@4: FZRec.next_in := FBuffer; Chris@4: FZRec.avail_in := 0; Chris@4: DCheck(inflateInit_(FZRec, zlib_version, sizeof(FZRec))); Chris@4: end; Chris@4: Chris@4: destructor TDecompressionStream.Destroy; Chris@4: begin Chris@4: FStrm.Seek(-FZRec.avail_in, 1); Chris@4: inflateEnd(FZRec); Chris@4: inherited Destroy; Chris@4: end; Chris@4: Chris@4: function TDecompressionStream.Read(var Buffer; Count: Longint): Longint; Chris@4: begin Chris@4: FZRec.next_out := @Buffer; Chris@4: FZRec.avail_out := Count; Chris@4: if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos; Chris@4: while (FZRec.avail_out > 0) do Chris@4: begin Chris@4: if FZRec.avail_in = 0 then Chris@4: begin Chris@4: FZRec.avail_in := FStrm.Read(FBuffer, sizeof(FBuffer)); Chris@4: if FZRec.avail_in = 0 then Chris@4: begin Chris@4: Result := Count - FZRec.avail_out; Chris@4: Exit; Chris@4: end; Chris@4: FZRec.next_in := FBuffer; Chris@4: FStrmPos := FStrm.Position; Chris@4: Progress(Self); Chris@4: end; Chris@4: CCheck(inflate(FZRec, 0)); Chris@4: end; Chris@4: Result := Count; Chris@4: end; Chris@4: Chris@4: function TDecompressionStream.Write(const Buffer; Count: Longint): Longint; Chris@4: begin Chris@4: raise EDecompressionError.CreateRes(@sInvalidStreamOp); Chris@4: end; Chris@4: Chris@4: function TDecompressionStream.Seek(Offset: Longint; Origin: Word): Longint; Chris@4: var Chris@4: I: Integer; Chris@4: Buf: array [0..4095] of Char; Chris@4: begin Chris@4: if (Offset = 0) and (Origin = soFromBeginning) then Chris@4: begin Chris@4: DCheck(inflateReset(FZRec)); Chris@4: FZRec.next_in := FBuffer; Chris@4: FZRec.avail_in := 0; Chris@4: FStrm.Position := 0; Chris@4: FStrmPos := 0; Chris@4: end Chris@4: else if ( (Offset >= 0) and (Origin = soFromCurrent)) or Chris@4: ( ((Offset - FZRec.total_out) > 0) and (Origin = soFromBeginning)) then Chris@4: begin Chris@4: if Origin = soFromBeginning then Dec(Offset, FZRec.total_out); Chris@4: if Offset > 0 then Chris@4: begin Chris@4: for I := 1 to Offset div sizeof(Buf) do Chris@4: ReadBuffer(Buf, sizeof(Buf)); Chris@4: ReadBuffer(Buf, Offset mod sizeof(Buf)); Chris@4: end; Chris@4: end Chris@4: else Chris@4: raise EDecompressionError.CreateRes(@sInvalidStreamOp); Chris@4: Result := FZRec.total_out; Chris@4: end; Chris@4: Chris@4: Chris@4: end.