{*******************************************************}

{ }

{ Borland Delphi Supplemental Components }

{ ZLIB Data Compression Interface Unit }

{ }

{ Copyright (c) 1997,99 Borland Corporation }

{ }

{*******************************************************}

{ Updated for zlib 1.2.x by Cosmin Truta <cosmint@cs.ubbcluj.ro> }

unit ZLib;

interface

uses SysUtils, Classes;

type

TAlloc = function (AppData: Pointer; Items, Size: Integer): Pointer; cdecl;

TFree = procedure (AppData, Block: Pointer); cdecl;

// Internal structure. Ignore.

TZStreamRec = packed record

next_in: PChar; // next input byte

avail_in: Integer; // number of bytes available at next_in

total_in: Longint; // total nb of input bytes read so far

next_out: PChar; // next output byte should be put here

avail_out: Integer; // remaining free space at next_out

total_out: Longint; // total nb of bytes output so far

msg: PChar; // last error message, NULL if no error

internal: Pointer; // not visible by applications

zalloc: TAlloc; // used to allocate the internal state

zfree: TFree; // used to free the internal state

AppData: Pointer; // private data object passed to zalloc and zfree

data_type: Integer; // best guess about the data type: ascii or binary

adler: Longint; // adler32 value of the uncompressed data

reserved: Longint; // reserved for future use

end;

// Abstract ancestor class

TCustomZlibStream = class(TStream)

private

FStrm: TStream;

FStrmPos: Integer;

FOnProgress: TNotifyEvent;

FZRec: TZStreamRec;

FBuffer: array [Word] of Char;

protected

procedure Progress(Sender: TObject); dynamic;

property OnProgress: TNotifyEvent read FOnProgress write FOnProgress;

constructor Create(Strm: TStream);

end;

{ TCompressionStream compresses data on the fly as data is written to it, and

stores the compressed data to another stream.

TCompressionStream is write-only and strictly sequential. Reading from the

stream will raise an exception. Using Seek to move the stream pointer

will raise an exception.

Output data is cached internally, written to the output stream only when

the internal output buffer is full. All pending output data is flushed

when the stream is destroyed.

The Position property returns the number of uncompressed bytes of

data that have been written to the stream so far.

CompressionRate returns the on-the-fly percentage by which the original

data has been compressed: (1 - (CompressedBytes / UncompressedBytes)) * 100

If raw data size = 100 and compressed data size = 25, the CompressionRate

is 75%

The OnProgress event is called each time the output buffer is filled and

written to the output stream. This is useful for updating a progress

indicator when you are writing a large chunk of data to the compression

stream in a single call.}

TCompressionLevel = (clNone, clFastest, clDefault, clMax);

TCompressionStream = class(TCustomZlibStream)

private

function GetCompressionRate: Single;

public

constructor Create(CompressionLevel: TCompressionLevel; Dest: TStream);

destructor Destroy; override;

function Read(var Buffer; Count: Longint): Longint; override;

function Write(const Buffer; Count: Longint): Longint; override;

function Seek(Offset: Longint; Origin: Word): Longint; override;

property CompressionRate: Single read GetCompressionRate;

property OnProgress;

end;

{ TDecompressionStream decompresses data on the fly as data is read from it.

Compressed data comes from a separate source stream. TDecompressionStream

is read-only and unidirectional; you can seek forward in the stream, but not

backwards. The special case of setting the stream position to zero is

allowed. Seeking forward decompresses data until the requested position in

the uncompressed data has been reached. Seeking backwards, seeking relative

to the end of the stream, requesting the size of the stream, and writing to

the stream will raise an exception.

The Position property returns the number of bytes of uncompressed data that

have been read from the stream so far.

The OnProgress event is called each time the internal input buffer of

compressed data is exhausted and the next block is read from the input stream.

This is useful for updating a progress indicator when you are reading a

large chunk of data from the decompression stream in a single call.}

TDecompressionStream = class(TCustomZlibStream)

public

constructor Create(Source: TStream);

destructor Destroy; override;

function Read(var Buffer; Count: Longint): Longint; override;

function Write(const Buffer; Count: Longint): Longint; override;

function Seek(Offset: Longint; Origin: Word): Longint; override;

property OnProgress;

end;

{ CompressBuf compresses data, buffer to buffer, in one call.

In: InBuf = ptr to compressed data

InBytes = number of bytes in InBuf

Out: OutBuf = ptr to newly allocated buffer containing decompressed data

OutBytes = number of bytes in OutBuf }

