{ -----------------------------------------------------------------------
Tcl Scripting Language Components (Tslc)
Copyright (C) 1996-2002 William Byrne

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

WilliamB@ByrneLitho.com
------------------------------------------------------------------------}
unit TslcZLib;

interface
uses Windows, SysUtils, Classes;


type
	ETslcZLib = class(Exception);
	gzFile = integer;


// ZLib stuff...
//
// This unit contains some basic ZLib implementation. See below for readme
// text supplied with ZLib distribution.
//
// Zlib created by Jean-loup Gailly and Mark Adler
//


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_DEFAULT_STRATEGY 	= 0;

	Z_BINARY   = 0;
	Z_ASCII    = 1;
	Z_UNKNOWN  = 2;

	Z_DEFLATED	= 8;

	Z_NULL	= 0;

	ZLIB_VERSION = '1.0.4';

{$IFNDEF WIN32}
?pragma error? 'integer sizes need to be addressed'
{$ENDIF}

type
    TslcZLib_alloc_func = function(opaque: pointer; items, size: Cardinal): pointer; cdecl;
    TslcZLib_free_func = procedure(opaque: pointer; address: pointer); cdecl;
    z_streamp = ^z_stream;
	z_stream = record
    	next_in: pChar;
        avail_in: Cardinal;
        total_in: Cardinal;
        next_out: pChar;
        avail_out: Cardinal;
        total_out: Cardinal;
        msg: pChar;
        internal_state: pointer;
        zalloc: TslcZLib_alloc_func;
        zfree: TslcZLib_free_func;
        opaque: pointer;
		data_type: integer;
        adler: Cardinal;
        reserved: Cardinal;
    end;

	TslcZLib_deflateInit_ = function(strm: z_streamp; level: integer; version: pChar; stream_size: integer): integer; cdecl;
	TslcZLib_deflate = function(strm: z_streamp; flush: integer): integer; cdecl;
	TslcZLib_deflateEnd = function(strm: z_streamp): integer; cdecl;
	TslcZLib_inflateInit_ = function(strm: z_streamp; version: pChar; stream_size: integer): integer; cdecl;
	TslcZLib_inflate = function(strm: z_streamp; flush: integer): integer; cdecl;
    TslcZLib_inflateEnd = function(strm: z_streamp): integer; cdecl;

	pInteger = ^Integer;
	TslcZLib_compress = function(dest: pChar; var destLen: integer; const source: pChar; sourceLen: integer): integer; cdecl;
	TslcZLib_uncompress = function(dest: pChar; var destLen: integer; const source: pChar; sourceLen: integer): integer; cdecl;

// gz_open wrapped by gzopen & gzdopen which...
// Opens a gzip (.gz) file for reading or writing. The mode parameter
// is as in fopen ("rb" or "wb"). The file is given either by file descriptor
// or path name (if fd == -1).
//  gz_open return NULL if the file could not be opened or if there was
// insufficient memory to allocate the (de)compression state; errno
// can be checked to distinguish the two cases (if errno is zero, the
// zlib error is Z_MEM_ERROR).


//  Opens a gzip (.gz) file for reading or writing.
	TslcZLib_gzopen = function(path, mode: pChar): gzFile; cdecl;

// Associate a gzFile with the file descriptor fd. fd is not dup'ed here
// to mimic the behavio(u)r of fdopen.
	TslcZLib_gzdopen = function(fd: integer; mode: pChar): gzFile; cdecl;

// Reads the given number of uncompressed bytes from the compressed file.
// gzread returns the number of bytes actually read (0 for end of file).
	TslcZLib_gzread = function(hFile: gzFile; buf: pointer; len: integer): integer; cdecl;

// Writes the given number of uncompressed bytes into the compressed file.
// gzwrite returns the number of bytes actually written (0 in case of error).
	TslcZLib_gzwrite = function(hFile: gzFile; buf: pointer; len: integer): integer; cdecl;

// Flushes all pending output into the compressed file. The parameter
// flush is as in the deflate() function.
// gzflush should be called only when strictly necessary because it can
// degrade compression.
	TslcZLib_gzflush = function(hFile: gzFile; flush: integer): integer; cdecl;

	TslcZLib_gzclose = function(hFile: gzFile): integer; cdecl;

