contrib/delphi/ZLib.pas

{*******************************************************}
{                                                       }
{       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.
Revision:	1096
Committed:	Sat Dec 30 14:40:33 2017 UTC (7 years, 9 months ago) by s10k
Content type:	text/x-pascal
File size:	16412 byte(s)
Log Message:	Added zlib, quazip, basicxmlsyntaxhighlighter, conditionalsemaphore and linenumberdisplay libraries. zlib and quazip are pre-compiled, but you can compile them yourself, just delete the dll files (or equivalent binary files to your OS)
#	Content
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.8';
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.