procedure CompressBuf(const InBuf: Pointer; InBytes: Integer;

out OutBuf: Pointer; out OutBytes: Integer);

{ DecompressBuf decompresses data, buffer to buffer, in one call.

In: InBuf = ptr to compressed data

InBytes = number of bytes in InBuf

OutEstimate = zero, or est. size of the decompressed data

Out: OutBuf = ptr to newly allocated buffer containing decompressed data

OutBytes = number of bytes in OutBuf }

procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer;

OutEstimate: Integer; out OutBuf: Pointer; out OutBytes: Integer);

{ DecompressToUserBuf decompresses data, buffer to buffer, in one call.

In: InBuf = ptr to compressed data

InBytes = number of bytes in InBuf

Out: OutBuf = ptr to user-allocated buffer to contain decompressed data

BufSize = number of bytes in OutBuf }

procedure DecompressToUserBuf(const InBuf: Pointer; InBytes: Integer;

const OutBuf: Pointer; BufSize: Integer);

const

zlib_version = '1.2.8';

type

EZlibError = class(Exception);

ECompressionError = class(EZlibError);

EDecompressionError = class(EZlibError);

implementation

uses ZLibConst;

const

Z_NO_FLUSH = 0;

Z_PARTIAL_FLUSH = 1;

Z_SYNC_FLUSH = 2;

Z_FULL_FLUSH = 3;

Z_FINISH = 4;

Z_OK = 0;

Z_STREAM_END = 1;

Z_NEED_DICT = 2;

Z_ERRNO = (-1);

Z_STREAM_ERROR = (-2);

Z_DATA_ERROR = (-3);

Z_MEM_ERROR = (-4);

Z_BUF_ERROR = (-5);

Z_VERSION_ERROR = (-6);

Z_NO_COMPRESSION = 0;

Z_BEST_SPEED = 1;

Z_BEST_COMPRESSION = 9;

Z_DEFAULT_COMPRESSION = (-1);

Z_FILTERED = 1;

Z_HUFFMAN_ONLY = 2;

Z_RLE = 3;

Z_DEFAULT_STRATEGY = 0;

Z_BINARY = 0;

Z_ASCII = 1;

Z_UNKNOWN = 2;

Z_DEFLATED = 8;

{$L adler32.obj}

{$L compress.obj}

{$L crc32.obj}

{$L deflate.obj}

{$L infback.obj}

{$L inffast.obj}

{$L inflate.obj}

{$L inftrees.obj}

{$L trees.obj}

{$L uncompr.obj}

{$L zutil.obj}

procedure adler32; external;

procedure compressBound; external;

procedure crc32; external;

procedure deflateInit2_; external;

procedure deflateParams; external;

function _malloc(Size: Integer): Pointer; cdecl;

begin

Result := AllocMem(Size);

end;

procedure _free(Block: Pointer); cdecl;

begin

FreeMem(Block);

end;

procedure _memset(P: Pointer; B: Byte; count: Integer); cdecl;

begin

FillChar(P^, count, B);

end;

procedure _memcpy(dest, source: Pointer; count: Integer); cdecl;

begin

Move(source^, dest^, count);

end;

// deflate compresses data

function deflateInit_(var strm: TZStreamRec; level: Integer; version: PChar;

recsize: Integer): Integer; external;

function deflate(var strm: TZStreamRec; flush: Integer): Integer; external;

function deflateEnd(var strm: TZStreamRec): Integer; external;

// inflate decompresses data

function inflateInit_(var strm: TZStreamRec; version: PChar;

recsize: Integer): Integer; external;

function inflate(var strm: TZStreamRec; flush: Integer): Integer; external;

function inflateEnd(var strm: TZStreamRec): Integer; external;

function inflateReset(var strm: TZStreamRec): Integer; external;

function zlibAllocMem(AppData: Pointer; Items, Size: Integer): Pointer; cdecl;

begin

// GetMem(Result, Items*Size);

Result := AllocMem(Items * Size);

end;

procedure zlibFreeMem(AppData, Block: Pointer); cdecl;

begin

FreeMem(Block);

end;

{function zlibCheck(code: Integer): Integer;

begin

Result := code;

if code < 0 then

raise EZlibError.Create('error'); //!!

end;}

function CCheck(code: Integer): Integer;