// Returns the error message for the last error which occured on the
// given compressed file. errnum is set to zlib error number. If an
// error occured in the file system and not in the compression library,
// errnum is set to Z_ERRNO and the application may consult errno
// to get the exact error code.
	TslcZLib_gzerror = function(hFile: gzFile; errnum: pInteger): pChar; cdecl;

const
	ZLibModule: HModule = 0;
	deflateInit_:	TslcZLib_deflateInit_ = nil;
    deflate:		TslcZLib_deflate = nil;
    deflateEnd:		TslcZLib_deflateEnd = nil;
    inflateInit_:	TslcZLib_inflateInit_ = nil;
    inflate:		TslcZLib_inflate = nil;
    inflateEnd:		TslcZLib_inflateEnd = nil;
	compress:		TslcZLib_compress = nil;
    uncompress:		TslcZLib_uncompress = nil;
    gzopen:			TslcZLib_gzopen = nil;
    gzdopen:		TslcZLib_gzdopen = nil;
    gzread:			TslcZlib_gzread = nil;
    gzwrite:		TslcZLib_gzwrite = nil;
    gzflush:		TslcZLib_gzflush = nil;
    gzclose:		TslcZLib_gzclose = nil;


procedure TslcZLibError(msg: string);
procedure TslcZLibErrorFmt(msg: string; const args: array of const);

// The following procedures throw ETslcZLib
procedure InitZLib( ALibPath: string);
procedure DeflateStream(sourceStrm, destStrm: TStream; level: integer);
procedure InflateStream(sourceStrm, destStrm: TStream);

// gz style... stream procedures currently use a temp file.
procedure CompressStream(sourceStrm, destStrm: TStream); // uses a tmp file
procedure CompressFile(sourcePath, destPath: string; overwrite: boolean);
procedure DecompressStream(sourceStrm, destStrm: TStream); // uses a tmp file
procedure DecompressFile(sourcePath, destPath: string; overwrite: boolean);
function TempFile: string;

const
	cZLibPath = 'TslcZLib.dll';
    cCompExt  = '.TCZ';

implementation
uses TslcPlat;

procedure TslcZLibError(msg: string);
begin
	raise ETslcZLib.Create(msg);
end;

procedure TslcZLibErrorFmt(msg: string; const args: array of const);
begin
	TslcZLibError(format(msg, args));
end;

procedure CheckZLib;
begin
	if ZLibModule = 0 then
    	TslcZLibError('ZLib library not loaded');
end;

var
    ZLibPath: string = cZLibPath;

procedure InitZLib( ALibPath: string);
	function Get( module: integer; name: string ): FARPROC;
	begin
		result := GetProcAddress( module, pChar( name ) );
	    if result = nil then
	    	result := GetProcAddress( module, pChar( '_' + name ) );
	end;
	function GetCheck(name: string ):FARPROC;
	begin
		result := Get(ZLibModule, name );
	    if result = nil then
    		raise Exception.CreateFmt('Unable to load ZLib procedures from %s %s',[ZLibPath, name]);
	end;
begin
	if ZlibModule <> 0 then exit;
	if ALibPath <> '' then ZLibPath := ALibPath;
    ZLibModule := GetModuleHandle(pChar(ZLibPath));
    if ZLibModule = 0 then
    	ZLibModule := LoadLibrary(pChar(ZLibPath));

    if ZLibModule = 0 then
	   	TslcZLibErrorFmt('Unable to load ZLib Library %s (%d)',[ZLibPath, GetLastError] );

	try
		deflateInit_:= GetCheck('deflateInit_');
        deflate		:= GetCheck('deflate');
        deflateEnd	:= GetCheck('deflateEnd');
        inflateInit_:= GetCheck('inflateInit_');
        inflate		:= GetCheck('inflate');
        inflateEnd	:= GetCheck('inflateEnd');
		compress	:= GetCheck('compress');
	    uncompress	:= GetCheck('uncompress');
		gzopen		:= GetCheck('gzopen');
	    gzdopen		:= GetCheck('gzdopen');
	    gzread		:= GetCheck('gzread');
	    gzwrite		:= GetCheck('gzwrite');
	    gzflush		:= GetCheck('gzflush');
	    gzclose		:= GetCheck('gzclose');
    except
    	FreeLibrary(ZLibModule);
        ZLibModule := 0;
        raise;
    end;
end;

procedure DeflateStream(sourceStrm, destStrm: TStream; level: integer);
const
	cBufSize = $2000;
var
	zstrm: z_stream;
    cbIn, err: integer;
    s, d: pChar;
begin

    zstrm.zalloc := nil;
    zstrm.zfree := nil;
    zstrm.opaque := nil;

    if deflateInit_(@zstrm, level, ZLIB_VERSION, sizeof(zstrm)) <> Z_OK then
    	TslcZLibError('Unable to initialize deflation');

	GetMem(s, cBufSize);
    try
    	GetMem(d, cBufSize);
    except
    	FreeMem(s);
        raise;
    end;

    try
		zstrm.next_in := s;
	    zstrm.next_out := d;
    	zstrm.avail_out := cBufSize;

        repeat
        	cbIn := sourceStrm.Read(s^, cBufSize);
            zstrm.avail_in := cbIn;
            zstrm.next_in := s;
			while zstrm.avail_in > 0 do
            begin
                err := deflate(@zstrm, Z_NO_FLUSH);
                if err <> Z_OK then
                	TslcZLibErrorFmt('An error occurred while deflating - %d', [err]);
                destStrm.Write(d^, cBufSize - zstrm.avail_out);
                zstrm.next_out := d;
                zstrm.avail_out := cBufSize;
            end;
        until cbIn < cBufSize;

		repeat
        	err := deflate(@zstrm, Z_FINISH);
            if err in [Z_OK, Z_STREAM_END] then
            begin
	            destStrm.Write(d^, cBufSize - zstrm.avail_out);
                zstrm.next_out := d;
                zstrm.avail_out := cBufSize;
            end;
        until err <> Z_OK;

        if err <> Z_STREAM_END then
        	TslcZLibErrorFmt('Unable to flush deflate: %d', [err]);
	finally
       	deflateEnd(@zstrm);
       	FreeMem(s);
        FreeMem(d);
    end;
end;

procedure InflateStream(sourceStrm, destStrm: TStream);
const
	cBufSize = $2000;
var
	zstrm: z_stream;
    cbIn, err: integer;
    s, d: pChar;
begin

    zstrm.zalloc := nil;
    zstrm.zfree := nil;
    zstrm.opaque := nil;

    if InflateInit_(@zstrm, ZLIB_VERSION, sizeof(zstrm)) <> Z_OK then
    	TslcZLibError('Unable to initialize inflation');

	GetMem(s, cBufSize);
    try
    	GetMem(d, cBufSize);
    except
    	FreeMem(s);
        raise;
    end;

    try
		zstrm.next_in := s;
	    zstrm.next_out := d;
    	zstrm.avail_out := cBufSize;

        repeat
        	cbIn := sourceStrm.Read(s^, cBufSize);
            zstrm.avail_in := cbIn;
            zstrm.next_in := s;
//			while eos < 2 do
			while zstrm.avail_in > 0 do
            begin
                err := inflate(@zstrm, Z_NO_FLUSH);
                if not (err in [Z_OK, Z_STREAM_END]) then
                	TslcZLibErrorFmt('An error occurred while inflating - %d', [err]);
				if (err = Z_STREAM_END) and (zstrm.avail_out = cBufSize) then
                	break; // kludge
                destStrm.Write(d^, cBufSize - zstrm.avail_out);
                zstrm.next_out := d;
                zstrm.avail_out := cBufSize;
            end;
        until cbIn < cBufSize;

		repeat
        	err := inflate(@zstrm, Z_FINISH);
            if err in [Z_OK, Z_STREAM_END] then
            begin
	            destStrm.Write(d^, cBufSize - zstrm.avail_out);
                zstrm.next_out := d;
                zstrm.avail_out := cBufSize;
            end;
        until err <> Z_OK;

        if err <> Z_STREAM_END then
        	TslcZLibErrorFmt('Unable to flush deflate: %d', [err]);
	finally
       	inflateEnd(@zstrm);
       	FreeMem(s);
        FreeMem(d);
    end;
end;



function TempFile: string;
var
	pathbuf, filebuf: array[0..MAX_PATH] of char;