begin

Result := code;

if code < 0 then

raise ECompressionError.Create('error'); //!!

end;

function DCheck(code: Integer): Integer;

begin

Result := code;

if code < 0 then

raise EDecompressionError.Create('error'); //!!

end;

procedure CompressBuf(const InBuf: Pointer; InBytes: Integer;

out OutBuf: Pointer; out OutBytes: Integer);

var

strm: TZStreamRec;

P: Pointer;

begin

FillChar(strm, sizeof(strm), 0);

strm.zalloc := zlibAllocMem;

strm.zfree := zlibFreeMem;

OutBytes := ((InBytes + (InBytes div 10) + 12) + 255) and not 255;

GetMem(OutBuf, OutBytes);

try

strm.next_in := InBuf;

strm.avail_in := InBytes;

strm.next_out := OutBuf;

strm.avail_out := OutBytes;

CCheck(deflateInit_(strm, Z_BEST_COMPRESSION, zlib_version, sizeof(strm)));

try

while CCheck(deflate(strm, Z_FINISH)) <> Z_STREAM_END do

begin

P := OutBuf;

Inc(OutBytes, 256);

ReallocMem(OutBuf, OutBytes);

strm.next_out := PChar(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P)));

strm.avail_out := 256;

end;

finally

CCheck(deflateEnd(strm));

end;

ReallocMem(OutBuf, strm.total_out);

OutBytes := strm.total_out;

except

FreeMem(OutBuf);

raise

end;

end;

procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer;

OutEstimate: Integer; out OutBuf: Pointer; out OutBytes: Integer);

var

strm: TZStreamRec;

P: Pointer;

BufInc: Integer;

begin

FillChar(strm, sizeof(strm), 0);

strm.zalloc := zlibAllocMem;

strm.zfree := zlibFreeMem;

BufInc := (InBytes + 255) and not 255;

if OutEstimate = 0 then

OutBytes := BufInc

else

OutBytes := OutEstimate;

GetMem(OutBuf, OutBytes);

try

strm.next_in := InBuf;

strm.avail_in := InBytes;

strm.next_out := OutBuf;

strm.avail_out := OutBytes;

DCheck(inflateInit_(strm, zlib_version, sizeof(strm)));

try

while DCheck(inflate(strm, Z_NO_FLUSH)) <> Z_STREAM_END do

begin

P := OutBuf;

Inc(OutBytes, BufInc);

ReallocMem(OutBuf, OutBytes);

strm.next_out := PChar(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P)));

strm.avail_out := BufInc;

end;

finally

DCheck(inflateEnd(strm));

end;

ReallocMem(OutBuf, strm.total_out);

OutBytes := strm.total_out;

except

FreeMem(OutBuf);

raise

end;

end;

procedure DecompressToUserBuf(const InBuf: Pointer; InBytes: Integer;

const OutBuf: Pointer; BufSize: Integer);

var

strm: TZStreamRec;

begin

FillChar(strm, sizeof(strm), 0);

strm.zalloc := zlibAllocMem;

strm.zfree := zlibFreeMem;

strm.next_in := InBuf;

strm.avail_in := InBytes;

strm.next_out := OutBuf;

strm.avail_out := BufSize;

DCheck(inflateInit_(strm, zlib_version, sizeof(strm)));

try

if DCheck(inflate(strm, Z_FINISH)) <> Z_STREAM_END then

raise EZlibError.CreateRes(@sTargetBufferTooSmall);

finally

DCheck(inflateEnd(strm));

end;

end;

// TCustomZlibStream

constructor TCustomZLibStream.Create(Strm: TStream);

begin

inherited Create;

FStrm := Strm;

FStrmPos := Strm.Position;

FZRec.zalloc := zlibAllocMem;

FZRec.zfree := zlibFreeMem;

end;

procedure TCustomZLibStream.Progress(Sender: TObject);

begin

if Assigned(FOnProgress) then FOnProgress(Sender);

end;

// TCompressionStream

constructor TCompressionStream.Create(CompressionLevel: TCompressionLevel;

Dest: TStream);

const

Levels: array [TCompressionLevel] of ShortInt =

(Z_NO_COMPRESSION, Z_BEST_SPEED, Z_DEFAULT_COMPRESSION, Z_BEST_COMPRESSION);

begin

inherited Create(Dest);

FZRec.next_out := FBuffer;

FZRec.avail_out := sizeof(FBuffer);