begin
	if (GetTempPath(MAX_PATH, pathbuf) = 0) or
       	(GetTempFileName(pathbuf, 'tcl', 0, filebuf) = 0) then
       	TslcZLibError ('Unable to create temporary file');
    result := filebuf;
end;

procedure DoCompress(sourceStrm, destStrm: TStream; destFile: pChar);
const
	cBufSize = $2000;
var
	d: gzFile;
	len: integer;
	buf: array[0..cBufSize - 1] of char;
	tmp: string;
    tStrm: TStream;
begin
	CheckZLib;

	// assert destFile != NULL && destStrm != NULL
    if destFile = nil then
		tmp := TempFile
    else
    	tmp := destFile;

    try
		d := gzopen(pChar(tmp), 'wb');
		if d = gzFile(0) then
    		TslcZLibError(Format('Could not open file for writing: %s', [tmp]));
	    try
       		repeat
				len := sourceStrm.Read(buf, cBufSize);
              	if gzwrite(d, @buf[0], len) <> len then
                	TslcZLibError('Error writing stream');
            until len < cBufSize;
	    finally
			gzclose(d);
	    end;
        if destFile = nil then
        begin
			tStrm := TFileStream.Create(tmp, fmOpenRead);
	        try
	            destStrm.CopyFrom(tStrm, tStrm.Size);
	        finally
	        	tStrm.Free;
	        end;
        end;
    finally
		if destFile = nil then
	    	DeleteFile(tmp);
    end;
end;

procedure CompressStream(sourceStrm, destStrm: TStream);
begin
	DoCompress(sourceStrm, destStrm, nil);
end;

procedure CompressFile(sourcePath, destPath: string; overwrite: boolean);
var
	sStrm: TStream;
begin
	CheckZLib;

	sStrm := TFileStream.Create(sourcePath, fmOpenRead);
	try
		if FileExists(destPath) then
	    	if overwrite then
	        	DeleteFile(destPath)
	        else
		    	TslcZLibErrorFmt('%s exists - cannot overwrite', [destPath]);

       	DoCompress(sStrm, nil, pChar(destPath));
    finally
    	sStrm.Free;
    end;
end;

procedure DoDecompress(sourceStrm: TStream; srcFile: pChar; destStrm: TStream);
const
	cBufSize = $2000;
var
	s: gzFile;
	len: integer;
	buf: array[0..cBufSize - 1] of char;
	tmp: string;
    tStrm: TStream;
begin
	CheckZLib;

    // assert sourceStrm != NULL && srcFile != NULL

    try
		if srcFile = nil then
        begin
        	tmp := TempFile;
			tStrm := TFileStream.Create(tmp, fmCreate);
	        try
	            tStrm.CopyFrom(sourceStrm, sourceStrm.Size);
	        finally
	        	tStrm.Free;
    	    end;
        end else
        	tmp := srcFile;

		s := gzopen(pChar(tmp), 'rb');
		if s = gzFile(0) then
    		TslcZLibErrorFmt('Could not open file for reading: %s', [tmp]);
	    try
       		repeat
				len := gzread(s, @buf[0], cBufSize);
              	if destStrm.Write(buf, len) <> len then
                	TslcZLibError('Error writing stream');
            until len < cBufSize;
	    finally
			gzclose(s);
	    end;
    finally
		if srcFile = nil then
	    	DeleteFile(tmp);
    end;
end;

procedure DecompressStream(sourceStrm, destStrm: TStream);
begin
	DoDecompress(sourceStrm, nil, destStrm);
end;

procedure DecompressFile(sourcePath, destPath: string; overwrite: boolean);
var
	dStrm: TStream;
begin
	CheckZLib;

	if FileExists(destPath) then
    	if overwrite then
        	DeleteFile(destPath)
        else
	    	TslcZLibErrorFmt('%s exists - cannot overwrite', [destPath]);
	dStrm := TFileStream.Create(destPath, fmCreate);
	try
       	DoDecompress(nil, pChar(sourcePath), dStrm);
    finally
    	dStrm.Free;
    end;
end;

initialization

finalization
    if ZLibModule <> 0 then
    	FreeLibrary(ZLibModule);
end.