CCheck(deflateInit_(FZRec, Levels[CompressionLevel], zlib_version, sizeof(FZRec)));

end;

destructor TCompressionStream.Destroy;

begin

FZRec.next_in := nil;

FZRec.avail_in := 0;

try

if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;

while (CCheck(deflate(FZRec, Z_FINISH)) <> Z_STREAM_END)

and (FZRec.avail_out = 0) do

begin

FStrm.WriteBuffer(FBuffer, sizeof(FBuffer));

FZRec.next_out := FBuffer;

FZRec.avail_out := sizeof(FBuffer);

end;

if FZRec.avail_out < sizeof(FBuffer) then

FStrm.WriteBuffer(FBuffer, sizeof(FBuffer) - FZRec.avail_out);

finally

deflateEnd(FZRec);

end;

inherited Destroy;

end;

function TCompressionStream.Read(var Buffer; Count: Longint): Longint;

begin

raise ECompressionError.CreateRes(@sInvalidStreamOp);

end;

function TCompressionStream.Write(const Buffer; Count: Longint): Longint;

begin

FZRec.next_in := @Buffer;

FZRec.avail_in := Count;

if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;

while (FZRec.avail_in > 0) do

begin

CCheck(deflate(FZRec, 0));

if FZRec.avail_out = 0 then

begin

FStrm.WriteBuffer(FBuffer, sizeof(FBuffer));

FZRec.next_out := FBuffer;

FZRec.avail_out := sizeof(FBuffer);

FStrmPos := FStrm.Position;

Progress(Self);

end;

end;

Result := Count;

end;

function TCompressionStream.Seek(Offset: Longint; Origin: Word): Longint;

begin

if (Offset = 0) and (Origin = soFromCurrent) then

Result := FZRec.total_in

else

raise ECompressionError.CreateRes(@sInvalidStreamOp);

end;

function TCompressionStream.GetCompressionRate: Single;

begin

if FZRec.total_in = 0 then

Result := 0

else

Result := (1.0 - (FZRec.total_out / FZRec.total_in)) * 100.0;

end;

// TDecompressionStream

constructor TDecompressionStream.Create(Source: TStream);

begin

inherited Create(Source);

FZRec.next_in := FBuffer;

FZRec.avail_in := 0;

DCheck(inflateInit_(FZRec, zlib_version, sizeof(FZRec)));

end;

destructor TDecompressionStream.Destroy;

begin

FStrm.Seek(-FZRec.avail_in, 1);

inflateEnd(FZRec);

inherited Destroy;

end;

function TDecompressionStream.Read(var Buffer; Count: Longint): Longint;

begin

FZRec.next_out := @Buffer;

FZRec.avail_out := Count;

if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;

while (FZRec.avail_out > 0) do

begin

if FZRec.avail_in = 0 then

begin

FZRec.avail_in := FStrm.Read(FBuffer, sizeof(FBuffer));

if FZRec.avail_in = 0 then

begin

Result := Count - FZRec.avail_out;

Exit;

end;

FZRec.next_in := FBuffer;

FStrmPos := FStrm.Position;

Progress(Self);

end;

CCheck(inflate(FZRec, 0));

end;

Result := Count;

end;

function TDecompressionStream.Write(const Buffer; Count: Longint): Longint;

begin

raise EDecompressionError.CreateRes(@sInvalidStreamOp);

end;

function TDecompressionStream.Seek(Offset: Longint; Origin: Word): Longint;

var

I: Integer;

Buf: array [0..4095] of Char;

begin

if (Offset = 0) and (Origin = soFromBeginning) then

begin

DCheck(inflateReset(FZRec));

FZRec.next_in := FBuffer;

FZRec.avail_in := 0;

FStrm.Position := 0;

FStrmPos := 0;

end

else if ( (Offset >= 0) and (Origin = soFromCurrent)) or

( ((Offset - FZRec.total_out) > 0) and (Origin = soFromBeginning)) then

begin

if Origin = soFromBeginning then Dec(Offset, FZRec.total_out);

if Offset > 0 then

begin

for I := 1 to Offset div sizeof(Buf) do

ReadBuffer(Buf, sizeof(Buf));

ReadBuffer(Buf, Offset mod sizeof(Buf));

end;

end

else

raise EDecompressionError.CreateRes(@sInvalidStreamOp);

Result := FZRec.total_out;

end;

end.