{ The following text is found in the ZLib distribution.

zlib 1.0.4 is a general purpose data compression library.  All the code
is reentrant (thread safe).  The data format used by the zlib library
is described by RFCs (Request for Comments) 1950 to 1952 in the files
ftp://ds.internic.net/rfc/rfc1950.txt (zlib format), rfc1951.txt (deflate
format) and rfc1952.txt (gzip format). These documents are also available in
other formats from ftp://ftp.uu.net/graphics/png/documents/zlib/zdoc-index.html

All functions of the compression library are documented in the file
zlib.h. A usage example of the library is given in the file example.c
which also tests that the library is working correctly. Another
example is given in the file minigzip.c. The compression library itself
is composed of all source files except example.c and minigzip.c.

To compile all files and run the test program, follow the instructions
given at the top of Makefile. In short "make test; make install"
should work for most machines.  For MSDOS, use one of the special
makefiles such as Makefile.msc; for VMS, use Make_vms.com or descrip.mms.

Questions about zlib should be sent to <zlib@quest.jpl.nasa.gov> or,
if this fails, to the addresses given below in the Copyright section.
The zlib home page is http://quest.jpl.nasa.gov/zlib/

The changes made in version 1.0.4 are documented in the file ChangeLog.
The main changes since 1.0.3 are:

- In very rare conditions, deflate(s, Z_FINISH) could fail to produce an EOF
  bit, so the decompressor could decompress all the correct data but went
  on to attempt decompressing extra garbage data. This affected minigzip too.
- zlibVersion and gzerror return const char* (needed for DLL)
- port to RISCOS (no fdopen, no multiple dots, no unlink, no fileno)


A Perl interface to zlib written by Paul Marquess <pmarquess@bfsec.bt.co.uk>
is in the CPAN (Comprehensive Perl Archive Network) sites, such as:
ftp://ftp.cis.ufl.edu/pub/perl/CPAN/modules/by-module/Compress/Compress-Zlib*


Notes for some targets:

- For Turbo C the small model is supported only with reduced performance to
  avoid any far allocation; it was tested with -DMAX_WBITS=11 -DMAX_MEM_LEVEL=3

- For 64-bit Iris, deflate.c must be compiled without any optimization.
  With -O, one libpng test fails. The test works in 32 bit mode (with
  the -32 compiler flag). The compiler bug has been reported to SGI.

- zlib doesn't work with gcc 2.6.3 on a DEC 3000/300LX under OSF/1 2.1   
  it works when compiled with cc.

- zlib doesn't work on HP-UX 9.05 with one cc compiler (the one not
  accepting the -O option). It works with the other cc compiler.

- To build a Windows DLL version, include in a DLL project zlib.def, zlib.rc
  and all .c files except example.c and minigzip.c; compile with -DZLIB_DLL
  For help on building a zlib DLL, contact Alessandro Iacopetti
  <iaco@email.alessandria.alpcom.it>  http://lisa.unial.it/iaco ,
  or contact Brad Clarke <bclarke@cyberus.ca>.

- gzdopen is not supported on RISCOS


Acknowledgments:

  The deflate format used by zlib was defined by Phil Katz. The deflate
  and zlib specifications were written by Peter Deutsch. Thanks to all the
  people who reported problems and suggested various improvements in zlib;
  they are too numerous to cite here.

Copyright notice:

 (C) 1995-1996 Jean-loup Gailly and Mark Adler

  This software is provided 'as-is', without any express or implied
  warranty.  In no event will the authors be held liable for any damages
  arising from the use of this software.

  Permission is granted to anyone to use this software for any purpose,
  including commercial applications, and to alter it and redistribute it
  freely, subject to the following restrictions:

  1. The origin of this software must not be misrepresented; you must not
     claim that you wrote the original software. If you use this software
     in a product, an acknowledgment in the product documentation would be
     appreciated but is not required.
  2. Altered source versions must be plainly marked as such, and must not be
     misrepresented as being the original software.
  3. This notice may not be removed or altered from any source distribution.

  Jean-loup Gailly        Mark Adler
  gzip@prep.ai.mit.edu    madler@alumni.caltech.edu

If you use the zlib library in a product, we would appreciate *not*
receiving lengthy legal documents to sign. The sources are provided
for free but without warranty of any kind.  The library has been
entirely written by Jean-loup Gailly and Mark Adler; it does not
include third-party code.

If you redistribute modified sources, we would appreciate that you include
in the file ChangeLog history information documenting your changes.
}