Vichingo455-RePacks/xtool
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases 1 Wiki Activity

source upload

Browse Source
This commit is contained in:
Razor12911
2022-01-17 22:16:47 +02:00
parent 12936d065b
commit 098e8c48de
1778 changed files with 1206749 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

117
contrib/fundamentals/ZLib/paszlib/Adler.pas Normal file
View File

@@ -0,0 +1,117 @@
Unit Adler;
{
adler32.c -- compute the Adler-32 checksum of a data stream
Copyright (C) 1995-1998 Mark Adler
Pascal tranlastion
Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
Modifiied 02/2003 by Sergey A. Galin for Delphi 6+ and Kylix compatibility.
See README in directory above for more information.
}
interface
{$I zconf.inc}
uses
ZUtil;
function adler32(adler : uLong; buf : pBytef; len : uInt) : uLong;
{ Update a running Adler-32 checksum with the bytes buf[0..len-1] and
return the updated checksum. If buf is NIL, this function returns
the required initial value for the checksum.
An Adler-32 checksum is almost as reliable as a CRC32 but can be computed
much faster. Usage example:
var
adler : uLong;
begin
adler := adler32(0, Z_NULL, 0);
while (read_buffer(buffer, length) <> EOF) do
adler := adler32(adler, buffer, length);
if (adler <> original_adler) then
error();
end;
}
implementation
const
BASE = uLong(65521); { largest prime smaller than 65536 }
{NMAX = 5552; original code with unsigned 32 bit integer }
{ NMAX is the largest n such that 255n(n+1)/2 + (n+1)(BASE-1) <= 2^32-1 }
NMAX = 3854; { code with signed 32 bit integer }
{ NMAX is the largest n such that 255n(n+1)/2 + (n+1)(BASE-1) <= 2^31-1 }
{ The penalty is the time loss in the extra MOD-calls. }
{ ========================================================================= }
function adler32(adler : uLong; buf : pBytef; len : uInt) : uLong;
var
s1, s2 : uLong;
k : int;
begin
s1 := adler and $ffff;
s2 := (adler shr 16) and $ffff;
if not Assigned(buf) then
begin
adler32 := uLong(1);
exit;
end;
while (len > 0) do
begin
if len < NMAX then
k := len
else
k := NMAX;
Dec(len, k);
{
while (k >= 16) do
begin
DO16(buf);
Inc(buf, 16);
Dec(k, 16);
end;
if (k <> 0) then
repeat
Inc(s1, buf^);
Inc(puf);
Inc(s2, s1);
Dec(k);
until (k = 0);
}
while (k > 0) do
begin
Inc(s1, buf^);
Inc(s2, s1);
Inc(buf);
Dec(k);
end;
s1 := s1 mod BASE;
s2 := s2 mod BASE;
end;
adler32 := (s2 shl 16) or s1;
end;
{
#define DO1(buf,i)
begin
Inc(s1, buf[i]);
Inc(s2, s1);
end;
#define DO2(buf,i) DO1(buf,i); DO1(buf,i+1);
#define DO4(buf,i) DO2(buf,i); DO2(buf,i+2);
#define DO8(buf,i) DO4(buf,i); DO4(buf,i+4);
#define DO16(buf) DO8(buf,0); DO8(buf,8);
}
end.

239
contrib/fundamentals/ZLib/paszlib/Crc.pas Normal file
View File

@@ -0,0 +1,239 @@
Unit Crc;
{
crc32.c -- compute the CRC-32 of a data stream
Copyright (C) 1995-1998 Mark Adler
Pascal tranlastion
Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
Modifiied 02/2003 by Sergey A. Galin for Delphi 6+ and Kylix compatibility.
See README in directory above for more information.
}
interface
{$I zconf.inc}
uses
ZUtil, gZlib;
function crc32(crc : uLong; buf : pBytef; len : uInt) : uLong;
{ Update a running crc with the bytes buf[0..len-1] and return the updated
crc. If buf is NULL, this function returns the required initial value
for the crc. Pre- and post-conditioning (one's complement) is performed
within this function so it shouldn't be done by the application.
Usage example:
var
crc : uLong;
begin
crc := crc32(0, Z_NULL, 0);
while (read_buffer(buffer, length) <> EOF) do
crc := crc32(crc, buffer, length);
if (crc <> original_crc) then error();
end;
}
function get_crc_table : puLong; { can be used by asm versions of crc32() }
implementation
{$IFDEF DYNAMIC_CRC_TABLE}
{local}
const
crc_table_empty : boolean = TRUE;
{local}
var
crc_table : array[0..256-1] of uLongf;
{
Generate a table for a byte-wise 32-bit CRC calculation on the polynomial:
x^32+x^26+x^23+x^22+x^16+x^12+x^11+x^10+x^8+x^7+x^5+x^4+x^2+x+1.
Polynomials over GF(2) are represented in binary, one bit per coefficient,
with the lowest powers in the most significant bit. Then adding polynomials
is just exclusive-or, and multiplying a polynomial by x is a right shift by
one. If we call the above polynomial p, and represent a byte as the
polynomial q, also with the lowest power in the most significant bit (so the
byte 0xb1 is the polynomial x^7+x^3+x+1), then the CRC is (q*x^32) mod p,
where a mod b means the remainder after dividing a by b.
This calculation is done using the shift-register method of multiplying and
taking the remainder. The register is initialized to zero, and for each
incoming bit, x^32 is added mod p to the register if the bit is a one (where
x^32 mod p is p+x^32 = x^26+...+1), and the register is multiplied mod p by
x (which is shifting right by one and adding x^32 mod p if the bit shifted
out is a one). We start with the highest power (least significant bit) of
q and repeat for all eight bits of q.
The table is simply the CRC of all possible eight bit values. This is all
the information needed to generate CRC's on data a byte at a time for all
combinations of CRC register values and incoming bytes.
}
{local}
procedure make_crc_table;
var
c : uLong;
n,k : int;
poly : uLong; { polynomial exclusive-or pattern }
const
{ terms of polynomial defining this crc (except x^32): }
p: array [0..13] of Byte = (0,1,2,4,5,7,8,10,11,12,16,22,23,26);
begin
{ make exclusive-or pattern from polynomial ($EDB88320) }
poly := Long(0);
for n := 0 to (sizeof(p) div sizeof(Byte))-1 do
poly := poly or (Long(1) shl (31 - p[n]));
for n := 0 to 255 do
begin
c := uLong(n);
for k := 0 to 7 do
begin
if (c and 1) <> 0 then
c := poly xor (c shr 1)
else
c := (c shr 1);
end;
crc_table[n] := c;
end;
crc_table_empty := FALSE;
end;
{$ELSE}
{ ========================================================================
Table of CRC-32's of all single-byte values (made by make_crc_table) }
{local}
const
crc_table : array[0..255] of uLongf = (
$00000000, $77073096, $ee0e612c, $990951ba, $076dc419,
$706af48f, $e963a535, $9e6495a3, $0edb8832, $79dcb8a4,
$e0d5e91e, $97d2d988, $09b64c2b, $7eb17cbd, $e7b82d07,
$90bf1d91, $1db71064, $6ab020f2, $f3b97148, $84be41de,
$1adad47d, $6ddde4eb, $f4d4b551, $83d385c7, $136c9856,
$646ba8c0, $fd62f97a, $8a65c9ec, $14015c4f, $63066cd9,
$fa0f3d63, $8d080df5, $3b6e20c8, $4c69105e, $d56041e4,
$a2677172, $3c03e4d1, $4b04d447, $d20d85fd, $a50ab56b,
$35b5a8fa, $42b2986c, $dbbbc9d6, $acbcf940, $32d86ce3,
$45df5c75, $dcd60dcf, $abd13d59, $26d930ac, $51de003a,
$c8d75180, $bfd06116, $21b4f4b5, $56b3c423, $cfba9599,
$b8bda50f, $2802b89e, $5f058808, $c60cd9b2, $b10be924,
$2f6f7c87, $58684c11, $c1611dab, $b6662d3d, $76dc4190,
$01db7106, $98d220bc, $efd5102a, $71b18589, $06b6b51f,
$9fbfe4a5, $e8b8d433, $7807c9a2, $0f00f934, $9609a88e,
$e10e9818, $7f6a0dbb, $086d3d2d, $91646c97, $e6635c01,
$6b6b51f4, $1c6c6162, $856530d8, $f262004e, $6c0695ed,
$1b01a57b, $8208f4c1, $f50fc457, $65b0d9c6, $12b7e950,
$8bbeb8ea, $fcb9887c, $62dd1ddf, $15da2d49, $8cd37cf3,
$fbd44c65, $4db26158, $3ab551ce, $a3bc0074, $d4bb30e2,
$4adfa541, $3dd895d7, $a4d1c46d, $d3d6f4fb, $4369e96a,
$346ed9fc, $ad678846, $da60b8d0, $44042d73, $33031de5,
$aa0a4c5f, $dd0d7cc9, $5005713c, $270241aa, $be0b1010,
$c90c2086, $5768b525, $206f85b3, $b966d409, $ce61e49f,
$5edef90e, $29d9c998, $b0d09822, $c7d7a8b4, $59b33d17,
$2eb40d81, $b7bd5c3b, $c0ba6cad, $edb88320, $9abfb3b6,
$03b6e20c, $74b1d29a, $ead54739, $9dd277af, $04db2615,
$73dc1683, $e3630b12, $94643b84, $0d6d6a3e, $7a6a5aa8,
$e40ecf0b, $9309ff9d, $0a00ae27, $7d079eb1, $f00f9344,
$8708a3d2, $1e01f268, $6906c2fe, $f762575d, $806567cb,
$196c3671, $6e6b06e7, $fed41b76, $89d32be0, $10da7a5a,
$67dd4acc, $f9b9df6f, $8ebeeff9, $17b7be43, $60b08ed5,
$d6d6a3e8, $a1d1937e, $38d8c2c4, $4fdff252, $d1bb67f1,
$a6bc5767, $3fb506dd, $48b2364b, $d80d2bda, $af0a1b4c,
$36034af6, $41047a60, $df60efc3, $a867df55, $316e8eef,
$4669be79, $cb61b38c, $bc66831a, $256fd2a0, $5268e236,
$cc0c7795, $bb0b4703, $220216b9, $5505262f, $c5ba3bbe,
$b2bd0b28, $2bb45a92, $5cb36a04, $c2d7ffa7, $b5d0cf31,
$2cd99e8b, $5bdeae1d, $9b64c2b0, $ec63f226, $756aa39c,
$026d930a, $9c0906a9, $eb0e363f, $72076785, $05005713,
$95bf4a82, $e2b87a14, $7bb12bae, $0cb61b38, $92d28e9b,
$e5d5be0d, $7cdcefb7, $0bdbdf21, $86d3d2d4, $f1d4e242,
$68ddb3f8, $1fda836e, $81be16cd, $f6b9265b, $6fb077e1,
$18b74777, $88085ae6, $ff0f6a70, $66063bca, $11010b5c,
$8f659eff, $f862ae69, $616bffd3, $166ccf45, $a00ae278,
$d70dd2ee, $4e048354, $3903b3c2, $a7672661, $d06016f7,
$4969474d, $3e6e77db, $aed16a4a, $d9d65adc, $40df0b66,
$37d83bf0, $a9bcae53, $debb9ec5, $47b2cf7f, $30b5ffe9,
$bdbdf21c, $cabac28a, $53b39330, $24b4a3a6, $bad03605,
$cdd70693, $54de5729, $23d967bf, $b3667a2e, $c4614ab8,
$5d681b02, $2a6f2b94, $b40bbe37, $c30c8ea1, $5a05df1b,
$2d02ef8d);
{$ENDIF}
{ =========================================================================
This function can be used by asm versions of crc32() }
function get_crc_table : {const} puLong;
begin
{$ifdef DYNAMIC_CRC_TABLE}
if (crc_table_empty) then
make_crc_table;
{$endif}
get_crc_table := {const} puLong(@crc_table);
end;
{ ========================================================================= }
function crc32 (crc : uLong; buf : pBytef; len : uInt): uLong;
begin
if (buf = Z_NULL) then
crc32 := Long(0)
else
begin
{$IFDEF DYNAMIC_CRC_TABLE}
if crc_table_empty then
make_crc_table;
{$ENDIF}
crc := crc xor uLong($ffffffff);
while (len >= 8) do
begin
{DO8(buf)}
crc := crc_table[(int(crc) xor buf^) and $ff] xor (crc shr 8);
inc(buf);
crc := crc_table[(int(crc) xor buf^) and $ff] xor (crc shr 8);
inc(buf);
crc := crc_table[(int(crc) xor buf^) and $ff] xor (crc shr 8);
inc(buf);
crc := crc_table[(int(crc) xor buf^) and $ff] xor (crc shr 8);
inc(buf);
crc := crc_table[(int(crc) xor buf^) and $ff] xor (crc shr 8);
inc(buf);
crc := crc_table[(int(crc) xor buf^) and $ff] xor (crc shr 8);
inc(buf);
crc := crc_table[(int(crc) xor buf^) and $ff] xor (crc shr 8);
inc(buf);
crc := crc_table[(int(crc) xor buf^) and $ff] xor (crc shr 8);
inc(buf);
Dec(len, 8);
end;
if (len <> 0) then
repeat
{DO1(buf)}
crc := crc_table[(int(crc) xor buf^) and $ff] xor (crc shr 8);
inc(buf);
Dec(len);
until (len = 0);
crc32 := crc xor uLong($ffffffff);
end;
end;
end.

952
contrib/fundamentals/ZLib/paszlib/InfBlock.pas Normal file
View File

@@ -0,0 +1,952 @@
Unit InfBlock;
{ infblock.h and
infblock.c -- interpret and process block types to last block
Copyright (C) 1995-1998 Mark Adler
Pascal tranlastion
Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
Modifiied 02/2003 by Sergey A. Galin for Delphi 6+ and Kylix compatibility.
See README in directory above for more information.
}
interface
{$I zconf.inc}
{.DEFINE INFBLOCK_DEBUG}
uses zutil, gzlib;
function inflate_blocks_new(var z : z_stream;
c : check_func; { check function }
w : uInt { window size }
) : pInflate_blocks_state;
function inflate_blocks (var s : inflate_blocks_state;
var z : z_stream;
r : int { initial return code }
) : int;
procedure inflate_blocks_reset (var s : inflate_blocks_state;
var z : z_stream;
c : puLong); { check value on output }
function inflate_blocks_free(s : pInflate_blocks_state;
var z : z_stream) : int;
procedure inflate_set_dictionary(var s : inflate_blocks_state;
const d : array of byte; { dictionary }
n : uInt); { dictionary length }
function inflate_blocks_sync_point(var s : inflate_blocks_state) : int;
implementation
uses
InfCodes, InfTrees, InfUtil;
{ Tables for deflate from PKZIP's appnote.txt. }
Const
border : Array [0..18] Of Word { Order of the bit length code lengths }
= (16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15);
{ Notes beyond the 1.93a appnote.txt:
1. Distance pointers never point before the beginning of the output
stream.
2. Distance pointers can point back across blocks, up to 32k away.
3. There is an implied maximum of 7 bits for the bit length table and
15 bits for the actual data.
4. If only one code exists, then it is encoded using one bit. (Zero
would be more efficient, but perhaps a little confusing.) If two
codes exist, they are coded using one bit each (0 and 1).
5. There is no way of sending zero distance codes--a dummy must be
sent if there are none. (History: a pre 2.0 version of PKZIP would
store blocks with no distance codes, but this was discovered to be
too harsh a criterion.) Valid only for 1.93a. 2.04c does allow
zero distance codes, which is sent as one code of zero bits in
length.
6. There are up to 286 literal/length codes. Code 256 represents the
end-of-block. Note however that the static length tree defines
288 codes just to fill out the Huffman codes. Codes 286 and 287
cannot be used though, since there is no length base or extra bits
defined for them. Similarily, there are up to 30 distance codes.
However, static trees define 32 codes (all 5 bits) to fill out the
Huffman codes, but the last two had better not show up in the data.
7. Unzip can check dynamic Huffman blocks for complete code sets.
The exception is that a single code would not be complete (see #4).
8. The five bits following the block type is really the number of
literal codes sent minus 257.
9. Length codes 8,16,16 are interpreted as 13 length codes of 8 bits
(1+6+6). Therefore, to output three times the length, you output
three codes (1+1+1), whereas to output four times the same length,
you only need two codes (1+3). Hmm.
10. In the tree reconstruction algorithm, Code = Code + Increment
only if BitLength(i) is not zero. (Pretty obvious.)
11. Correction: 4 Bits: # of Bit Length codes - 4 (4 - 19)
12. Note: length code 284 can represent 227-258, but length code 285
really is 258. The last length deserves its own, short code
since it gets used a lot in very redundant files. The length
258 is special since 258 - 3 (the min match length) is 255.
13. The literal/length and distance code bit lengths are read as a
single stream of lengths. It is possible (and advantageous) for
a repeat code (16, 17, or 18) to go across the boundary between
the two sets of lengths. }
procedure inflate_blocks_reset (var s : inflate_blocks_state;
var z : z_stream;
c : puLong); { check value on output }
begin
if (c <> Z_NULL) then
c^ := s.check;
if (s.mode = BTREE) or (s.mode = DTREE) then
ZFREE(z, s.sub.trees.blens);
if (s.mode = CODES) then
inflate_codes_free(s.sub.decode.codes, z);
s.mode := ZTYPE;
s.bitk := 0;
s.bitb := 0;
s.write := s.window;
s.read := s.window;
if Assigned(s.checkfn) then
begin
s.check := s.checkfn(uLong(0), pBytef(NIL), 0);
z.adler := s.check;
end;
{$IFDEF INFBLOCK_DEBUG}
Tracev('inflate: blocks reset');
{$ENDIF}
end;
function inflate_blocks_new(var z : z_stream;
c : check_func; { check function }
w : uInt { window size }
) : pInflate_blocks_state;
var
s : pInflate_blocks_state;
begin
s := pInflate_blocks_state( ZALLOC(z,1, sizeof(inflate_blocks_state)) );
if (s = Z_NULL) then
begin
inflate_blocks_new := s;
exit;
end;
s^.hufts := huft_ptr( ZALLOC(z, sizeof(inflate_huft), MANY) );
if (s^.hufts = Z_NULL) then
begin
ZFREE(z, s);
inflate_blocks_new := Z_NULL;
exit;
end;
s^.window := pBytef( ZALLOC(z, 1, w) );
if (s^.window = Z_NULL) then
begin
ZFREE(z, s^.hufts);
ZFREE(z, s);
inflate_blocks_new := Z_NULL;
exit;
end;
s^.zend := s^.window;
Inc(s^.zend, w);
s^.checkfn := c;
s^.mode := ZTYPE;
{$IFDEF INFBLOCK_DEBUG}
Tracev('inflate: blocks allocated');
{$ENDIF}
inflate_blocks_reset(s^, z, Z_NULL);
inflate_blocks_new := s;
end;
function inflate_blocks (var s : inflate_blocks_state;
var z : z_stream;
r : int) : int; { initial return code }
label
start_btree, start_dtree,
start_blkdone, start_dry,
start_codes;
var
t : uInt; { temporary storage }
b : uLong; { bit buffer }
k : uInt; { bits in bit buffer }
p : pBytef; { input data pointer }
n : uInt; { bytes available there }
q : pBytef; { output window write pointer }
m : uInt; { bytes to end of window or read pointer }
{ fixed code blocks }
var
bl, bd : uInt;
tl, td : pInflate_huft;
var
h : pInflate_huft;
i, j, c : uInt;
var
cs : pInflate_codes_state;
begin
{ copy input/output information to locals }
p := z.next_in;
n := z.avail_in;
b := s.bitb;
k := s.bitk;
q := s.write;
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
{ decompress an inflated block }
{ process input based on current state }
while True do
Case s.mode of
ZTYPE:
begin
{NEEDBITS(3);}
while (k < 3) do
begin
{NEEDBYTE;}
if (n <> 0) then
r :=Z_OK
else
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
Dec(n);
b := b or (uLong(p^) shl k);
Inc(p);
Inc(k, 8);
end;
t := uInt(b) and 7;
s.last := boolean(t and 1);
case (t shr 1) of
0: { stored }
begin
{$IFDEF INFBLOCK_DEBUG}
if s.last then
Tracev('inflate: stored block (last)')
else
Tracev('inflate: stored block');
{$ENDIF}
{DUMPBITS(3);}
b := b shr 3;
Dec(k, 3);
t := k and 7; { go to byte boundary }
{DUMPBITS(t);}
b := b shr t;
Dec(k, t);
s.mode := LENS; { get length of stored block }
end;
1: { fixed }
begin
begin
{$IFDEF INFBLOCK_DEBUG}
if s.last then
Tracev('inflate: fixed codes blocks (last)')
else
Tracev('inflate: fixed codes blocks');
{$ENDIF}
inflate_trees_fixed(bl, bd, tl, td, z);
s.sub.decode.codes := inflate_codes_new(bl, bd, tl, td, z);
if (s.sub.decode.codes = Z_NULL) then
begin
r := Z_MEM_ERROR;
{ update pointers and return }
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
end;
{DUMPBITS(3);}
b := b shr 3;
Dec(k, 3);
s.mode := CODES;
end;
2: { dynamic }
begin
{$IFDEF INFBLOCK_DEBUG}
if s.last then
Tracev('inflate: dynamic codes block (last)')
else
Tracev('inflate: dynamic codes block');
{$ENDIF}
{DUMPBITS(3);}
b := b shr 3;
Dec(k, 3);
s.mode := TABLE;
end;
3:
begin { illegal }
{DUMPBITS(3);}
b := b shr 3;
Dec(k, 3);
s.mode := BLKBAD;
z.msg := 'invalid block type';
r := Z_DATA_ERROR;
{ update pointers and return }
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
end;
end;
LENS:
begin
{NEEDBITS(32);}
while (k < 32) do
begin
{NEEDBYTE;}
if (n <> 0) then
r :=Z_OK
else
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
Dec(n);
b := b or (uLong(p^) shl k);
Inc(p);
Inc(k, 8);
end;
if (((not b) shr 16) and $ffff) <> (b and $ffff) then
begin
s.mode := BLKBAD;
z.msg := 'invalid stored block lengths';
r := Z_DATA_ERROR;
{ update pointers and return }
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
s.sub.left := uInt(b) and $ffff;
k := 0;
b := 0; { dump bits }
{$IFDEF INFBLOCK_DEBUG}
Tracev('inflate: stored length '+IntToStr(s.sub.left));
{$ENDIF}
if s.sub.left <> 0 then
s.mode := STORED
else
if s.last then
s.mode := DRY
else
s.mode := ZTYPE;
end;
STORED:
begin
if (n = 0) then
begin
{ update pointers and return }
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
{NEEDOUT}
if (m = 0) then
begin
{WRAP}
if (q = s.zend) and (s.read <> s.window) then
begin
q := s.window;
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
end;
if (m = 0) then
begin
{FLUSH}
s.write := q;
r := inflate_flush(s,z,r);
q := s.write;
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
{WRAP}
if (q = s.zend) and (s.read <> s.window) then
begin
q := s.window;
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
end;
if (m = 0) then
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
end;
end;
r := Z_OK;
t := s.sub.left;
if (t > n) then
t := n;
if (t > m) then
t := m;
zmemcpy(q, p, t);
Inc(p, t); Dec(n, t);
Inc(q, t); Dec(m, t);
Dec(s.sub.left, t);
if (s.sub.left = 0) then
begin
{$IFDEF INFBLOCK_DEBUG}
if (ptr2int(q) >= ptr2int(s.read)) then
Tracev('inflate: stored end '+
IntToStr(z.total_out + ptr2int(q) - ptr2int(s.read)) + ' total out')
else
Tracev('inflate: stored end '+
IntToStr(z.total_out + ptr2int(s.zend) - ptr2int(s.read) +
ptr2int(q) - ptr2int(s.window)) + ' total out');
{$ENDIF}
if s.last then
s.mode := DRY
else
s.mode := ZTYPE;
end;
end;
TABLE:
begin
{NEEDBITS(14);}
while (k < 14) do
begin
{NEEDBYTE;}
if (n <> 0) then
r :=Z_OK
else
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
Dec(n);
b := b or (uLong(p^) shl k);
Inc(p);
Inc(k, 8);
end;
t := uInt(b) and $3fff;
s.sub.trees.table := t;
{$ifndef PKZIP_BUG_WORKAROUND}
if ((t and $1f) > 29) or (((t shr 5) and $1f) > 29) then
begin
s.mode := BLKBAD;
z.msg := 'too many length or distance symbols';
r := Z_DATA_ERROR;
{ update pointers and return }
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
{$endif}
t := 258 + (t and $1f) + ((t shr 5) and $1f);
s.sub.trees.blens := puIntArray( ZALLOC(z, t, sizeof(uInt)) );
if (s.sub.trees.blens = Z_NULL) then
begin
r := Z_MEM_ERROR;
{ update pointers and return }
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
{DUMPBITS(14);}
b := b shr 14;
Dec(k, 14);
s.sub.trees.index := 0;
{$IFDEF INFBLOCK_DEBUG}
Tracev('inflate: table sizes ok');
{$ENDIF}
s.mode := BTREE;
{ fall trough case is handled by the while }
{ try GOTO for speed - Nomssi }
goto start_btree;
end;
BTREE:
begin
start_btree:
while (s.sub.trees.index < 4 + (s.sub.trees.table shr 10)) do
begin
{NEEDBITS(3);}
while (k < 3) do
begin
{NEEDBYTE;}
if (n <> 0) then
r :=Z_OK
else
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
Dec(n);
b := b or (uLong(p^) shl k);
Inc(p);
Inc(k, 8);
end;
s.sub.trees.blens^[border[s.sub.trees.index]] := uInt(b) and 7;
Inc(s.sub.trees.index);
{DUMPBITS(3);}
b := b shr 3;
Dec(k, 3);
end;
while (s.sub.trees.index < 19) do
begin
s.sub.trees.blens^[border[s.sub.trees.index]] := 0;
Inc(s.sub.trees.index);
end;
s.sub.trees.bb := 7;
t := inflate_trees_bits(s.sub.trees.blens^, s.sub.trees.bb,
s.sub.trees.tb, s.hufts^, z);
if (t <> Z_OK) then
begin
ZFREE(z, s.sub.trees.blens);
r := t;
if (r = Z_DATA_ERROR) then
s.mode := BLKBAD;
{ update pointers and return }
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
s.sub.trees.index := 0;
{$IFDEF INFBLOCK_DEBUG}
Tracev('inflate: bits tree ok');
{$ENDIF}
s.mode := DTREE;
{ fall through again }
goto start_dtree;
end;
DTREE:
begin
start_dtree:
while TRUE do
begin
t := s.sub.trees.table;
if not (s.sub.trees.index < 258 +
(t and $1f) + ((t shr 5) and $1f)) then
break;
t := s.sub.trees.bb;
{NEEDBITS(t);}
while (k < t) do
begin
{NEEDBYTE;}
if (n <> 0) then
r :=Z_OK
else
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
Dec(n);
b := b or (uLong(p^) shl k);
Inc(p);
Inc(k, 8);
end;
h := s.sub.trees.tb;
Inc(h, uInt(b) and inflate_mask[t]);
t := h^.Bits;
c := h^.Base;
if (c < 16) then
begin
{DUMPBITS(t);}
b := b shr t;
Dec(k, t);
s.sub.trees.blens^[s.sub.trees.index] := c;
Inc(s.sub.trees.index);
end
else { c = 16..18 }
begin
if c = 18 then
begin
i := 7;
j := 11;
end
else
begin
i := c - 14;
j := 3;
end;
{NEEDBITS(t + i);}
while (k < t + i) do
begin
{NEEDBYTE;}
if (n <> 0) then
r :=Z_OK
else
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
Dec(n);
b := b or (uLong(p^) shl k);
Inc(p);
Inc(k, 8);
end;
{DUMPBITS(t);}
b := b shr t;
Dec(k, t);
Inc(j, uInt(b) and inflate_mask[i]);
{DUMPBITS(i);}
b := b shr i;
Dec(k, i);
i := s.sub.trees.index;
t := s.sub.trees.table;
if (i + j > 258 + (t and $1f) + ((t shr 5) and $1f)) or
((c = 16) and (i < 1)) then
begin
ZFREE(z, s.sub.trees.blens);
s.mode := BLKBAD;
z.msg := 'invalid bit length repeat';
r := Z_DATA_ERROR;
{ update pointers and return }
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
if c = 16 then
c := s.sub.trees.blens^[i - 1]
else
c := 0;
repeat
s.sub.trees.blens^[i] := c;
Inc(i);
Dec(j);
until (j=0);
s.sub.trees.index := i;
end;
end; { while }
s.sub.trees.tb := Z_NULL;
begin
bl := 9; { must be <= 9 for lookahead assumptions }
bd := 6; { must be <= 9 for lookahead assumptions }
t := s.sub.trees.table;
t := inflate_trees_dynamic(257 + (t and $1f),
1 + ((t shr 5) and $1f),
s.sub.trees.blens^, bl, bd, tl, td, s.hufts^, z);
ZFREE(z, s.sub.trees.blens);
if (t <> Z_OK) then
begin
if (t = uInt(Z_DATA_ERROR)) then
s.mode := BLKBAD;
r := t;
{ update pointers and return }
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
{$IFDEF INFBLOCK_DEBUG}
Tracev('inflate: trees ok');
{$ENDIF}
{ c renamed to cs }
cs := inflate_codes_new(bl, bd, tl, td, z);
if (cs = Z_NULL) then
begin
r := Z_MEM_ERROR;
{ update pointers and return }
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
s.sub.decode.codes := cs;
end;
s.mode := CODES;
{ yet another falltrough }
goto start_codes;
end;
CODES:
begin
start_codes:
{ update pointers }
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
s.write := q;
r := inflate_codes(s, z, r);
if (r <> Z_STREAM_END) then
begin
inflate_blocks := inflate_flush(s, z, r);
exit;
end;
r := Z_OK;
inflate_codes_free(s.sub.decode.codes, z);
{ load local pointers }
p := z.next_in;
n := z.avail_in;
b := s.bitb;
k := s.bitk;
q := s.write;
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
{$IFDEF INFBLOCK_DEBUG}
if (ptr2int(q) >= ptr2int(s.read)) then
Tracev('inflate: codes end '+
IntToStr(z.total_out + ptr2int(q) - ptr2int(s.read)) + ' total out')
else
Tracev('inflate: codes end '+
IntToStr(z.total_out + ptr2int(s.zend) - ptr2int(s.read) +
ptr2int(q) - ptr2int(s.window)) + ' total out');
{$ENDIF}
if (not s.last) then
begin
s.mode := ZTYPE;
continue; { break for switch statement in C-code }
end;
{$ifndef patch112}
if (k > 7) then { return unused byte, if any }
begin
{$IFDEF INFBLOCK_DEBUG}
Assert(k < 16, 'inflate_codes grabbed too many bytes');
{$ENDIF}
Dec(k, 8);
Inc(n);
Dec(p); { can always return one }
end;
{$endif}
s.mode := DRY;
{ another falltrough }
goto start_dry;
end;
DRY:
begin
start_dry:
{FLUSH}
s.write := q;
r := inflate_flush(s,z,r);
q := s.write;
{ not needed anymore, we are done:
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
}
if (s.read <> s.write) then
begin
{ update pointers and return }
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
s.mode := BLKDONE;
goto start_blkdone;
end;
BLKDONE:
begin
start_blkdone:
r := Z_STREAM_END;
{ update pointers and return }
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
BLKBAD:
begin
r := Z_DATA_ERROR;
{ update pointers and return }
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
else
begin
r := Z_STREAM_ERROR;
{ update pointers and return }
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
end; { Case s.mode of }
end;
function inflate_blocks_free(s : pInflate_blocks_state;
var z : z_stream) : int;
begin
inflate_blocks_reset(s^, z, Z_NULL);
ZFREE(z, s^.window);
ZFREE(z, s^.hufts);
ZFREE(z, s);
{$IFDEF INFBLOCK_DEBUG}
Trace('inflate: blocks freed');
{$ENDIF}
inflate_blocks_free := Z_OK;
end;
procedure inflate_set_dictionary(var s : inflate_blocks_state;
const d : array of byte; { dictionary }
n : uInt); { dictionary length }
begin
zmemcpy(s.window, pBytef(@d), n);
s.write := s.window;
Inc(s.write, n);
s.read := s.write;
end;
{ Returns true if inflate is currently at the end of a block generated
by Z_SYNC_FLUSH or Z_FULL_FLUSH.
IN assertion: s <> Z_NULL }
function inflate_blocks_sync_point(var s : inflate_blocks_state) : int;
begin
inflate_blocks_sync_point := int(s.mode = LENS);
end;
end.

578
contrib/fundamentals/ZLib/paszlib/InfCodes.pas Normal file
View File

@@ -0,0 +1,578 @@
Unit InfCodes;
{ infcodes.c -- process literals and length/distance pairs
Copyright (C) 1995-1998 Mark Adler
Pascal tranlastion
Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
Modifiied 02/2003 by Sergey A. Galin for Delphi 6+ and Kylix compatibility.
See README in directory above for more information.
}
interface
{$I zconf.inc}
{.DEFINE INFCODES_DEBUG}
uses
zutil, gzlib;
function inflate_codes_new (bl : uInt;
bd : uInt;
tl : pInflate_huft;
td : pInflate_huft;
var z : z_stream): pInflate_codes_state;
function inflate_codes(var s : inflate_blocks_state;
var z : z_stream;
r : int) : int;
procedure inflate_codes_free(c : pInflate_codes_state;
var z : z_stream);
implementation
uses
infutil, InfFast;
function inflate_codes_new (bl : uInt;
bd : uInt;
tl : pInflate_huft;
td : pInflate_huft;
var z : z_stream): pInflate_codes_state;
var
c : pInflate_codes_state;
begin
c := pInflate_codes_state( ZALLOC(z,1,sizeof(inflate_codes_state)) );
if (c <> Z_NULL) then
begin
c^.mode := START;
c^.lbits := Byte(bl);
c^.dbits := Byte(bd);
c^.ltree := tl;
c^.dtree := td;
{$IFDEF INFCODES_DEBUG}
Tracev('inflate: codes new');
{$ENDIF}
end;
inflate_codes_new := c;
end;
function inflate_codes(var s : inflate_blocks_state;
var z : z_stream;
r : int) : int;
var
j : uInt; { temporary storage }
t : pInflate_huft; { temporary pointer }
e : uInt; { extra bits or operation }
b : uLong; { bit buffer }
k : uInt; { bits in bit buffer }
p : pBytef; { input data pointer }
n : uInt; { bytes available there }
q : pBytef; { output window write pointer }
m : uInt; { bytes to end of window or read pointer }
f : pBytef; { pointer to copy strings from }
var
c : pInflate_codes_state;
begin
c := s.sub.decode.codes; { codes state }
{ copy input/output information to locals }
p := z.next_in;
n := z.avail_in;
b := s.bitb;
k := s.bitk;
q := s.write;
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
{ process input and output based on current state }
while True do
case (c^.mode) of
{ waiting for "i:"=input, "o:"=output, "x:"=nothing }
START: { x: set up for LEN }
begin
{$ifndef SLOW}
if (m >= 258) and (n >= 10) then
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
r := inflate_fast(c^.lbits, c^.dbits, c^.ltree, c^.dtree, s, z);
{LOAD}
p := z.next_in;
n := z.avail_in;
b := s.bitb;
k := s.bitk;
q := s.write;
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
if (r <> Z_OK) then
begin
if (r = Z_STREAM_END) then
c^.mode := WASH
else
c^.mode := BADCODE;
continue; { break for switch-statement in C }
end;
end;
{$endif} { not SLOW }
c^.sub.code.need := c^.lbits;
c^.sub.code.tree := c^.ltree;
c^.mode := LEN; { falltrough }
end;
LEN: { i: get length/literal/eob next }
begin
j := c^.sub.code.need;
{NEEDBITS(j);}
while (k < j) do
begin
{NEEDBYTE;}
if (n <> 0) then
r :=Z_OK
else
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_codes := inflate_flush(s,z,r);
exit;
end;
Dec(n);
b := b or (uLong(p^) shl k);
Inc(p);
Inc(k, 8);
end;
t := c^.sub.code.tree;
Inc(t, uInt(b) and inflate_mask[j]);
{DUMPBITS(t^.bits);}
b := b shr t^.bits;
Dec(k, t^.bits);
e := uInt(t^.exop);
if (e = 0) then { literal }
begin
c^.sub.lit := t^.base;
{$IFDEF INFCODES_DEBUG}
if (t^.base >= $20) and (t^.base < $7f) then
Tracevv('inflate: literal '+char(t^.base))
else
Tracevv('inflate: literal '+IntToStr(t^.base));
{$ENDIF}
c^.mode := LIT;
continue; { break switch statement }
end;
if (e and 16 <> 0) then { length }
begin
c^.sub.copy.get := e and 15;
c^.len := t^.base;
c^.mode := LENEXT;
continue; { break C-switch statement }
end;
if (e and 64 = 0) then { next table }
begin
c^.sub.code.need := e;
c^.sub.code.tree := @huft_ptr(t)^[t^.base];
continue; { break C-switch statement }
end;
if (e and 32 <> 0) then { end of block }
begin
{$IFDEF INFCODES_DEBUG}
Tracevv('inflate: end of block');
{$ENDIF}
c^.mode := WASH;
continue; { break C-switch statement }
end;
c^.mode := BADCODE; { invalid code }
z.msg := 'invalid literal/length code';
r := Z_DATA_ERROR;
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_codes := inflate_flush(s,z,r);
exit;
end;
LENEXT: { i: getting length extra (have base) }
begin
j := c^.sub.copy.get;
{NEEDBITS(j);}
while (k < j) do
begin
{NEEDBYTE;}
if (n <> 0) then
r :=Z_OK
else
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_codes := inflate_flush(s,z,r);
exit;
end;
Dec(n);
b := b or (uLong(p^) shl k);
Inc(p);
Inc(k, 8);
end;
Inc(c^.len, uInt(b and inflate_mask[j]));
{DUMPBITS(j);}
b := b shr j;
Dec(k, j);
c^.sub.code.need := c^.dbits;
c^.sub.code.tree := c^.dtree;
{$IFDEF INFCODES_DEBUG}
Tracevv('inflate: length '+IntToStr(c^.len));
{$ENDIF}
c^.mode := DIST;
{ falltrough }
end;
DIST: { i: get distance next }
begin
j := c^.sub.code.need;
{NEEDBITS(j);}
while (k < j) do
begin
{NEEDBYTE;}
if (n <> 0) then
r :=Z_OK
else
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_codes := inflate_flush(s,z,r);
exit;
end;
Dec(n);
b := b or (uLong(p^) shl k);
Inc(p);
Inc(k, 8);
end;
t := @huft_ptr(c^.sub.code.tree)^[uInt(b) and inflate_mask[j]];
{DUMPBITS(t^.bits);}
b := b shr t^.bits;
Dec(k, t^.bits);
e := uInt(t^.exop);
if (e and 16 <> 0) then { distance }
begin
c^.sub.copy.get := e and 15;
c^.sub.copy.dist := t^.base;
c^.mode := DISTEXT;
continue; { break C-switch statement }
end;
if (e and 64 = 0) then { next table }
begin
c^.sub.code.need := e;
c^.sub.code.tree := @huft_ptr(t)^[t^.base];
continue; { break C-switch statement }
end;
c^.mode := BADCODE; { invalid code }
z.msg := 'invalid distance code';
r := Z_DATA_ERROR;
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_codes := inflate_flush(s,z,r);
exit;
end;
DISTEXT: { i: getting distance extra }
begin
j := c^.sub.copy.get;
{NEEDBITS(j);}
while (k < j) do
begin
{NEEDBYTE;}
if (n <> 0) then
r :=Z_OK
else
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_codes := inflate_flush(s,z,r);
exit;
end;
Dec(n);
b := b or (uLong(p^) shl k);
Inc(p);
Inc(k, 8);
end;
Inc(c^.sub.copy.dist, uInt(b) and inflate_mask[j]);
{DUMPBITS(j);}
b := b shr j;
Dec(k, j);
{$IFDEF INFCODES_DEBUG}
Tracevv('inflate: distance '+ IntToStr(c^.sub.copy.dist));
{$ENDIF}
c^.mode := COPY;
{ falltrough }
end;
COPY: { o: copying bytes in window, waiting for space }
begin
f := q;
Dec(f, c^.sub.copy.dist);
if (uInt(ptr2int(q) - ptr2int(s.window)) < c^.sub.copy.dist) then
begin
f := s.zend;
Dec(f, c^.sub.copy.dist - uInt(ptr2int(q) - ptr2int(s.window)));
end;
while (c^.len <> 0) do
begin
{NEEDOUT}
if (m = 0) then
begin
{WRAP}
if (q = s.zend) and (s.read <> s.window) then
begin
q := s.window;
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
end;
if (m = 0) then
begin
{FLUSH}
s.write := q;
r := inflate_flush(s,z,r);
q := s.write;
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
{WRAP}
if (q = s.zend) and (s.read <> s.window) then
begin
q := s.window;
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
end;
if (m = 0) then
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_codes := inflate_flush(s,z,r);
exit;
end;
end;
end;
r := Z_OK;
{OUTBYTE( *f++)}
q^ := f^;
Inc(q);
Inc(f);
Dec(m);
if (f = s.zend) then
f := s.window;
Dec(c^.len);
end;
c^.mode := START;
{ C-switch break; not needed }
end;
LIT: { o: got literal, waiting for output space }
begin
{NEEDOUT}
if (m = 0) then
begin
{WRAP}
if (q = s.zend) and (s.read <> s.window) then
begin
q := s.window;
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
end;
if (m = 0) then
begin
{FLUSH}
s.write := q;
r := inflate_flush(s,z,r);
q := s.write;
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
{WRAP}
if (q = s.zend) and (s.read <> s.window) then
begin
q := s.window;
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
end;
if (m = 0) then
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_codes := inflate_flush(s,z,r);
exit;
end;
end;
end;
r := Z_OK;
{OUTBYTE(c^.sub.lit);}
q^ := c^.sub.lit;
Inc(q);
Dec(m);
c^.mode := START;
{break;}
end;
WASH: { o: got eob, possibly more output }
begin
{$ifdef patch112}
if (k > 7) then { return unused byte, if any }
begin
{$IFDEF INFCODES_DEBUG}
Assert(k < 16, 'inflate_codes grabbed too many bytes');
{$ENDIF}
Dec(k, 8);
Inc(n);
Dec(p); { can always return one }
end;
{$endif}
{FLUSH}
s.write := q;
r := inflate_flush(s,z,r);
q := s.write;
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
if (s.read <> s.write) then
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_codes := inflate_flush(s,z,r);
exit;
end;
c^.mode := ZEND;
{ falltrough }
end;
ZEND:
begin
r := Z_STREAM_END;
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_codes := inflate_flush(s,z,r);
exit;
end;
BADCODE: { x: got error }
begin
r := Z_DATA_ERROR;
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_codes := inflate_flush(s,z,r);
exit;
end;
else
begin
r := Z_STREAM_ERROR;
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_codes := inflate_flush(s,z,r);
exit;
end;
end;
{NEED_DUMMY_RETURN - Delphi2+ dumb compilers complain without this }
inflate_codes := Z_STREAM_ERROR;
end;
procedure inflate_codes_free(c : pInflate_codes_state;
var z : z_stream);
begin
ZFREE(z, c);
{$IFDEF INFCODES_DEBUG}
Tracev('inflate: codes free');
{$ENDIF}
end;
end.

319
contrib/fundamentals/ZLib/paszlib/InfFast.pas Normal file
View File

@@ -0,0 +1,319 @@
Unit InfFast;
{
inffast.h and
inffast.c -- process literals and length/distance pairs fast
Copyright (C) 1995-1998 Mark Adler
Pascal tranlastion
Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
Modifiied 02/2003 by Sergey A. Galin for Delphi 6+ and Kylix compatibility.
See README in directory above for more information.
}
interface
{$I zconf.inc}
{.DEFINE INFFAST_DEBUG}
uses zutil, gzlib;
function inflate_fast( bl : uInt;
bd : uInt;
tl : pInflate_huft;
td : pInflate_huft;
var s : inflate_blocks_state;
var z : z_stream) : int;
implementation
uses
infutil;
{ Called with number of bytes left to write in window at least 258
(the maximum string length) and number of input bytes available
at least ten. The ten bytes are six bytes for the longest length/
distance pair plus four bytes for overloading the bit buffer. }
function inflate_fast( bl : uInt;
bd : uInt;
tl : pInflate_huft;
td : pInflate_huft;
var s : inflate_blocks_state;
var z : z_stream) : int;
var
t : pInflate_huft; { temporary pointer }
e : uInt; { extra bits or operation }
b : uLong; { bit buffer }
k : uInt; { bits in bit buffer }
p : pBytef; { input data pointer }
n : uInt; { bytes available there }
q : pBytef; { output window write pointer }
m : uInt; { bytes to end of window or read pointer }
ml : uInt; { mask for literal/length tree }
md : uInt; { mask for distance tree }
c : uInt; { bytes to copy }
d : uInt; { distance back to copy from }
r : pBytef; { copy source pointer }
begin
{ load input, output, bit values (macro LOAD) }
p := z.next_in;
n := z.avail_in;
b := s.bitb;
k := s.bitk;
q := s.write;
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
{ initialize masks }
ml := inflate_mask[bl];
md := inflate_mask[bd];
{ do until not enough input or output space for fast loop }
repeat { assume called with (m >= 258) and (n >= 10) }
{ get literal/length code }
{GRABBITS(20);} { max bits for literal/length code }
while (k < 20) do
begin
Dec(n);
b := b or (uLong(p^) shl k);
Inc(p);
Inc(k, 8);
end;
t := @(huft_ptr(tl)^[uInt(b) and ml]);
e := t^.exop;
if (e = 0) then
begin
{DUMPBITS(t^.bits);}
b := b shr t^.bits;
Dec(k, t^.bits);
{$IFDEF INFFAST_DEBUG}
if (t^.base >= $20) and (t^.base < $7f) then
Tracevv('inflate: * literal '+char(t^.base))
else
Tracevv('inflate: * literal '+ IntToStr(t^.base));
{$ENDIF}
q^ := Byte(t^.base);
Inc(q);
Dec(m);
continue;
end;
repeat
{DUMPBITS(t^.bits);}
b := b shr t^.bits;
Dec(k, t^.bits);
if (e and 16 <> 0) then
begin
{ get extra bits for length }
e := e and 15;
c := t^.base + (uInt(b) and inflate_mask[e]);
{DUMPBITS(e);}
b := b shr e;
Dec(k, e);
{$IFDEF INFFAST_DEBUG}
Tracevv('inflate: * length ' + IntToStr(c));
{$ENDIF}
{ decode distance base of block to copy }
{GRABBITS(15);} { max bits for distance code }
while (k < 15) do
begin
Dec(n);
b := b or (uLong(p^) shl k);
Inc(p);
Inc(k, 8);
end;
t := @huft_ptr(td)^[uInt(b) and md];
e := t^.exop;
repeat
{DUMPBITS(t^.bits);}
b := b shr t^.bits;
Dec(k, t^.bits);
if (e and 16 <> 0) then
begin
{ get extra bits to add to distance base }
e := e and 15;
{GRABBITS(e);} { get extra bits (up to 13) }
while (k < e) do
begin
Dec(n);
b := b or (uLong(p^) shl k);
Inc(p);
Inc(k, 8);
end;
d := t^.base + (uInt(b) and inflate_mask[e]);
{DUMPBITS(e);}
b := b shr e;
Dec(k, e);
{$IFDEF INFFAST_DEBUG}
Tracevv('inflate: * distance '+IntToStr(d));
{$ENDIF}
{ do the copy }
Dec(m, c);
if (uInt(ptr2int(q) - ptr2int(s.window)) >= d) then { offset before dest }
begin { just copy }
r := q;
Dec(r, d);
q^ := r^; Inc(q); Inc(r); Dec(c); { minimum count is three, }
q^ := r^; Inc(q); Inc(r); Dec(c); { so unroll loop a little }
end
else { else offset after destination }
begin
e := d - uInt(ptr2int(q) - ptr2int(s.window)); { bytes from offset to end }
r := s.zend;
Dec(r, e); { pointer to offset }
if (c > e) then { if source crosses, }
begin
Dec(c, e); { copy to end of window }
repeat
q^ := r^;
Inc(q);
Inc(r);
Dec(e);
until (e=0);
r := s.window; { copy rest from start of window }
end;
end;
repeat { copy all or what's left }
q^ := r^;
Inc(q);
Inc(r);
Dec(c);
until (c = 0);
break;
end
else
if (e and 64 = 0) then
begin
Inc(t, t^.base + (uInt(b) and inflate_mask[e]));
e := t^.exop;
end
else
begin
z.msg := 'invalid distance code';
{UNGRAB}
c := z.avail_in-n;
if (k shr 3) < c then
c := k shr 3;
Inc(n, c);
Dec(p, c);
Dec(k, c shl 3);
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_fast := Z_DATA_ERROR;
exit;
end;
until FALSE;
break;
end;
if (e and 64 = 0) then
begin
{t += t->base;
e = (t += ((uInt)b & inflate_mask[e]))->exop;}
Inc(t, t^.base + (uInt(b) and inflate_mask[e]));
e := t^.exop;
if (e = 0) then
begin
{DUMPBITS(t^.bits);}
b := b shr t^.bits;
Dec(k, t^.bits);
{$IFDEF INFFAST_DEBUG}
if (t^.base >= $20) and (t^.base < $7f) then
Tracevv('inflate: * literal '+char(t^.base))
else
Tracevv('inflate: * literal '+IntToStr(t^.base));
{$ENDIF}
q^ := Byte(t^.base);
Inc(q);
Dec(m);
break;
end;
end
else
if (e and 32 <> 0) then
begin
{$IFDEF INFFAST_DEBUG}
Tracevv('inflate: * end of block');
{$ENDIF}
{UNGRAB}
c := z.avail_in-n;
if (k shr 3) < c then
c := k shr 3;
Inc(n, c);
Dec(p, c);
Dec(k, c shl 3);
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_fast := Z_STREAM_END;
exit;
end
else
begin
z.msg := 'invalid literal/length code';
{UNGRAB}
c := z.avail_in-n;
if (k shr 3) < c then
c := k shr 3;
Inc(n, c);
Dec(p, c);
Dec(k, c shl 3);
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_fast := Z_DATA_ERROR;
exit;
end;
until FALSE;
until (m < 258) or (n < 10);
{ not enough input or output--restore pointers and return }
{UNGRAB}
c := z.avail_in-n;
if (k shr 3) < c then
c := k shr 3;
Inc(n, c);
Dec(p, c);
Dec(k, c shl 3);
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_fast := Z_OK;
end;
end.

784
contrib/fundamentals/ZLib/paszlib/InfTrees.pas Normal file
View File

@@ -0,0 +1,784 @@
Unit InfTrees;
{ inftrees.h -- header to use inftrees.c
inftrees.c -- generate Huffman trees for efficient decoding
Copyright (C) 1995-1998 Mark Adler
WARNING: this file should *not* be used by applications. It is
part of the implementation of the compression library and is
subject to change.
Pascal tranlastion
Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
Modifiied 02/2003 by Sergey A. Galin for Delphi 6+ and Kylix compatibility.
See README in directory above for more information.
}
Interface
{$I zconf.inc}
uses
zutil, gzlib;
{ Maximum size of dynamic tree. The maximum found in a long but non-
exhaustive search was 1004 huft structures (850 for length/literals
and 154 for distances, the latter actually the result of an
exhaustive search). The actual maximum is not known, but the
value below is more than safe. }
const
MANY = 1440;
{$ifdef DEBUG}
var
inflate_hufts : uInt;
{$endif}
function inflate_trees_bits(
var c : array of uIntf; { 19 code lengths }
var bb : uIntf; { bits tree desired/actual depth }
var tb : pinflate_huft; { bits tree result }
var hp : array of Inflate_huft; { space for trees }
var z : z_stream { for messages }
) : int;
function inflate_trees_dynamic(
nl : uInt; { number of literal/length codes }
nd : uInt; { number of distance codes }
var c : Array of uIntf; { that many (total) code lengths }
var bl : uIntf; { literal desired/actual bit depth }
var bd : uIntf; { distance desired/actual bit depth }
var tl : pInflate_huft; { literal/length tree result }
var td : pInflate_huft; { distance tree result }
var hp : array of Inflate_huft; { space for trees }
var z : z_stream { for messages }
) : int;
function inflate_trees_fixed (
var bl : uInt; { literal desired/actual bit depth }
var bd : uInt; { distance desired/actual bit depth }
var tl : pInflate_huft; { literal/length tree result }
var td : pInflate_huft; { distance tree result }
var z : z_stream { for memory allocation }
) : int;
implementation
const
inflate_copyright = 'inflate 1.1.2 Copyright 1995-1998 Mark Adler';
{
If you use the zlib library in a product, an acknowledgment is welcome
in the documentation of your product. If for some reason you cannot
include such an acknowledgment, I would appreciate that you keep this
copyright string in the executable of your product.
}
const
{ Tables for deflate from PKZIP's appnote.txt. }
cplens : Array [0..30] Of uInt { Copy lengths for literal codes 257..285 }
= (3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 15, 17, 19, 23, 27, 31,
35, 43, 51, 59, 67, 83, 99, 115, 131, 163, 195, 227, 258, 0, 0);
{ actually lengths - 2; also see note #13 above about 258 }
invalid_code = 112;
cplext : Array [0..30] Of uInt { Extra bits for literal codes 257..285 }
= (0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 2, 2, 2, 2,
3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 5, 5, 0, invalid_code, invalid_code);
cpdist : Array [0..29] Of uInt { Copy offsets for distance codes 0..29 }
= (1, 2, 3, 4, 5, 7, 9, 13, 17, 25, 33, 49, 65, 97, 129, 193,
257, 385, 513, 769, 1025, 1537, 2049, 3073, 4097, 6145,
8193, 12289, 16385, 24577);
cpdext : Array [0..29] Of uInt { Extra bits for distance codes }
= (0, 0, 0, 0, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6,
7, 7, 8, 8, 9, 9, 10, 10, 11, 11,
12, 12, 13, 13);
{ Huffman code decoding is performed using a multi-level table lookup.
The fastest way to decode is to simply build a lookup table whose
size is determined by the longest code. However, the time it takes
to build this table can also be a factor if the data being decoded
is not very long. The most common codes are necessarily the
shortest codes, so those codes dominate the decoding time, and hence
the speed. The idea is you can have a shorter table that decodes the
shorter, more probable codes, and then point to subsidiary tables for
the longer codes. The time it costs to decode the longer codes is
then traded against the time it takes to make longer tables.
This results of this trade are in the variables lbits and dbits
below. lbits is the number of bits the first level table for literal/
length codes can decode in one step, and dbits is the same thing for
the distance codes. Subsequent tables are also less than or equal to
those sizes. These values may be adjusted either when all of the
codes are shorter than that, in which case the longest code length in
bits is used, or when the shortest code is *longer* than the requested
table size, in which case the length of the shortest code in bits is
used.
There are two different values for the two tables, since they code a
different number of possibilities each. The literal/length table
codes 286 possible values, or in a flat code, a little over eight
bits. The distance table codes 30 possible values, or a little less
than five bits, flat. The optimum values for speed end up being
about one bit more than those, so lbits is 8+1 and dbits is 5+1.
The optimum values may differ though from machine to machine, and
possibly even between compilers. Your mileage may vary. }
{ If BMAX needs to be larger than 16, then h and x[] should be uLong. }
const
BMAX = 15; { maximum bit length of any code }
{$DEFINE USE_PTR}
function huft_build(
var b : array of uIntf; { code lengths in bits (all assumed <= BMAX) }
n : uInt; { number of codes (assumed <= N_MAX) }
s : uInt; { number of simple-valued codes (0..s-1) }
const d : array of uIntf; { list of base values for non-simple codes }
{ array of word }
const e : array of uIntf; { list of extra bits for non-simple codes }
{ array of byte }
t : ppInflate_huft; { result: starting table }
var m : uIntf; { maximum lookup bits, returns actual }
var hp : array of inflate_huft; { space for trees }
var hn : uInt; { hufts used in space }
var v : array of uIntf { working area: values in order of bit length }
) : int;
{ Given a list of code lengths and a maximum table size, make a set of
tables to decode that set of codes. Return Z_OK on success, Z_BUF_ERROR
if the given code set is incomplete (the tables are still built in this
case), Z_DATA_ERROR if the input is invalid (an over-subscribed set of
lengths), or Z_MEM_ERROR if not enough memory. }
Var
a : uInt; { counter for codes of length k }
c : Array [0..BMAX] Of uInt; { bit length count table }
f : uInt; { i repeats in table every f entries }
g : int; { maximum code length }
h : int; { table level }
i : uInt; {register} { counter, current code }
j : uInt; {register} { counter }
k : Int; {register} { number of bits in current code }
l : int; { bits per table (returned in m) }
mask : uInt; { (1 shl w) - 1, to avoid cc -O bug on HP }
p : ^uIntf; {register} { pointer into c[], b[], or v[] }
q : pInflate_huft; { points to current table }
r : inflate_huft; { table entry for structure assignment }
u : Array [0..BMAX-1] Of pInflate_huft; { table stack }
w : int; {register} { bits before this table = (l*h) }
x : Array [0..BMAX] Of uInt; { bit offsets, then code stack }
{$IFDEF USE_PTR}
xp : puIntf; { pointer into x }
{$ELSE}
xp : uInt;
{$ENDIF}
y : int; { number of dummy codes added }
z : uInt; { number of entries in current table }
Begin
{ Generate counts for each bit length }
FillChar(c,SizeOf(c),0) ; { clear c[] }
for i := 0 to n-1 do
Inc (c[b[i]]); { assume all entries <= BMAX }
If (c[0] = n) Then { null input--all zero length codes }
Begin
t^ := pInflate_huft(NIL);
m := 0 ;
huft_build := Z_OK ;
Exit;
End ;
{ Find minimum and maximum length, bound [m] by those }
l := m;
for j:=1 To BMAX do
if (c[j] <> 0) then
break;
k := j ; { minimum code length }
if (uInt(l) < j) then
l := j;
for i := BMAX downto 1 do
if (c[i] <> 0) then
break ;
g := i ; { maximum code length }
if (uInt(l) > i) then
l := i;
m := l;
{ Adjust last length count to fill out codes, if needed }
y := 1 shl j ;
while (j < i) do
begin
Dec(y, c[j]) ;
if (y < 0) then
begin
huft_build := Z_DATA_ERROR; { bad input: more codes than bits }
exit;
end ;
Inc(j) ;
y := y shl 1
end;
Dec (y, c[i]) ;
if (y < 0) then
begin
huft_build := Z_DATA_ERROR; { bad input: more codes than bits }
exit;
end;
Inc(c[i], y);
{ Generate starting offsets into the value table FOR each length }
{$IFDEF USE_PTR}
x[1] := 0;
j := 0;
p := @c[1];
xp := @x[2];
dec(i); { note that i = g from above }
WHILE (i > 0) DO
BEGIN
inc(j, p^);
xp^ := j;
inc(p);
inc(xp);
dec(i);
END;
{$ELSE}
x[1] := 0;
j := 0 ;
for i := 1 to g do
begin
x[i] := j;
Inc(j, c[i]);
end;
{$ENDIF}
{ Make a table of values in order of bit lengths }
for i := 0 to n-1 do
begin
j := b[i];
if (j <> 0) then
begin
v[ x[j] ] := i;
Inc(x[j]);
end;
end;
n := x[g]; { set n to length of v }
{ Generate the Huffman codes and for each, make the table entries }
i := 0 ;
x[0] := 0 ; { first Huffman code is zero }
p := Addr(v) ; { grab values in bit order }
h := -1 ; { no tables yet--level -1 }
w := -l ; { bits decoded = (l*h) }
u[0] := pInflate_huft(NIL); { just to keep compilers happy }
q := pInflate_huft(NIL); { ditto }
z := 0 ; { ditto }
{ go through the bit lengths (k already is bits in shortest code) }
while (k <= g) Do
begin
a := c[k] ;
while (a<>0) Do
begin
Dec (a) ;
{ here i is the Huffman code of length k bits for value p^ }
{ make tables up to required level }
while (k > w + l) do
begin
Inc (h) ;
Inc (w, l); { add bits already decoded }
{ previous table always l bits }
{ compute minimum size table less than or equal to l bits }
{ table size upper limit }
z := g - w;
If (z > uInt(l)) Then
z := l;
{ try a k-w bit table }
j := k - w;
f := 1 shl j;
if (f > a+1) Then { too few codes for k-w bit table }
begin
Dec(f, a+1); { deduct codes from patterns left }
{$IFDEF USE_PTR}
xp := Addr(c[k]);
if (j < z) then
begin
Inc(j);
while (j < z) do
begin { try smaller tables up to z bits }
f := f shl 1;
Inc (xp) ;
If (f <= xp^) Then
break; { enough codes to use up j bits }
Dec(f, xp^); { else deduct codes from patterns }
Inc(j);
end;
end;
{$ELSE}
xp := k;
if (j < z) then
begin
Inc (j) ;
While (j < z) Do
begin { try smaller tables up to z bits }
f := f * 2;
Inc (xp) ;
if (f <= c[xp]) then
Break ; { enough codes to use up j bits }
Dec (f, c[xp]) ; { else deduct codes from patterns }
Inc (j);
end;
end;
{$ENDIF}
end;
z := 1 shl j; { table entries for j-bit table }
{ allocate new table }
if (hn + z > MANY) then { (note: doesn't matter for fixed) }
begin
huft_build := Z_MEM_ERROR; { not enough memory }
exit;
end;
q := @hp[hn];
u[h] := q;
Inc(hn, z);
{ connect to last table, if there is one }
if (h <> 0) then
begin
x[h] := i; { save pattern for backing up }
r.bits := Byte(l); { bits to dump before this table }
r.exop := Byte(j); { bits in this table }
j := i shr (w - l);
{r.base := uInt( q - u[h-1] -j);} { offset to this table }
r.base := (ptr2int(q) - ptr2int(u[h-1]) ) div sizeof(q^) - j;
huft_Ptr(u[h-1])^[j] := r; { connect to last table }
end
else
t^ := q; { first table is returned result }
end;
{ set up table entry in r }
r.bits := Byte(k - w);
{ C-code: if (p >= v + n) - see ZUTIL.PAS for comments }
if ptr2int(p)>=ptr2int(@(v[n])) then { also works under DPMI ?? }
r.exop := 128 + 64 { out of values--invalid code }
else
if (p^ < s) then
begin
if (p^ < 256) then { 256 is end-of-block code }
r.exop := 0
Else
r.exop := 32 + 64; { EOB_code; }
r.base := p^; { simple code is just the value }
Inc(p);
end
Else
begin
r.exop := Byte(e[p^-s] + 16 + 64); { non-simple--look up in lists }
r.base := d[p^-s];
Inc (p);
end ;
{ fill code-like entries with r }
f := 1 shl (k - w);
j := i shr w;
while (j < z) do
begin
huft_Ptr(q)^[j] := r;
Inc(j, f);
end;
{ backwards increment the k-bit code i }
j := 1 shl (k-1) ;
while (i and j) <> 0 do
begin
i := i xor j; { bitwise exclusive or }
j := j shr 1
end ;
i := i xor j;
{ backup over finished tables }
mask := (1 shl w) - 1; { needed on HP, cc -O bug }
while ((i and mask) <> x[h]) do
begin
Dec(h); { don't need to update q }
Dec(w, l);
mask := (1 shl w) - 1;
end;
end;
Inc(k);
end;
{ Return Z_BUF_ERROR if we were given an incomplete table }
if (y <> 0) And (g <> 1) then
huft_build := Z_BUF_ERROR
else
huft_build := Z_OK;
end; { huft_build}
function inflate_trees_bits(
var c : array of uIntf; { 19 code lengths }
var bb : uIntf; { bits tree desired/actual depth }
var tb : pinflate_huft; { bits tree result }
var hp : array of Inflate_huft; { space for trees }
var z : z_stream { for messages }
) : int;
var
r : int;
hn : uInt; { hufts used in space }
v : PuIntArray; { work area for huft_build }
begin
hn := 0;
v := PuIntArray( ZALLOC(z, 19, sizeof(uInt)) );
if (v = Z_NULL) then
begin
inflate_trees_bits := Z_MEM_ERROR;
exit;
end;
r := huft_build(c, 19, 19, cplens, cplext,
{puIntf(Z_NULL), puIntf(Z_NULL),}
@tb, bb, hp, hn, v^);
if (r = Z_DATA_ERROR) then
z.msg := 'oversubscribed dynamic bit lengths tree'
else
if (r = Z_BUF_ERROR) or (bb = 0) then
begin
z.msg := 'incomplete dynamic bit lengths tree';
r := Z_DATA_ERROR;
end;
ZFREE(z, v);
inflate_trees_bits := r;
end;
function inflate_trees_dynamic(
nl : uInt; { number of literal/length codes }
nd : uInt; { number of distance codes }
var c : Array of uIntf; { that many (total) code lengths }
var bl : uIntf; { literal desired/actual bit depth }
var bd : uIntf; { distance desired/actual bit depth }
var tl : pInflate_huft; { literal/length tree result }
var td : pInflate_huft; { distance tree result }
var hp : array of Inflate_huft; { space for trees }
var z : z_stream { for messages }
) : int;
var
r : int;
hn : uInt; { hufts used in space }
v : PuIntArray; { work area for huft_build }
begin
hn := 0;
{ allocate work area }
v := PuIntArray( ZALLOC(z, 288, sizeof(uInt)) );
if (v = Z_NULL) then
begin
inflate_trees_dynamic := Z_MEM_ERROR;
exit;
end;
{ build literal/length tree }
r := huft_build(c, nl, 257, cplens, cplext, @tl, bl, hp, hn, v^);
if (r <> Z_OK) or (bl = 0) then
begin
if (r = Z_DATA_ERROR) then
z.msg := 'oversubscribed literal/length tree'
else
if (r <> Z_MEM_ERROR) then
begin
z.msg := 'incomplete literal/length tree';
r := Z_DATA_ERROR;
end;
ZFREE(z, v);
inflate_trees_dynamic := r;
exit;
end;
{ build distance tree }
r := huft_build(puIntArray(@c[nl])^, nd, 0,
cpdist, cpdext, @td, bd, hp, hn, v^);
if (r <> Z_OK) or ((bd = 0) and (nl > 257)) then
begin
if (r = Z_DATA_ERROR) then
z.msg := 'oversubscribed literal/length tree'
else
if (r = Z_BUF_ERROR) then
begin
{$ifdef PKZIP_BUG_WORKAROUND}
r := Z_OK;
end;
{$else}
z.msg := 'incomplete literal/length tree';
r := Z_DATA_ERROR;
end
else
if (r <> Z_MEM_ERROR) then
begin
z.msg := 'empty distance tree with lengths';
r := Z_DATA_ERROR;
end;
ZFREE(z, v);
inflate_trees_dynamic := r;
exit;
{$endif}
end;
{ done }
ZFREE(z, v);
inflate_trees_dynamic := Z_OK;
end;
{$UNDEF BUILDFIXED}
{ build fixed tables only once--keep them here }
{$IFNDEF BUILDFIXED}
{ locals }
var
fixed_built : Boolean = false;
const
FIXEDH = 544; { number of hufts used by fixed tables }
var
fixed_mem : array[0..FIXEDH-1] of inflate_huft;
fixed_bl : uInt;
fixed_bd : uInt;
fixed_tl : pInflate_huft;
fixed_td : pInflate_huft;
{$ELSE}
{ inffixed.h -- table for decoding fixed codes }
{local}
const
fixed_bl = uInt(9);
{local}
const
fixed_bd = uInt(5);
{local}
const
fixed_tl : array [0..288-1] of inflate_huft = (
Exop, { number of extra bits or operation }
bits : Byte; { number of bits in this code or subcode }
{pad : uInt;} { pad structure to a power of 2 (4 bytes for }
{ 16-bit, 8 bytes for 32-bit int's) }
base : uInt; { literal, length base, or distance base }
{ or table offset }
((96,7),256), ((0,8),80), ((0,8),16), ((84,8),115), ((82,7),31),
((0,8),112), ((0,8),48), ((0,9),192), ((80,7),10), ((0,8),96),
((0,8),32), ((0,9),160), ((0,8),0), ((0,8),128), ((0,8),64),
((0,9),224), ((80,7),6), ((0,8),88), ((0,8),24), ((0,9),144),
((83,7),59), ((0,8),120), ((0,8),56), ((0,9),208), ((81,7),17),
((0,8),104), ((0,8),40), ((0,9),176), ((0,8),8), ((0,8),136),
((0,8),72), ((0,9),240), ((80,7),4), ((0,8),84), ((0,8),20),
((85,8),227), ((83,7),43), ((0,8),116), ((0,8),52), ((0,9),200),
((81,7),13), ((0,8),100), ((0,8),36), ((0,9),168), ((0,8),4),
((0,8),132), ((0,8),68), ((0,9),232), ((80,7),8), ((0,8),92),
((0,8),28), ((0,9),152), ((84,7),83), ((0,8),124), ((0,8),60),
((0,9),216), ((82,7),23), ((0,8),108), ((0,8),44), ((0,9),184),
((0,8),12), ((0,8),140), ((0,8),76), ((0,9),248), ((80,7),3),
((0,8),82), ((0,8),18), ((85,8),163), ((83,7),35), ((0,8),114),
((0,8),50), ((0,9),196), ((81,7),11), ((0,8),98), ((0,8),34),
((0,9),164), ((0,8),2), ((0,8),130), ((0,8),66), ((0,9),228),
((80,7),7), ((0,8),90), ((0,8),26), ((0,9),148), ((84,7),67),
((0,8),122), ((0,8),58), ((0,9),212), ((82,7),19), ((0,8),106),
((0,8),42), ((0,9),180), ((0,8),10), ((0,8),138), ((0,8),74),
((0,9),244), ((80,7),5), ((0,8),86), ((0,8),22), ((192,8),0),
((83,7),51), ((0,8),118), ((0,8),54), ((0,9),204), ((81,7),15),
((0,8),102), ((0,8),38), ((0,9),172), ((0,8),6), ((0,8),134),
((0,8),70), ((0,9),236), ((80,7),9), ((0,8),94), ((0,8),30),
((0,9),156), ((84,7),99), ((0,8),126), ((0,8),62), ((0,9),220),
((82,7),27), ((0,8),110), ((0,8),46), ((0,9),188), ((0,8),14),
((0,8),142), ((0,8),78), ((0,9),252), ((96,7),256), ((0,8),81),
((0,8),17), ((85,8),131), ((82,7),31), ((0,8),113), ((0,8),49),
((0,9),194), ((80,7),10), ((0,8),97), ((0,8),33), ((0,9),162),
((0,8),1), ((0,8),129), ((0,8),65), ((0,9),226), ((80,7),6),
((0,8),89), ((0,8),25), ((0,9),146), ((83,7),59), ((0,8),121),
((0,8),57), ((0,9),210), ((81,7),17), ((0,8),105), ((0,8),41),
((0,9),178), ((0,8),9), ((0,8),137), ((0,8),73), ((0,9),242),
((80,7),4), ((0,8),85), ((0,8),21), ((80,8),258), ((83,7),43),
((0,8),117), ((0,8),53), ((0,9),202), ((81,7),13), ((0,8),101),
((0,8),37), ((0,9),170), ((0,8),5), ((0,8),133), ((0,8),69),
((0,9),234), ((80,7),8), ((0,8),93), ((0,8),29), ((0,9),154),
((84,7),83), ((0,8),125), ((0,8),61), ((0,9),218), ((82,7),23),
((0,8),109), ((0,8),45), ((0,9),186), ((0,8),13), ((0,8),141),
((0,8),77), ((0,9),250), ((80,7),3), ((0,8),83), ((0,8),19),
((85,8),195), ((83,7),35), ((0,8),115), ((0,8),51), ((0,9),198),
((81,7),11), ((0,8),99), ((0,8),35), ((0,9),166), ((0,8),3),
((0,8),131), ((0,8),67), ((0,9),230), ((80,7),7), ((0,8),91),
((0,8),27), ((0,9),150), ((84,7),67), ((0,8),123), ((0,8),59),
((0,9),214), ((82,7),19), ((0,8),107), ((0,8),43), ((0,9),182),
((0,8),11), ((0,8),139), ((0,8),75), ((0,9),246), ((80,7),5),
((0,8),87), ((0,8),23), ((192,8),0), ((83,7),51), ((0,8),119),
((0,8),55), ((0,9),206), ((81,7),15), ((0,8),103), ((0,8),39),
((0,9),174), ((0,8),7), ((0,8),135), ((0,8),71), ((0,9),238),
((80,7),9), ((0,8),95), ((0,8),31), ((0,9),158), ((84,7),99),
((0,8),127), ((0,8),63), ((0,9),222), ((82,7),27), ((0,8),111),
((0,8),47), ((0,9),190), ((0,8),15), ((0,8),143), ((0,8),79),
((0,9),254), ((96,7),256), ((0,8),80), ((0,8),16), ((84,8),115),
((82,7),31), ((0,8),112), ((0,8),48), ((0,9),193), ((80,7),10),
((0,8),96), ((0,8),32), ((0,9),161), ((0,8),0), ((0,8),128),
((0,8),64), ((0,9),225), ((80,7),6), ((0,8),88), ((0,8),24),
((0,9),145), ((83,7),59), ((0,8),120), ((0,8),56), ((0,9),209),
((81,7),17), ((0,8),104), ((0,8),40), ((0,9),177), ((0,8),8),
((0,8),136), ((0,8),72), ((0,9),241), ((80,7),4), ((0,8),84),
((0,8),20), ((85,8),227), ((83,7),43), ((0,8),116), ((0,8),52),
((0,9),201), ((81,7),13), ((0,8),100), ((0,8),36), ((0,9),169),
((0,8),4), ((0,8),132), ((0,8),68), ((0,9),233), ((80,7),8),
((0,8),92), ((0,8),28), ((0,9),153), ((84,7),83), ((0,8),124),
((0,8),60), ((0,9),217), ((82,7),23), ((0,8),108), ((0,8),44),
((0,9),185), ((0,8),12), ((0,8),140), ((0,8),76), ((0,9),249),
((80,7),3), ((0,8),82), ((0,8),18), ((85,8),163), ((83,7),35),
((0,8),114), ((0,8),50), ((0,9),197), ((81,7),11), ((0,8),98),
((0,8),34), ((0,9),165), ((0,8),2), ((0,8),130), ((0,8),66),
((0,9),229), ((80,7),7), ((0,8),90), ((0,8),26), ((0,9),149),
((84,7),67), ((0,8),122), ((0,8),58), ((0,9),213), ((82,7),19),
((0,8),106), ((0,8),42), ((0,9),181), ((0,8),10), ((0,8),138),
((0,8),74), ((0,9),245), ((80,7),5), ((0,8),86), ((0,8),22),
((192,8),0), ((83,7),51), ((0,8),118), ((0,8),54), ((0,9),205),
((81,7),15), ((0,8),102), ((0,8),38), ((0,9),173), ((0,8),6),
((0,8),134), ((0,8),70), ((0,9),237), ((80,7),9), ((0,8),94),
((0,8),30), ((0,9),157), ((84,7),99), ((0,8),126), ((0,8),62),
((0,9),221), ((82,7),27), ((0,8),110), ((0,8),46), ((0,9),189),
((0,8),14), ((0,8),142), ((0,8),78), ((0,9),253), ((96,7),256),
((0,8),81), ((0,8),17), ((85,8),131), ((82,7),31), ((0,8),113),
((0,8),49), ((0,9),195), ((80,7),10), ((0,8),97), ((0,8),33),
((0,9),163), ((0,8),1), ((0,8),129), ((0,8),65), ((0,9),227),
((80,7),6), ((0,8),89), ((0,8),25), ((0,9),147), ((83,7),59),
((0,8),121), ((0,8),57), ((0,9),211), ((81,7),17), ((0,8),105),
((0,8),41), ((0,9),179), ((0,8),9), ((0,8),137), ((0,8),73),
((0,9),243), ((80,7),4), ((0,8),85), ((0,8),21), ((80,8),258),
((83,7),43), ((0,8),117), ((0,8),53), ((0,9),203), ((81,7),13),
((0,8),101), ((0,8),37), ((0,9),171), ((0,8),5), ((0,8),133),
((0,8),69), ((0,9),235), ((80,7),8), ((0,8),93), ((0,8),29),
((0,9),155), ((84,7),83), ((0,8),125), ((0,8),61), ((0,9),219),
((82,7),23), ((0,8),109), ((0,8),45), ((0,9),187), ((0,8),13),
((0,8),141), ((0,8),77), ((0,9),251), ((80,7),3), ((0,8),83),
((0,8),19), ((85,8),195), ((83,7),35), ((0,8),115), ((0,8),51),
((0,9),199), ((81,7),11), ((0,8),99), ((0,8),35), ((0,9),167),
((0,8),3), ((0,8),131), ((0,8),67), ((0,9),231), ((80,7),7),
((0,8),91), ((0,8),27), ((0,9),151), ((84,7),67), ((0,8),123),
((0,8),59), ((0,9),215), ((82,7),19), ((0,8),107), ((0,8),43),
((0,9),183), ((0,8),11), ((0,8),139), ((0,8),75), ((0,9),247),
((80,7),5), ((0,8),87), ((0,8),23), ((192,8),0), ((83,7),51),
((0,8),119), ((0,8),55), ((0,9),207), ((81,7),15), ((0,8),103),
((0,8),39), ((0,9),175), ((0,8),7), ((0,8),135), ((0,8),71),
((0,9),239), ((80,7),9), ((0,8),95), ((0,8),31), ((0,9),159),
((84,7),99), ((0,8),127), ((0,8),63), ((0,9),223), ((82,7),27),
((0,8),111), ((0,8),47), ((0,9),191), ((0,8),15), ((0,8),143),
((0,8),79), ((0,9),255)
);
{local}
const
fixed_td : array[0..32-1] of inflate_huft = (
(Exop:80;bits:5;base:1), (Exop:87;bits:5;base:257), (Exop:83;bits:5;base:17),
(Exop:91;bits:5;base:4097), (Exop:81;bits:5;base), (Exop:89;bits:5;base:1025),
(Exop:85;bits:5;base:65), (Exop:93;bits:5;base:16385), (Exop:80;bits:5;base:3),
(Exop:88;bits:5;base:513), (Exop:84;bits:5;base:33), (Exop:92;bits:5;base:8193),
(Exop:82;bits:5;base:9), (Exop:90;bits:5;base:2049), (Exop:86;bits:5;base:129),
(Exop:192;bits:5;base:24577), (Exop:80;bits:5;base:2), (Exop:87;bits:5;base:385),
(Exop:83;bits:5;base:25), (Exop:91;bits:5;base:6145), (Exop:81;bits:5;base:7),
(Exop:89;bits:5;base:1537), (Exop:85;bits:5;base:97), (Exop:93;bits:5;base:24577),
(Exop:80;bits:5;base:4), (Exop:88;bits:5;base:769), (Exop:84;bits:5;base:49),
(Exop:92;bits:5;base:12289), (Exop:82;bits:5;base:13), (Exop:90;bits:5;base:3073),
(Exop:86;bits:5;base:193), (Exop:192;bits:5;base:24577)
);
{$ENDIF}
function inflate_trees_fixed(
var bl : uInt; { literal desired/actual bit depth }
var bd : uInt; { distance desired/actual bit depth }
var tl : pInflate_huft; { literal/length tree result }
var td : pInflate_huft; { distance tree result }
var z : z_stream { for memory allocation }
) : int;
type
pFixed_table = ^fixed_table;
fixed_table = array[0..288-1] of uIntf;
var
k : int; { temporary variable }
c : pFixed_table; { length list for huft_build }
v : PuIntArray; { work area for huft_build }
var
f : uInt; { number of hufts used in fixed_mem }
begin
{ build fixed tables if not already (multiple overlapped executions ok) }
if not fixed_built then
begin
f := 0;
{ allocate memory }
c := pFixed_table( ZALLOC(z, 288, sizeof(uInt)) );
if (c = Z_NULL) then
begin
inflate_trees_fixed := Z_MEM_ERROR;
exit;
end;
v := PuIntArray( ZALLOC(z, 288, sizeof(uInt)) );
if (v = Z_NULL) then
begin
ZFREE(z, c);
inflate_trees_fixed := Z_MEM_ERROR;
exit;
end;
{ literal table }
for k := 0 to Pred(144) do
c^[k] := 8;
for k := 144 to Pred(256) do
c^[k] := 9;
for k := 256 to Pred(280) do
c^[k] := 7;
for k := 280 to Pred(288) do
c^[k] := 8;
fixed_bl := 9;
huft_build(c^, 288, 257, cplens, cplext, @fixed_tl, fixed_bl,
fixed_mem, f, v^);
{ distance table }
for k := 0 to Pred(30) do
c^[k] := 5;
fixed_bd := 5;
huft_build(c^, 30, 0, cpdist, cpdext, @fixed_td, fixed_bd,
fixed_mem, f, v^);
{ done }
ZFREE(z, v);
ZFREE(z, c);
fixed_built := True;
end;
bl := fixed_bl;
bd := fixed_bd;
tl := fixed_tl;
td := fixed_td;
inflate_trees_fixed := Z_OK;
end; { inflate_trees_fixed }
end.

140
contrib/fundamentals/ZLib/paszlib/README.txt Normal file
View File

@@ -0,0 +1,140 @@
This version of PASZLIB was modified by David J Butler, 04/2015
for inclusion in the Fundamentals Library.
https://github.com/fundamentalslib
_____________________________________________________________________________
This version of PASZLIB was modified by Sergey A. Galin, 02/2003.
See the
README in directory above for details.
_____________________________________________________________________________
PASZLIB 1.0 May 11th, 1998
Based on the zlib 1.1.2, a general purpose data compression library.
Copyright (C) 1998,1999,2000 by NOMSSI NZALI Jacques H. C.
[kn&n DES] See "Legal issues" for conditions of distribution and use.
_____________________________________________________________________________
Introduction
============
The 'zlib' compression library provides in-memory compression and
decompression functions, including integrity checks of the uncompressed
data. This version of the library supports only one compression method
(deflation) but other algorithms will be added later and will have the same
stream interface.
Compression can be done in a single step if the buffers are large
enough (for example if an input file is mmap'ed), or can be done by
repeated calls of the compression function. In the latter case, the
application must provide more input and/or consume the output
(providing more output space) before each call.
The default memory requirements for deflate are 256K plus a few kilobytes
for small objects. The default memory requirements for inflate are 32K
plus a few kilobytes for small objects.
Change Log
==========
March 24th 2000 - minizip code by Gilles Vollant ported to Pascal.
z_stream.msg defined as string[255] to avoid problems
with Delphi 2+ dynamic string handling.
changes to silence Delphi 5 compiler warning. If you
have Delphi 5, defines Delphi5 in zconf.inc
May 7th 1999 - Some changes for FPC
deflateCopy() has new parameters
trees.pas - record constant definition
June 17th 1998 - Applied official 1.1.2 patch.
Memcheck turned off by default.
zutil.pas patch for Delphi 1 memory allocation corrected.
dzlib.txt file added.
compress2() is now exported
June 25th 1998 - fixed a conversion bug: in inftrees.pas, ZFREE(z, v) was
missing in line 574;
File list
=========
Here is a road map to the files in the Paszlib distribution.
readme.txt Introduction, Documentation
dzlib.txt Changes to Delphi sources for Paszlib stream classes
include file
zconf.inc Configuration declarations.
Pascal source code files:
adler.pas compute the Adler-32 checksum of a data stream
crc.pas compute the CRC-32 of a data stream
gzio.pas IO on .gz files
infblock.pas interpret and process block types to last block
infcodes.pas process literals and length/distance pairs
inffast.pas process literals and length/distance pairs fast
inftrees.pas generate Huffman trees for efficient decoding
infutil.pas types and macros common to blocks and codes
strutils.pas string utilities
trees.pas output deflated data using Huffman coding
zcompres.pas compress a memory buffer
zdeflate.pas compress data using the deflation algorithm
zinflate.pas zlib interface to inflate modules
zlib.pas zlib data structures. read the comments there!
zuncompr.pas decompress a memory buffer
zutil.pas
minizip/ziputils.pas data structure and IO on .zip file
minizip/unzip.pas
minizip/zip.pas
Test applications
example.pas usage example of the zlib compression library
minigzip.pas simulate gzip using the zlib compression library
minizip/miniunz.pas simulates unzip using the zlib compression library
minizip/minizip.pas simulates zip using the zlib compression library
Legal issues
============
Copyright (C) 1998,1999,2000 by Jacques Nomssi Nzali
This software is provided 'as-is', without any express or implied
warranty. In no event will the author 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.
Archive Locations:
==================
Check the Paszlib home page with links
http://www.tu-chemnitz.de/~nomssi/paszlib.html
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.
____________________________________________________________________________
Jacques Nomssi Nzali <mailto:nomssi@physik.tu-chemnitz.de> March 24th, 2000

557
contrib/fundamentals/ZLib/paszlib/ZUtil.pas Normal file
View File

@@ -0,0 +1,557 @@
Unit ZUtil;
{
Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
Modifiied 02/2003 by Sergey A. Galin for Delphi 6+ and Kylix compatibility.
See README in directory above for more information.
Modified 04/2015 by David J Butler for additional compilers compatibility.
}
interface
{$I zconf.inc}
{$IFNDEF SupportRawByteString}
type
AnsiChar = Byte;
AnsiString = array of AnsiChar;
RawByteString = AnsiString;
PRawByteString = ^RawByteString;
{$ENDIF}
{$IFNDEF SupportNativeUInt}
type
{$IFDEF CPU_X86_64}
{$IFNDEF SupportUInt64}
UInt64 = type Int64;
Word64 = UInt64;
{$ENDIF}
NativeUInt = type Word64;
{$ELSE}
NativeUInt = type Cardinal;
{$ENDIF}
PNativeUInt = ^NativeUInt;
{$ENDIF}
{$IFDEF FREEPASCAL}
type
PNativeUInt = ^NativeUInt;
{$ENDIF}
{ Type declarations }
type
{Byte = usigned char; 8 bits}
Bytef = byte;
charf = byte;
int = integer;
intf = int;
uInt = cardinal; { 16 bits or more }
uIntf = uInt;
Long = longint;
uLong = Cardinal;
uLongf = uLong;
voidp = pointer;
voidpf = voidp;
pBytef = ^Bytef;
pIntf = ^intf;
puIntf = ^uIntf;
puLong = ^uLongf;
ptr2int = NativeUInt;
{ a pointer to integer casting is used to do pointer arithmetic.
ptr2int must be an integer type and sizeof(ptr2int) must be less
than sizeof(pointer) - Nomssi }
const
{$IFDEF MAXSEG_64K}
MaxMemBlock = $FFFF;
{$ELSE}
MaxMemBlock = MaxInt;
{$ENDIF}
type
zByteArray = array[0..(MaxMemBlock div SizeOf(Bytef))-1] of Bytef;
pzByteArray = ^zByteArray;
type
zIntfArray = array[0..(MaxMemBlock div SizeOf(Intf))-1] of Intf;
pzIntfArray = ^zIntfArray;
type
zuIntArray = array[0..(MaxMemBlock div SizeOf(uInt))-1] of uInt;
PuIntArray = ^zuIntArray;
{ Type declarations - only for deflate }
type
uch = Byte;
uchf = uch; { FAR }
ush = Word;
ushf = ush;
ulg = LongInt;
unsigned = uInt;
pcharf = ^charf;
puchf = ^uchf;
pushf = ^ushf;
type
zuchfArray = zByteArray;
puchfArray = ^zuchfArray;
type
zushfArray = array[0..(MaxMemBlock div SizeOf(ushf))-1] of ushf;
pushfArray = ^zushfArray;
procedure zmemcpy(destp : pBytef; sourcep : pBytef; len : uInt);
function zmemcmp(s1p, s2p : pBytef; len : uInt) : int;
procedure zmemzero(destp : pBytef; len : uInt);
procedure zcfree(opaque : voidpf; ptr : voidpf);
function zcalloc (opaque : voidpf; items : uInt; size : uInt) : voidpf;
implementation
{$ifdef ver80}
{$define Delphi16}
{$endif}
{$ifdef ver70}
{$define HugeMem}
{$endif}
{$ifdef ver60}
{$define HugeMem}
{$endif}
{$IFDEF CALLDOS}
uses
WinDos;
{$ENDIF}
{$IFDEF Delphi16}
uses
WinTypes,
WinProcs;
{$ENDIF}
{$IFNDEF FPC}
{$IFDEF DPMI}
uses
WinAPI;
{$ENDIF}
{$ENDIF}
{$IFDEF CALLDOS}
{ reduce your application memory footprint with $M before using this }
function dosAlloc (Size : Longint) : Pointer;
var
regs: TRegisters;
begin
regs.bx := (Size + 15) div 16; { number of 16-bytes-paragraphs }
regs.ah := $48; { Allocate memory block }
msdos(regs);
if regs.Flags and FCarry <> 0 then
DosAlloc := NIL
else
DosAlloc := Ptr(regs.ax, 0);
end;
function dosFree(P : pointer) : boolean;
var
regs: TRegisters;
begin
dosFree := FALSE;
regs.bx := Seg(P^); { segment }
if Ofs(P) <> 0 then
exit;
regs.ah := $49; { Free memory block }
msdos(regs);
dosFree := (regs.Flags and FCarry = 0);
end;
{$ENDIF}
type
LH = record
L, H : word;
end;
{$IFDEF HugeMem}
{$define HEAP_LIST}
{$endif}
{$IFDEF HEAP_LIST} {--- to avoid Mark and Release --- }
const
MaxAllocEntries = 50;
type
TMemRec = record
orgvalue,
value : pointer;
size: longint;
end;
const
allocatedCount : 0..MaxAllocEntries = 0;
var
allocatedList : array[0..MaxAllocEntries-1] of TMemRec;
function NewAllocation(ptr0, ptr : pointer; memsize : longint) : boolean;
begin
if (allocatedCount < MaxAllocEntries) and (ptr0 <> NIL) then
begin
with allocatedList[allocatedCount] do
begin
orgvalue := ptr0;
value := ptr;
size := memsize;
end;
Inc(allocatedCount); { we don't check for duplicate }
NewAllocation := TRUE;
end
else
NewAllocation := FALSE;
end;
{$ENDIF}
{$IFDEF HugeMem}
{ The code below is extremely version specific to the TP 6/7 heap manager!!}
type
PFreeRec = ^TFreeRec;
TFreeRec = record
next: PFreeRec;
size: Pointer;
end;
type
HugePtr = voidpf;
procedure IncPtr(var p:pointer;count:word);
{ Increments pointer }
begin
inc(LH(p).L,count);
if LH(p).L < count then
inc(LH(p).H,SelectorInc); { $1000 }
end;
procedure DecPtr(var p:pointer;count:word);
{ decrements pointer }
begin
if count > LH(p).L then
dec(LH(p).H,SelectorInc);
dec(LH(p).L,Count);
end;
procedure IncPtrLong(var p:pointer;count:longint);
{ Increments pointer; assumes count > 0 }
begin
inc(LH(p).H,SelectorInc*LH(count).H);
inc(LH(p).L,LH(Count).L);
if LH(p).L < LH(count).L then
inc(LH(p).H,SelectorInc);
end;
procedure DecPtrLong(var p:pointer;count:longint);
{ Decrements pointer; assumes count > 0 }
begin
if LH(count).L > LH(p).L then
dec(LH(p).H,SelectorInc);
dec(LH(p).L,LH(Count).L);
dec(LH(p).H,SelectorInc*LH(Count).H);
end;
{ The next section is for real mode only }
function Normalized(p : pointer) : pointer;
var
count : word;
begin
count := LH(p).L and $FFF0;
Normalized := Ptr(LH(p).H + (count shr 4), LH(p).L and $F);
end;
procedure FreeHuge(var p:HugePtr; size : longint);
const
blocksize = $FFF0;
var
block : word;
begin
while size > 0 do
begin
{ block := minimum(size, blocksize); }
if size > blocksize then
block := blocksize
else
block := size;
dec(size,block);
freemem(p,block);
IncPtr(p,block); { we may get ptr($xxxx, $fff8) and 31 bytes left }
p := Normalized(p); { to free, so we must normalize }
end;
end;
function FreeMemHuge(ptr : pointer) : boolean;
var
i : integer; { -1..MaxAllocEntries }
begin
FreeMemHuge := FALSE;
i := allocatedCount - 1;
while (i >= 0) do
begin
if (ptr = allocatedList[i].value) then
begin
with allocatedList[i] do
FreeHuge(orgvalue, size);
Move(allocatedList[i+1], allocatedList[i],
SizeOf(TMemRec)*(allocatedCount - 1 - i));
Dec(allocatedCount);
FreeMemHuge := TRUE;
break;
end;
Dec(i);
end;
end;
procedure GetMemHuge(var p:HugePtr;memsize:Longint);
const
blocksize = $FFF0;
var
size : longint;
prev,free : PFreeRec;
save,temp : pointer;
block : word;
begin
p := NIL;
{ Handle the easy cases first }
if memsize > maxavail then
exit
else
if memsize <= blocksize then
begin
getmem(p, memsize);
if not NewAllocation(p, p, memsize) then
begin
FreeMem(p, memsize);
p := NIL;
end;
end
else
begin
size := memsize + 15;
{ Find the block that has enough space }
prev := PFreeRec(@freeList);
free := prev^.next;
while (free <> heapptr) and (ptr2int(free^.size) < size) do
begin
prev := free;
free := prev^.next;
end;
{ Now free points to a region with enough space; make it the first one and
multiple allocations will be contiguous. }
save := freelist;
freelist := free;
{ In TP 6, this works; check against other heap managers }
while size > 0 do
begin
{ block := minimum(size, blocksize); }
if size > blocksize then
block := blocksize
else
block := size;
dec(size,block);
getmem(temp,block);
end;
{ We've got what we want now; just sort things out and restore the
free list to normal }
p := free;
if prev^.next <> freelist then
begin
prev^.next := freelist;
freelist := save;
end;
if (p <> NIL) then
begin
{ return pointer with 0 offset }
temp := p;
if Ofs(p^)<>0 Then
p := Ptr(Seg(p^)+1,0); { hack }
if not NewAllocation(temp, p, memsize + 15) then
begin
FreeHuge(temp, size);
p := NIL;
end;
end;
end;
end;
{$ENDIF}
procedure zmemcpy(destp : pBytef; sourcep : pBytef; len : uInt);
begin
Move(sourcep^, destp^, len);
end;
function zmemcmp(s1p, s2p : pBytef; len : uInt) : int;
var
j : uInt;
source,
dest : pBytef;
begin
source := s1p;
dest := s2p;
for j := 0 to pred(len) do
begin
if (source^ <> dest^) then
begin
zmemcmp := 2*Ord(source^ > dest^)-1;
exit;
end;
Inc(source);
Inc(dest);
end;
zmemcmp := 0;
end;
procedure zmemzero(destp : pBytef; len : uInt);
begin
FillChar(destp^, len, 0);
end;
procedure zcfree(opaque : voidpf; ptr : voidpf);
{$ifdef Delphi16}
var
Handle : THandle;
{$endif}
{$IFDEF FPC}
var
memsize : uint;
{$ENDIF}
begin
{$IFDEF DPMI}
{h :=} GlobalFreePtr(ptr);
{$ELSE}
{$IFDEF CALL_DOS}
dosFree(ptr);
{$ELSE}
{$ifdef HugeMem}
FreeMemHuge(ptr);
{$else}
{$ifdef Delphi16}
Handle := GlobalHandle(LH(ptr).H); { HiWord(LongInt(ptr)) }
GlobalUnLock(Handle);
GlobalFree(Handle);
{$else}
{$IFDEF FPC}
Dec(puIntf(ptr));
memsize := puIntf(ptr)^;
FreeMem(ptr, memsize+SizeOf(uInt));
{$ELSE}
FreeMem(ptr); { Delphi 2,3,4 }
{$ENDIF}
{$endif}
{$endif}
{$ENDIF}
{$ENDIF}
end;
function zcalloc (opaque : voidpf; items : uInt; size : uInt) : voidpf;
var
p : voidpf;
memsize : uLong;
{$ifdef Delphi16}
handle : THandle;
{$endif}
begin
memsize := uLong(items) * size;
{$IFDEF DPMI}
p := GlobalAllocPtr(gmem_moveable, memsize);
{$ELSE}
{$IFDEF CALLDOS}
p := dosAlloc(memsize);
{$ELSE}
{$ifdef HugeMem}
GetMemHuge(p, memsize);
{$else}
{$ifdef Delphi16}
Handle := GlobalAlloc(HeapAllocFlags, memsize);
p := GlobalLock(Handle);
{$else}
{$IFDEF FPC}
GetMem(p, memsize+SizeOf(uInt));
puIntf(p)^:= memsize;
Inc(puIntf(p));
{$ELSE}
GetMem(p, memsize); { Delphi: p := AllocMem(memsize); }
{$ENDIF}
{$endif}
{$endif}
{$ENDIF}
{$ENDIF}
zcalloc := p;
end;
{ edited from a SWAG posting:
In Turbo Pascal 6, the heap is the memory allocated when using the Procedures 'New' and
'GetMem'. The heap starts at the address location pointed to by 'Heaporg' and
grows to higher addresses as more memory is allocated. The top of the heap,
the first address of allocatable memory space above the allocated memory
space, is pointed to by 'HeapPtr'.
Memory is deallocated by the Procedures 'Dispose' and 'FreeMem'. As memory
blocks are deallocated more memory becomes available, but..... When a block
of memory, which is not the top-most block in the heap is deallocated, a gap
in the heap will appear. to keep track of these gaps Turbo Pascal maintains
a so called free list.
The Function 'MaxAvail' holds the size of the largest contiguous free block
_in_ the heap. The Function 'MemAvail' holds the sum of all free blocks in
the heap.
TP6.0 keeps track of the free blocks by writing a 'free list Record' to the
first eight Bytes of the freed memory block! A (TP6.0) free-list Record
contains two four Byte Pointers of which the first one points to the next
free memory block, the second Pointer is not a Real Pointer but contains the
size of the memory block.
Summary
TP6.0 maintains a linked list with block sizes and Pointers to the _next_
free block. An extra heap Variable 'Heapend' designate the end of the heap.
When 'HeapPtr' and 'FreeList' have the same value, the free list is empty.
TP6.0 Heapend
<20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>Ŀ <<3C><><EFBFBD><EFBFBD>
<20> <20>
<20> <20>
<20> <20>
<20> <20>
<20> <20>
<20> <20>
<20> <20>
<20> <20> HeapPtr
<20><>><3E><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>Ĵ <<3C><><EFBFBD><EFBFBD>
<20> <20> <20>
<20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>Ĵ
<20><>ij Free <20>
<20><>><3E><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>Ĵ
<20> <20> <20>
<20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>Ĵ
<20><>ij Free <20> FreeList
<20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>Ĵ <<3C><><EFBFBD><EFBFBD>
<20> <20> Heaporg
<20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>Ĵ <<3C><><EFBFBD><EFBFBD>
}
end.

485
contrib/fundamentals/ZLib/paszlib/dzlib.pas Normal file
View File

@@ -0,0 +1,485 @@
{*******************************************************}
{ }
{ Delphi Supplemental Components }
{ ZLIB Data Compression Interface Unit }
{ }
{ Copyright (c) 1997 Borland International }
{ Copyright (c) 1998 Jacques Nomssi Nzali }
{ }
{*******************************************************}
unit dzlib;
{$WARN UNSAFE_TYPE OFF}
{$WARN UNSAFE_CODE OFF}
interface
uses gzlib, Sysutils, Classes;
{$IFDEF VER80}
{$DEFINE Delphi16}
{$ENDIF}
type
TAlloc = alloc_func;
{function (AppData: Pointer; Items, Size: Integer): Pointer;}
TFree = free_func;
{procedure (AppData, Block: Pointer);}
{ Internal structure. Ignore. }
TZStreamRec = z_stream;
const
FBufSize = 8192;
type
{ Abstract ancestor class }
TCustomZlibStream = class(TStream)
private
FStrm: TStream;
FStrmPos: Integer;
FOnProgress: TNotifyEvent;
FZRec: TZStreamRec;
FBuffer: array [0..FBufSize-1] 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 }
{$IFDEF Delphi16}
procedure CompressBuf(const InBuf: Pointer; InBytes: Integer;
var OutBuf: Pointer; var OutBytes: Integer);
{$ELSE}
procedure CompressBuf(const InBuf: Pointer; InBytes: Integer;
out OutBuf: Pointer; out OutBytes: Integer);
{$ENDIF}
{ 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 }
{$IFDEF Delphi16}
procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer;
OutEstimate: Integer; var OutBuf: Pointer; var OutBytes: Integer);
{$ELSE}
procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer;
OutEstimate: Integer; out OutBuf: Pointer; out OutBytes: Integer);
{$ENDIF}
type
EZlibError = class(Exception);
ECompressionError = class(EZlibError);
EDecompressionError = class(EZlibError);
implementation
uses
{$IFDEF Delphi16}
WinTypes, WinProcs,
{$ENDIF}
zutil, zDeflate, zInflate;
{$IFDEF Delphi16}
Procedure zlibFreeMem(AppData, Block: Pointer); far;
type
LH = packed record
L, H : word;
end;
var
Handle : THandle;
begin
Handle := GlobalHandle(LH(Block).H); { HiWord(LongInt(ptr)) }
GlobalUnLock(Handle);
GlobalFree(Handle);
end;
function zlibAllocMem(AppData: Pointer; Items, Size: Cardinal): Pointer; far;
var
handle : THandle;
begin
Handle := GlobalAlloc(HeapAllocFlags, Long(Items) * Size);
zlibAllocMem := GlobalLock(Handle);
end;
procedure ReAllocMem(OutBuf : voidpf; OutBytes : uInt);
begin
zlibFreeMem(NIL, OutBuf);
OutBuf := zlibAllocMem(NIL, OutBytes, 1);
end;
{$ELSE}
function zlibAllocMem(AppData: Pointer; Items, Size: Cardinal): Pointer;
begin
GetMem(Result, Items*Size);
end;
procedure zlibFreeMem(AppData, Block: Pointer);
begin
FreeMem(Block);
end;
{$ENDIF}
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;
{$IFDEF Delphi16}
procedure CompressBuf(const InBuf: Pointer; InBytes: Integer;
var OutBuf: Pointer; var OutBytes: Integer);
{$ELSE}
procedure CompressBuf(const InBuf: Pointer; InBytes: Integer;
out OutBuf: Pointer; out OutBytes: Integer);
{$ENDIF}
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 := pBytef(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
{$IFDEF Delphi16} {next line changed} {$ENDIF}
zlibFreeMem(NIL, OutBuf);
raise
end;
end;
{$IFDEF Delphi16}
procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer;
OutEstimate: Integer; var OutBuf: Pointer; var OutBytes: Integer);
{$ELSE}
procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer;
OutEstimate: Integer; out OutBuf: Pointer; out OutBytes: Integer);
{$ENDIF}
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 inflate(strm, Z_FINISH) <> Z_STREAM_END do
begin
P := OutBuf;
Inc(OutBytes, BufInc);
ReallocMem(OutBuf, OutBytes);
strm.next_out := pBytef(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
{$IFDEF Delphi16} {next line changed} {$ENDIF}
zlibFreeMem(NIL, OutBuf);
raise
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.Create('Invalid stream operation');
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.Create('Invalid stream operation');
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
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.Create('Invalid stream operation');
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.Create('Invalid stream operation');
Result := FZRec.total_out;
end;
end.

102
contrib/fundamentals/ZLib/paszlib/dzlib.txt Normal file
View File

@@ -0,0 +1,102 @@
The Delphi 3 CD-ROM contains in \INFO\EXTRAS\ZLIB a zlib unit that implements
the TCompressionStream and TDecompressionStream classes. With some changes to
this unit you can implement the same functionality using Paszlib. I can not
publish the modified file (Copyright 1997 by Borland International), but this
document tells you how to make the changes by hand.
1. zlib.pas conflicts to a Paszlib unit name, change the name to dzlib.pas.
< unit dzlib;
---
> unit zlib;
2. Add zlib to the uses clause:
< uses zlib, Sysutils, Classes;
---
> uses Sysutils, Classes;
3. Change the type declarations for TAlloc, TFree and TZStreamRec to
< TAlloc = alloc_func;
< TFree = free_func;
< TZStreamRec = z_stream;
4. Remove the zlib_Version const.
> const
> zlib_Version = '1.0.4';
5. In the implementation part, add the following uses clause
< uses
< zutil, zDeflate, zInflate;
6. remove all Z_xxx const, {$L xxx} and all external procedures up to
(and including) the inflateReset() function and the _memset and _memcpy
procedure definitions.
7. for compatibility with D1 you should change the type of the "Size"
parameter of the zlibAllocMem() function from Integer to Cardinal
and all comments of the // form into the {} form.
8. Now, make the following changes, so that the dzlib can compile, you
can then use the modified unit dzlib in the test.pas source.
185c293
< CCheck(deflateInit_(@strm, Z_BEST_COMPRESSION, zlib_version, sizeof(strm)));
---
> CCheck(deflateInit_(strm, Z_BEST_COMPRESSION, zlib_version, sizeof(strm)));
192c300
< strm.next_out := pBytef(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P)));
---
> strm.next_out := PChar(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P)));
228c336
< DCheck(inflateInit_(@strm, zlib_version, sizeof(strm)));
---
> DCheck(inflateInit_(strm, zlib_version, sizeof(strm)));
235c343
< strm.next_out := pBytef(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P)));
---
> strm.next_out := PChar(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P)));
250c358
276c384
< FZRec.next_out := @FBuffer;
---
> FZRec.next_out := FBuffer;
278c386
< CCheck(deflateInit_(@FZRec, Levels[CompressionLevel], zlib_version, sizeof(FZRec)));
---
> CCheck(deflateInit_(FZRec, Levels[CompressionLevel], zlib_version, sizeof(FZRec)));
291c399
< FZRec.next_out := @FBuffer;
---
> FZRec.next_out := FBuffer;
318c426
< FZRec.next_out := @FBuffer;
---
> FZRec.next_out := FBuffer;
344c452
< FZRec.next_in := @FBuffer;
---
> FZRec.next_in := FBuffer;
351c459
< DCheck(inflateInit_(@FZRec, zlib_version, sizeof(FZRec)));
---
> DCheck(inflateInit_(FZRec, zlib_version, sizeof(FZRec)));
375c483
< FZRec.next_in := @FBuffer;
---
> FZRec.next_in := FBuffer;
397c505
< FZRec.next_in := @FBuffer;
---
> FZRec.next_in := FBuffer;
9. This is a bug fix:
in CompressBuf() change
< while CCheck(deflate(strm, Z_FINISH)) <> Z_STREAM_END do
to
> while deflate(strm, Z_FINISH) <> Z_STREAM_END do
in DeCompressBuf() change
< while CCheck(inflate(strm, Z_FINISH)) <> Z_STREAM_END do
to
> while inflate(strm, Z_FINISH) <> Z_STREAM_END do
Jacques Nomssi Nzali <nomssi@physik.tu-chemnitz.de> [25.3.2000]

704
contrib/fundamentals/ZLib/paszlib/example.pas Normal file
View File

@@ -0,0 +1,704 @@
program example;
{ example.c -- usage example of the zlib compression library
Copyright (C) 1995-1998 Jean-loup Gailly.
Pascal tranlastion
Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
}
{-$define MemCheck}
{$DEFINE TEST_COMPRESS}
{$DEFINE TEST_GZIO}
{$DEFINE TEST_INFLATE}
{$DEFINE TEST_DEFLATE}
{$DEFINE TEST_SYNC}
{$DEFINE TEST_DICT}
{$DEFINE TEST_FLUSH}
uses
{$ifdef ver80}
WinCrt,
{$endif}
{$ifdef you may have to define this in Delphi < 5}
strings,
{$endif}
{$ifndef MSDOS}
SysUtils,
{$endif}
zutil,
gzLib,
gzIo,
zInflate,
zDeflate,
zCompres,
zUnCompr
{$ifdef MemCheck}
, MemCheck in '..\..\monotekt\pas\memcheck\memcheck.pas'
{$endif}
;
procedure Stop;
begin
Write('Program halted...');
ReadLn;
Halt(1);
end;
procedure CHECK_ERR(err : int; msg : string);
begin
if (err <> Z_OK) then
begin
Write(msg, ' error: ', err);
Stop;
end;
end;
const
hello : PChar = 'hello, hello!';
{ "hello world" would be more standard, but the repeated "hello"
stresses the compression code better, sorry... }
{$IFDEF TEST_DICT}
const
dictionary : PChar = 'hello';
var
dictId : uLong; { Adler32 value of the dictionary }
{$ENDIF}
{ ===========================================================================
Test compress() and uncompress() }
{$IFDEF TEST_COMPRESS}
procedure test_compress(compr : pBytef; var comprLen : uLong;
uncompr : pBytef; uncomprLen : uLong);
var
err : int;
len : uLong;
begin
len := strlen(hello)+1;
err := compress(compr, comprLen, pBytef(hello)^, len);
CHECK_ERR(err, 'compress');
strcopy(PChar(uncompr), 'garbage');
err := uncompress(uncompr, uncomprLen, compr^, comprLen);
CHECK_ERR(err, 'uncompress');
if (strcomp(PChar(uncompr), hello)) <> 0 then
begin
WriteLn('bad uncompress');
Stop;
end
else
WriteLn('uncompress(): ', StrPas(PChar(uncompr)));
end;
{$ENDIF}
{ ===========================================================================
Test read/write of .gz files }
{$IFDEF TEST_GZIO}
procedure test_gzio(const outf : string; { output file }
const inf : string; { input file }
uncompr : pBytef;
uncomprLen : int);
var
err : int;
len : int;
var
zfile : gzFile;
pos : z_off_t;
begin
len := strlen(hello)+1;
zfile := gzopen(outf, 'w');
if (zfile = NIL) then
begin
WriteLn('_gzopen error');
Stop;
end;
gzputc(zfile, 'h');
if (gzputs(zfile, 'ello') <> 4) then
begin
WriteLn('gzputs err: ', gzerror(zfile, err));
Stop;
end;
{$ifdef GZ_FORMAT_STRING}
if (gzprintf(zfile, ', %s!', 'hello') <> 8) then
begin
WriteLn('gzprintf err: ', gzerror(zfile, err));
Stop;
end;
{$else}
if (gzputs(zfile, ', hello!') <> 8) then
begin
WriteLn('gzputs err: ', gzerror(zfile, err));
Stop;
end;
{$ENDIF}
gzseek(zfile, Long(1), SEEK_CUR); { add one zero byte }
gzclose(zfile);
zfile := gzopen(inf, 'r');
if (zfile = NIL) then
WriteLn('gzopen error');
strcopy(pchar(uncompr), 'garbage');
uncomprLen := gzread(zfile, uncompr, uInt(uncomprLen));
if (uncomprLen <> len) then
begin
WriteLn('gzread err: ', gzerror(zfile, err));
Stop;
end;
if (strcomp(pchar(uncompr), hello)) <> 0 then
begin
WriteLn('bad gzread: ', pchar(uncompr));
Stop;
end
else
WriteLn('gzread(): ', pchar(uncompr));
pos := gzseek(zfile, Long(-8), SEEK_CUR);
if (pos <> 6) or (gztell(zfile) <> pos) then
begin
WriteLn('gzseek error, pos=',pos,', gztell=',gztell(zfile));
Stop;
end;
if (char(gzgetc(zfile)) <> ' ') then
begin
WriteLn('gzgetc error');
Stop;
end;
gzgets(zfile, pchar(uncompr), uncomprLen);
uncomprLen := strlen(pchar(uncompr));
if (uncomprLen <> 6) then
begin { "hello!" }
WriteLn('gzgets err after gzseek: ', gzerror(zfile, err));
Stop;
end;
if (strcomp(pchar(uncompr), hello+7)) <> 0 then
begin
WriteLn('bad gzgets after gzseek');
Stop;
end
else
WriteLn('gzgets() after gzseek: ', PChar(uncompr));
gzclose(zfile);
end;
{$ENDIF}
{ ===========================================================================
Test deflate() with small buffers }
{$IFDEF TEST_DEFLATE}
procedure test_deflate(compr : pBytef; comprLen : uLong);
var
c_stream : z_stream; { compression stream }
err : int;
len : int;
begin
len := strlen(hello)+1;
c_stream.zalloc := NIL; {alloc_func(0);}
c_stream.zfree := NIL; {free_func(0);}
c_stream.opaque := NIL; {voidpf(0);}
err := deflateInit(c_stream, Z_DEFAULT_COMPRESSION);
CHECK_ERR(err, 'deflateInit');
c_stream.next_in := pBytef(hello);
c_stream.next_out := compr;
while (c_stream.total_in <> uLong(len)) and (c_stream.total_out < comprLen) do
begin
c_stream.avail_out := 1; { force small buffers }
c_stream.avail_in := 1;
err := deflate(c_stream, Z_NO_FLUSH);
CHECK_ERR(err, 'deflate');
end;
{ Finish the stream, still forcing small buffers: }
while TRUE do
begin
c_stream.avail_out := 1;
err := deflate(c_stream, Z_FINISH);
if (err = Z_STREAM_END) then
break;
CHECK_ERR(err, 'deflate');
end;
err := deflateEnd(c_stream);
CHECK_ERR(err, 'deflateEnd');
end;
{$ENDIF}
{ ===========================================================================
Test inflate() with small buffers
}
{$IFDEF TEST_INFLATE}
procedure test_inflate(compr : pBytef; comprLen : uLong;
uncompr : pBytef; uncomprLen : uLong);
var
err : int;
d_stream : z_stream; { decompression stream }
begin
strcopy(PChar(uncompr), 'garbage');
d_stream.zalloc := NIL; {alloc_func(0);}
d_stream.zfree := NIL; {free_func(0);}
d_stream.opaque := NIL; {voidpf(0);}
d_stream.next_in := compr;
d_stream.avail_in := 0;
d_stream.next_out := uncompr;
err := inflateInit(d_stream);
CHECK_ERR(err, 'inflateInit');
while (d_stream.total_out < uncomprLen) and
(d_stream.total_in < comprLen) do
begin
d_stream.avail_out := 1; { force small buffers }
d_stream.avail_in := 1;
err := inflate(d_stream, Z_NO_FLUSH);
if (err = Z_STREAM_END) then
break;
CHECK_ERR(err, 'inflate');
end;
err := inflateEnd(d_stream);
CHECK_ERR(err, 'inflateEnd');
if (strcomp(PChar(uncompr), hello) <> 0) then
begin
WriteLn('bad inflate');
exit;
end
else
begin
WriteLn('inflate(): ', StrPas(PChar(uncompr)));
end;
end;
{$ENDIF}
{ ===========================================================================
Test deflate() with large buffers and dynamic change of compression level
}
{$IFDEF TEST_DEFLATE}
procedure test_large_deflate(compr : pBytef; comprLen : uLong;
uncompr : pBytef; uncomprLen : uLong);
var
c_stream : z_stream; { compression stream }
err : int;
begin
c_stream.zalloc := NIL; {alloc_func(0);}
c_stream.zfree := NIL; {free_func(0);}
c_stream.opaque := NIL; {voidpf(0);}
err := deflateInit(c_stream, Z_BEST_SPEED);
CHECK_ERR(err, 'deflateInit');
c_stream.next_out := compr;
c_stream.avail_out := uInt(comprLen);
{ At this point, uncompr is still mostly zeroes, so it should compress
very well: }
c_stream.next_in := uncompr;
c_stream.avail_in := uInt(uncomprLen);
err := deflate(c_stream, Z_NO_FLUSH);
CHECK_ERR(err, 'deflate');
if (c_stream.avail_in <> 0) then
begin
WriteLn('deflate not greedy');
exit;
end;
{ Feed in already compressed data and switch to no compression: }
deflateParams(c_stream, Z_NO_COMPRESSION, Z_DEFAULT_STRATEGY);
c_stream.next_in := compr;
c_stream.avail_in := uInt(comprLen div 2);
err := deflate(c_stream, Z_NO_FLUSH);
CHECK_ERR(err, 'deflate');
{ Switch back to compressing mode: }
deflateParams(c_stream, Z_BEST_COMPRESSION, Z_FILTERED);
c_stream.next_in := uncompr;
c_stream.avail_in := uInt(uncomprLen);
err := deflate(c_stream, Z_NO_FLUSH);
CHECK_ERR(err, 'deflate');
err := deflate(c_stream, Z_FINISH);
if (err <> Z_STREAM_END) then
begin
WriteLn('deflate should report Z_STREAM_END');
exit;
end;
err := deflateEnd(c_stream);
CHECK_ERR(err, 'deflateEnd');
end;
{$ENDIF}
{ ===========================================================================
Test inflate() with large buffers }
{$IFDEF TEST_INFLATE}
procedure test_large_inflate(compr : pBytef; comprLen : uLong;
uncompr : pBytef; uncomprLen : uLong);
var
err : int;
d_stream : z_stream; { decompression stream }
begin
strcopy(PChar(uncompr), 'garbage');
d_stream.zalloc := NIL; {alloc_func(0);}
d_stream.zfree := NIL; {free_func(0);}
d_stream.opaque := NIL; {voidpf(0);}
d_stream.next_in := compr;
d_stream.avail_in := uInt(comprLen);
err := inflateInit(d_stream);
CHECK_ERR(err, 'inflateInit');
while TRUE do
begin
d_stream.next_out := uncompr; { discard the output }
d_stream.avail_out := uInt(uncomprLen);
err := inflate(d_stream, Z_NO_FLUSH);
if (err = Z_STREAM_END) then
break;
CHECK_ERR(err, 'large inflate');
end;
err := inflateEnd(d_stream);
CHECK_ERR(err, 'inflateEnd');
if (d_stream.total_out <> 2*uncomprLen + comprLen div 2) then
begin
WriteLn('bad large inflate: ', d_stream.total_out);
Stop;
end
else
WriteLn('large_inflate(): OK');
end;
{$ENDIF}
{ ===========================================================================
Test deflate() with full flush
}
{$IFDEF TEST_FLUSH}
procedure test_flush(compr : pBytef; var comprLen : uLong);
var
c_stream : z_stream; { compression stream }
err : int;
len : int;
begin
len := strlen(hello)+1;
c_stream.zalloc := NIL; {alloc_func(0);}
c_stream.zfree := NIL; {free_func(0);}
c_stream.opaque := NIL; {voidpf(0);}
err := deflateInit(c_stream, Z_DEFAULT_COMPRESSION);
CHECK_ERR(err, 'deflateInit');
c_stream.next_in := pBytef(hello);
c_stream.next_out := compr;
c_stream.avail_in := 3;
c_stream.avail_out := uInt(comprLen);
err := deflate(c_stream, Z_FULL_FLUSH);
CHECK_ERR(err, 'deflate');
Inc(pzByteArray(compr)^[3]); { force an error in first compressed block }
c_stream.avail_in := len - 3;
err := deflate(c_stream, Z_FINISH);
if (err <> Z_STREAM_END) then
CHECK_ERR(err, 'deflate');
err := deflateEnd(c_stream);
CHECK_ERR(err, 'deflateEnd');
comprLen := c_stream.total_out;
end;
{$ENDIF}
{ ===========================================================================
Test inflateSync()
}
{$IFDEF TEST_SYNC}
procedure test_sync(compr : pBytef; comprLen : uLong;
uncompr : pBytef; uncomprLen : uLong);
var
err : int;
d_stream : z_stream; { decompression stream }
begin
strcopy(PChar(uncompr), 'garbage');
d_stream.zalloc := NIL; {alloc_func(0);}
d_stream.zfree := NIL; {free_func(0);}
d_stream.opaque := NIL; {voidpf(0);}
d_stream.next_in := compr;
d_stream.avail_in := 2; { just read the zlib header }
err := inflateInit(d_stream);
CHECK_ERR(err, 'inflateInit');
d_stream.next_out := uncompr;
d_stream.avail_out := uInt(uncomprLen);
inflate(d_stream, Z_NO_FLUSH);
CHECK_ERR(err, 'inflate');
d_stream.avail_in := uInt(comprLen-2); { read all compressed data }
err := inflateSync(d_stream); { but skip the damaged part }
CHECK_ERR(err, 'inflateSync');
err := inflate(d_stream, Z_FINISH);
if (err <> Z_DATA_ERROR) then
begin
WriteLn('inflate should report DATA_ERROR');
{ Because of incorrect adler32 }
Stop;
end;
err := inflateEnd(d_stream);
CHECK_ERR(err, 'inflateEnd');
WriteLn('after inflateSync(): hel', StrPas(PChar(uncompr)));
end;
{$ENDIF}
{ ===========================================================================
Test deflate() with preset dictionary
}
{$IFDEF TEST_DICT}
procedure test_dict_deflate(compr : pBytef; comprLen : uLong);
var
c_stream : z_stream; { compression stream }
err : int;
begin
c_stream.zalloc := NIL; {(alloc_func)0;}
c_stream.zfree := NIL; {(free_func)0;}
c_stream.opaque := NIL; {(voidpf)0;}
err := deflateInit(c_stream, Z_BEST_COMPRESSION);
CHECK_ERR(err, 'deflateInit');
err := deflateSetDictionary(c_stream,
pBytef(dictionary), StrLen(dictionary));
CHECK_ERR(err, 'deflateSetDictionary');
dictId := c_stream.adler;
c_stream.next_out := compr;
c_stream.avail_out := uInt(comprLen);
c_stream.next_in := pBytef(hello);
c_stream.avail_in := uInt(strlen(hello)+1);
err := deflate(c_stream, Z_FINISH);
if (err <> Z_STREAM_END) then
begin
WriteLn('deflate should report Z_STREAM_END');
exit;
end;
err := deflateEnd(c_stream);
CHECK_ERR(err, 'deflateEnd');
end;
{ ===========================================================================
Test inflate() with a preset dictionary }
procedure test_dict_inflate(compr : pBytef; comprLen : uLong;
uncompr : pBytef; uncomprLen : uLong);
var
err : int;
d_stream : z_stream; { decompression stream }
begin
strcopy(PChar(uncompr), 'garbage');
d_stream.zalloc := NIL; { alloc_func(0); }
d_stream.zfree := NIL; { free_func(0); }
d_stream.opaque := NIL; { voidpf(0); }
d_stream.next_in := compr;
d_stream.avail_in := uInt(comprLen);
err := inflateInit(d_stream);
CHECK_ERR(err, 'inflateInit');
d_stream.next_out := uncompr;
d_stream.avail_out := uInt(uncomprLen);
while TRUE do
begin
err := inflate(d_stream, Z_NO_FLUSH);
if (err = Z_STREAM_END) then
break;
if (err = Z_NEED_DICT) then
begin
if (d_stream.adler <> dictId) then
begin
WriteLn('unexpected dictionary');
Stop;
end;
err := inflateSetDictionary(d_stream, pBytef(dictionary),
StrLen(dictionary));
end;
CHECK_ERR(err, 'inflate with dict');
end;
err := inflateEnd(d_stream);
CHECK_ERR(err, 'inflateEnd');
if (strcomp(PChar(uncompr), hello)) <> 0 then
begin
WriteLn('bad inflate with dict');
Stop;
end
else
begin
WriteLn('inflate with dictionary: ', StrPas(PChar(uncompr)));
end;
end;
{$ENDIF}
function GetFromFile(buf : pBytef; FName : string;
var MaxLen : uInt) : boolean;
const
zOfs = 0;
var
f : file;
Len : uLong;
begin
assign(f, FName);
GetFromFile := false;
{$I-}
filemode := 0; { read only }
reset(f, 1);
if IOresult = 0 then
begin
Len := FileSize(f)-zOfs;
Seek(f, zOfs);
if Len < MaxLen then
MaxLen := Len;
BlockRead(f, buf^, MaxLen);
close(f);
WriteLn(FName);
GetFromFile := (IOresult = 0) and (MaxLen > 0);
end
else
WriteLn('Could not open ', FName);
end;
{ ===========================================================================
Usage: example [output.gz [input.gz]]
}
var
compr, uncompr : pBytef;
const
msdoslen = 25000;
comprLenL : uLong = msdoslen div sizeof(uInt); { don't overflow on MSDOS }
uncomprLenL : uLong = msdoslen div sizeof(uInt);
var
zVersion,
myVersion : string;
var
comprLen : uInt;
uncomprLen : uInt;
begin
{$ifdef MemCheck}
MemChk;
{$endif}
comprLen := comprLenL;
uncomprLen := uncomprLenL;
myVersion := ZLIB_VERSION;
zVersion := zlibVersion;
if (zVersion[1] <> myVersion[1]) then
begin
WriteLn('incompatible zlib version');
Stop;
end
else
if (zVersion <> ZLIB_VERSION) then
begin
WriteLn('warning: different zlib version');
end;
GetMem(compr, comprLen*sizeof(uInt));
GetMem(uncompr, uncomprLen*sizeof(uInt));
{ compr and uncompr are cleared to avoid reading uninitialized
data and to ensure that uncompr compresses well. }
if (compr = Z_NULL) or (uncompr = Z_NULL) then
begin
WriteLn('out of memory');
Stop;
end;
FillChar(compr^, comprLen*sizeof(uInt), 0);
FillChar(uncompr^, uncomprLen*sizeof(uInt), 0);
if (compr = Z_NULL) or (uncompr = Z_NULL) then
begin
WriteLn('out of memory');
Stop;
end;
{$IFDEF TEST_COMPRESS}
test_compress(compr, comprLenL, uncompr, uncomprLen);
{$ENDIF}
{$IFDEF TEST_GZIO}
Case ParamCount of
0: test_gzio('foo.gz', 'foo.gz', uncompr, int(uncomprLen));
1: test_gzio(ParamStr(1), 'foo.gz', uncompr, int(uncomprLen));
else
test_gzio(ParamStr(1), ParamStr(2), uncompr, int(uncomprLen));
end;
{$ENDIF}
{$IFDEF TEST_DEFLATE}
WriteLn('small buffer Deflate');
test_deflate(compr, comprLen);
{$ENDIF}
{$IFDEF TEST_INFLATE}
{$IFNDEF TEST_DEFLATE}
WriteLn('small buffer Inflate');
if GetFromFile(compr, 'u:\nomssi\paszlib\new\test0.z', comprLen) then
{$ENDIF}
test_inflate(compr, comprLen, uncompr, uncomprLen);
{$ENDIF}
readln;
{$IFDEF TEST_DEFLATE}
WriteLn('large buffer Deflate');
test_large_deflate(compr, comprLen, uncompr, uncomprLen);
{$ENDIF}
{$IFDEF TEST_INFLATE}
WriteLn('large buffer Inflate');
test_large_inflate(compr, comprLen, uncompr, uncomprLen);
{$ENDIF}
{$IFDEF TEST_FLUSH}
test_flush(compr, comprLenL);
{$ENDIF}
{$IFDEF TEST_SYNC}
test_sync(compr, comprLen, uncompr, uncomprLen);
{$ENDIF}
comprLen := uncomprLen;
{$IFDEF TEST_DICT}
test_dict_deflate(compr, comprLen);
test_dict_inflate(compr, comprLen, uncompr, uncomprLen);
{$ENDIF}
readln;
FreeMem(compr, comprLen*sizeof(uInt));
FreeMem(uncompr, uncomprLen*sizeof(uInt));
end.

526
contrib/fundamentals/ZLib/paszlib/gZlib.pas Normal file
View File

@@ -0,0 +1,526 @@
unit gZlib;
{ Original:
zlib.h -- interface of the 'zlib' general purpose compression library
version 1.1.0, Feb 24th, 1998
Copyright (C) 1995-1998 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
jloup@gzip.org madler@alumni.caltech.edu
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).
Pascal tranlastion
Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
Modifiied 02/2003 by Sergey A. Galin for Delphi 6+ and Kylix compatibility.
See README in directory above for more information.
}
interface
{$I zconf.inc}
uses
ZUtil;
{ zconf.h -- configuration of the zlib compression library }
{ zutil.c -- target dependent utility functions for the compression library }
{ The 'zlib' compression library provides in-memory compression and
decompression functions, including integrity checks of the uncompressed
data. This version of the library supports only one compression method
(deflation) but other algorithms will be added later and will have the same
stream interface.
Compression can be done in a single step if the buffers are large
enough (for example if an input file is mmap'ed), or can be done by
repeated calls of the compression function. In the latter case, the
application must provide more input and/or consume the output
(providing more output space) before each call.
The library also supports reading and writing files in gzip (.gz) format
with an interface similar to that of stdio.
The library does not install any signal handler. The decoder checks
the consistency of the compressed data, so the library should never
crash even in case of corrupted input. }
{ Compile with -DMAXSEG_64K if the alloc function cannot allocate more
than 64k bytes at a time (needed on systems with 16-bit int). }
{ Maximum value for memLevel in deflateInit2 }
{$ifdef MAXSEG_64K}
{$IFDEF VER70}
const
MAX_MEM_LEVEL = 7;
DEF_MEM_LEVEL = MAX_MEM_LEVEL; { default memLevel }
{$ELSE}
const
MAX_MEM_LEVEL = 8;
DEF_MEM_LEVEL = MAX_MEM_LEVEL; { default memLevel }
{$ENDIF}
{$else}
const
MAX_MEM_LEVEL = 9;
DEF_MEM_LEVEL = 8; { if MAX_MEM_LEVEL > 8 }
{$endif}
{ Maximum value for windowBits in deflateInit2 and inflateInit2 }
const
{$IFDEF VER70}
MAX_WBITS = 14; { 32K LZ77 window }
{$ELSE}
MAX_WBITS = 15; { 32K LZ77 window }
{$ENDIF}
{ default windowBits for decompression. MAX_WBITS is for compression only }
const
DEF_WBITS = MAX_WBITS;
{ The memory requirements for deflate are (in bytes):
1 shl (windowBits+2) + 1 shl (memLevel+9)
that is: 128K for windowBits=15 + 128K for memLevel = 8 (default values)
plus a few kilobytes for small objects. For example, if you want to reduce
the default memory requirements from 256K to 128K, compile with
DMAX_WBITS=14 DMAX_MEM_LEVEL=7
Of course this will generally degrade compression (there's no free lunch).
The memory requirements for inflate are (in bytes) 1 shl windowBits
that is, 32K for windowBits=15 (default value) plus a few kilobytes
for small objects. }
{ Huffman code lookup table entry--this entry is four bytes for machines
that have 16-bit pointers (e.g. PC's in the small or medium model). }
type
pInflate_huft = ^inflate_huft;
inflate_huft = Record
Exop, { number of extra bits or operation }
bits : Byte; { number of bits in this code or subcode }
{pad : uInt;} { pad structure to a power of 2 (4 bytes for }
{ 16-bit, 8 bytes for 32-bit int's) }
base : uInt; { literal, length base, or distance base }
{ or table offset }
End;
type
huft_field = Array[0..(MaxMemBlock div SizeOf(inflate_huft))-1] of inflate_huft;
huft_ptr = ^huft_field;
type
ppInflate_huft = ^pInflate_huft;
type
inflate_codes_mode = ( { waiting for "i:"=input, "o:"=output, "x:"=nothing }
START, { x: set up for LEN }
LEN, { i: get length/literal/eob next }
LENEXT, { i: getting length extra (have base) }
DIST, { i: get distance next }
DISTEXT, { i: getting distance extra }
COPY, { o: copying bytes in window, waiting for space }
LIT, { o: got literal, waiting for output space }
WASH, { o: got eob, possibly still output waiting }
ZEND, { x: got eob and all data flushed }
BADCODE); { x: got error }
{ inflate codes private state }
type
pInflate_codes_state = ^inflate_codes_state;
inflate_codes_state = record
mode : inflate_codes_mode; { current inflate_codes mode }
{ mode dependent information }
len : uInt;
sub : record { submode }
Case Byte of
0:(code : record { if LEN or DIST, where in tree }
tree : pInflate_huft; { pointer into tree }
need : uInt; { bits needed }
end);
1:(lit : uInt); { if LIT, literal }
2:(copy: record { if EXT or COPY, where and how much }
get : uInt; { bits to get for extra }
dist : uInt; { distance back to copy from }
end);
end;
{ mode independent information }
lbits : Byte; { ltree bits decoded per branch }
dbits : Byte; { dtree bits decoder per branch }
ltree : pInflate_huft; { literal/length/eob tree }
dtree : pInflate_huft; { distance tree }
end;
type
check_func = function(check : uLong;
buf : pBytef;
{const buf : array of byte;}
len : uInt) : uLong;
type
inflate_block_mode =
(ZTYPE, { get type bits (3, including end bit) }
LENS, { get lengths for stored }
STORED, { processing stored block }
TABLE, { get table lengths }
BTREE, { get bit lengths tree for a dynamic block }
DTREE, { get length, distance trees for a dynamic block }
CODES, { processing fixed or dynamic block }
DRY, { output remaining window bytes }
BLKDONE, { finished last block, done }
BLKBAD); { got a data error--stuck here }
type
pInflate_blocks_state = ^inflate_blocks_state;
{ inflate blocks semi-private state }
inflate_blocks_state = record
mode : inflate_block_mode; { current inflate_block mode }
{ mode dependent information }
sub : record { submode }
case Byte of
0:(left : uInt); { if STORED, bytes left to copy }
1:(trees : record { if DTREE, decoding info for trees }
table : uInt; { table lengths (14 bits) }
index : uInt; { index into blens (or border) }
blens : PuIntArray; { bit lengths of codes }
bb : uInt; { bit length tree depth }
tb : pInflate_huft; { bit length decoding tree }
end);
2:(decode : record { if CODES, current state }
tl : pInflate_huft;
td : pInflate_huft; { trees to free }
codes : pInflate_codes_state;
end);
end;
last : boolean; { true if this block is the last block }
{ mode independent information }
bitk : uInt; { bits in bit buffer }
bitb : uLong; { bit buffer }
hufts : huft_ptr; {pInflate_huft;} { single malloc for tree space }
window : pBytef; { sliding window }
zend : pBytef; { one byte after sliding window }
read : pBytef; { window read pointer }
write : pBytef; { window write pointer }
checkfn : check_func; { check function }
check : uLong; { check on output }
end;
type
inflate_mode = (
METHOD, { waiting for method byte }
FLAG, { waiting for flag byte }
DICT4, { four dictionary check bytes to go }
DICT3, { three dictionary check bytes to go }
DICT2, { two dictionary check bytes to go }
DICT1, { one dictionary check byte to go }
DICT0, { waiting for inflateSetDictionary }
BLOCKS, { decompressing blocks }
CHECK4, { four check bytes to go }
CHECK3, { three check bytes to go }
CHECK2, { two check bytes to go }
CHECK1, { one check byte to go }
DONE, { finished check, done }
BAD); { got an error--stay here }
{ inflate private state }
type
pInternal_state = ^internal_state; { or point to a deflate_state record }
internal_state = record
mode : inflate_mode; { current inflate mode }
{ mode dependent information }
sub : record { submode }
case byte of
0:(method : uInt); { if FLAGS, method byte }
1:(check : record { if CHECK, check values to compare }
was : uLong; { computed check value }
need : uLong; { stream check value }
end);
2:(marker : uInt); { if BAD, inflateSync's marker bytes count }
end;
{ mode independent information }
nowrap : boolean; { flag for no wrapper }
wbits : uInt; { log2(window size) (8..15, defaults to 15) }
blocks : pInflate_blocks_state; { current inflate_blocks state }
end;
type
alloc_func = function(opaque : voidpf; items : uInt; size : uInt) : voidpf;
free_func = procedure(opaque : voidpf; address : voidpf);
type
z_streamp = ^z_stream;
z_stream = record
next_in : pBytef; { next input byte }
avail_in : uInt; { number of bytes available at next_in }
total_in : uLong; { total nb of input bytes read so far }
next_out : pBytef; { next output byte should be put there }
avail_out : uInt; { remaining free space at next_out }
total_out : uLong; { total nb of bytes output so far }
msg : string; { last error message, '' if no error }
state : pInternal_state; { not visible by applications }
zalloc : alloc_func; { used to allocate the internal state }
zfree : free_func; { used to free the internal state }
opaque : voidpf; { private data object passed to zalloc and zfree }
data_type : int; { best guess about the data type: ascii or binary }
adler : uLong; { adler32 value of the uncompressed data }
reserved : uLong; { reserved for future use }
end;
{ The application must update next_in and avail_in when avail_in has
dropped to zero. It must update next_out and avail_out when avail_out
has dropped to zero. The application must initialize zalloc, zfree and
opaque before calling the init function. All other fields are set by the
compression library and must not be updated by the application.
The opaque value provided by the application will be passed as the first
parameter for calls of zalloc and zfree. This can be useful for custom
memory management. The compression library attaches no meaning to the
opaque value.
zalloc must return Z_NULL if there is not enough memory for the object.
On 16-bit systems, the functions zalloc and zfree must be able to allocate
exactly 65536 bytes, but will not be required to allocate more than this
if the symbol MAXSEG_64K is defined (see zconf.h). WARNING: On MSDOS,
pointers returned by zalloc for objects of exactly 65536 bytes *must*
have their offset normalized to zero. The default allocation function
provided by this library ensures this (see zutil.c). To reduce memory
requirements and avoid any allocation of 64K objects, at the expense of
compression ratio, compile the library with -DMAX_WBITS=14 (see zconf.h).
The fields total_in and total_out can be used for statistics or
progress reports. After compression, total_in holds the total size of
the uncompressed data and may be saved for use in the decompressor
(particularly if the decompressor wants to decompress everything in
a single step). }
const { constants }
Z_NO_FLUSH = 0;
Z_PARTIAL_FLUSH = 1;
Z_SYNC_FLUSH = 2;
Z_FULL_FLUSH = 3;
Z_FINISH = 4;
{ Allowed flush values; see deflate() below for details }
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);
{ Return codes for the compression/decompression functions. Negative
values are errors, positive values are used for special but normal events.}
Z_NO_COMPRESSION = 0;
Z_BEST_SPEED = 1;
Z_BEST_COMPRESSION = 9;
Z_DEFAULT_COMPRESSION = (-1);
{ compression levels }
Z_FILTERED = 1;
Z_HUFFMAN_ONLY = 2;
Z_DEFAULT_STRATEGY = 0;
{ compression strategy; see deflateInit2() below for details }
Z_BINARY = 0;
Z_ASCII = 1;
Z_UNKNOWN = 2;
{ Possible values of the data_type field }
Z_DEFLATED = 8;
{ The deflate compression method (the only one supported in this version) }
Z_NULL = NIL; { for initializing zalloc, zfree, opaque }
{$IFDEF GZIO}
var
errno : int;
{$ENDIF}
{ common constants }
{ The three kinds of block type }
const
STORED_BLOCK = 0;
STATIC_TREES = 1;
DYN_TREES = 2;
{ The minimum and maximum match lengths }
const
MIN_MATCH = 3;
{$ifdef MAX_MATCH_IS_258}
MAX_MATCH = 258;
{$else}
MAX_MATCH = ??; { deliberate syntax error }
{$endif}
const
PRESET_DICT = $20; { preset dictionary flag in zlib header }
{$IFDEF DEBUG}
// procedure Assert(cond : boolean; msg : string);
{$ENDIF}
procedure Trace(x : string);
procedure Tracev(x : string);
procedure Tracevv(x : string);
procedure Tracevvv(x : string);
procedure Tracec(c : boolean; x : string);
procedure Tracecv(c : boolean; x : string);
function zlibVersion : string;
{ The application can compare zlibVersion and ZLIB_VERSION for consistency.
If the first character differs, the library code actually used is
not compatible with the zlib.h header file used by the application.
This check is automatically made by deflateInit and inflateInit. }
function zError(err : int) : string;
function ZALLOC (var strm : z_stream; items : uInt; size : uInt) : voidpf;
procedure ZFREE (var strm : z_stream; ptr : voidpf);
procedure TRY_FREE (var strm : z_stream; ptr : voidpf);
const
ZLIB_VERSION : string = '1.1.2';
const
z_errbase = Z_NEED_DICT;
z_errmsg : array[0..9] of string = { indexed by 2-zlib_error }
('need dictionary', { Z_NEED_DICT 2 }
'stream end', { Z_STREAM_END 1 }
'', { Z_OK 0 }
'file error', { Z_ERRNO (-1) }
'stream error', { Z_STREAM_ERROR (-2) }
'data error', { Z_DATA_ERROR (-3) }
'insufficient memory', { Z_MEM_ERROR (-4) }
'buffer error', { Z_BUF_ERROR (-5) }
'incompatible version',{ Z_VERSION_ERROR (-6) }
'');
const
z_verbose : int = 1;
{$IFDEF DEBUG}
procedure z_error (m : string);
{$ENDIF}
implementation
function zError(err : int) : string;
begin
zError := String(z_errmsg[Z_NEED_DICT-err]);
end;
function zlibVersion : string;
begin
zlibVersion := ZLIB_VERSION;
end;
procedure z_error (m : string);
begin
WriteLn(output, m);
Write('Zlib - Halt...');
ReadLn;
Halt(1);
end;
{
procedure Assert(cond : boolean; msg : string);
begin
if not cond then
z_error(msg);
end;
}
procedure Trace(x : string);
begin
WriteLn(x);
end;
procedure Tracev(x : string);
begin
if (z_verbose>0) then
WriteLn(x);
end;
procedure Tracevv(x : string);
begin
if (z_verbose>1) then
WriteLn(x);
end;
procedure Tracevvv(x : string);
begin
if (z_verbose>2) then
WriteLn(x);
end;
procedure Tracec(c : boolean; x : string);
begin
if (z_verbose>0) and (c) then
WriteLn(x);
end;
procedure Tracecv(c : boolean; x : string);
begin
if (z_verbose>1) and c then
WriteLn(x);
end;
function ZALLOC (var strm : z_stream; items : uInt; size : uInt) : voidpf;
begin
ZALLOC := strm.zalloc(strm.opaque, items, size);
end;
procedure ZFREE (var strm : z_stream; ptr : voidpf);
begin
strm.zfree(strm.opaque, ptr);
end;
procedure TRY_FREE (var strm : z_stream; ptr : voidpf);
begin
{if @strm <> Z_NULL then}
strm.zfree(strm.opaque, ptr);
end;
end.

1174
contrib/fundamentals/ZLib/paszlib/gzIO.pas Normal file
View File

File diff suppressed because it is too large Load Diff

225
contrib/fundamentals/ZLib/paszlib/infutil.pas Normal file
View File

@@ -0,0 +1,225 @@
Unit infutil;
{ types and macros common to blocks and codes
Copyright (C) 1995-1998 Mark Adler
WARNING: this file should *not* be used by applications. It is
part of the implementation of the compression library and is
subject to change.
Pascal tranlastion
Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
Modifiied 02/2003 by Sergey A. Galin for Delphi 6+ and Kylix compatibility.
See README in directory above for more information.
}
interface
{$I zconf.inc}
uses
ZUtil, gZlib;
{ copy as much as possible from the sliding window to the output area }
function inflate_flush(var s : inflate_blocks_state;
var z : z_stream;
r : int) : int;
{ And'ing with mask[n] masks the lower n bits }
const
inflate_mask : array[0..17-1] of uInt = (
$0000,
$0001, $0003, $0007, $000f, $001f, $003f, $007f, $00ff,
$01ff, $03ff, $07ff, $0fff, $1fff, $3fff, $7fff, $ffff);
{procedure GRABBITS(j : int);}
{procedure DUMPBITS(j : int);}
{procedure NEEDBITS(j : int);}
implementation
{ macros for bit input with no checking and for returning unused bytes }
procedure GRABBITS(j : int);
begin
{while (k < j) do
begin
Dec(z^.avail_in);
Inc(z^.total_in);
b := b or (uLong(z^.next_in^) shl k);
Inc(z^.next_in);
Inc(k, 8);
end;}
end;
procedure DUMPBITS(j : int);
begin
{b := b shr j;
Dec(k, j);}
end;
procedure NEEDBITS(j : int);
begin
(*
while (k < j) do
begin
{NEEDBYTE;}
if (n <> 0) then
r :=Z_OK
else
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, LongInt(p)-LongInt(z.next_in));
z.next_in := p;
s.write := q;
result := inflate_flush(s,z,r);
exit;
end;
Dec(n);
b := b or (uLong(p^) shl k);
Inc(p);
Inc(k, 8);
end;
*)
end;
procedure NEEDOUT;
begin
(*
if (m = 0) then
begin
{WRAP}
if (q = s.zend) and (s.read <> s.window) then
begin
q := s.window;
if LongInt(q) < LongInt(s.read) then
m := uInt(LongInt(s.read)-LongInt(q)-1)
else
m := uInt(LongInt(s.zend)-LongInt(q));
end;
if (m = 0) then
begin
{FLUSH}
s.write := q;
r := inflate_flush(s,z,r);
q := s.write;
if LongInt(q) < LongInt(s.read) then
m := uInt(LongInt(s.read)-LongInt(q)-1)
else
m := uInt(LongInt(s.zend)-LongInt(q));
{WRAP}
if (q = s.zend) and (s.read <> s.window) then
begin
q := s.window;
if LongInt(q) < LongInt(s.read) then
m := uInt(LongInt(s.read)-LongInt(q)-1)
else
m := uInt(LongInt(s.zend)-LongInt(q));
end;
if (m = 0) then
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, LongInt(p)-LongInt(z.next_in));
z.next_in := p;
s.write := q;
result := inflate_flush(s,z,r);
exit;
end;
end;
end;
r := Z_OK;
*)
end;
{ copy as much as possible from the sliding window to the output area }
function inflate_flush(var s : inflate_blocks_state;
var z : z_stream;
r : int) : int;
var
n : uInt;
p : pBytef;
q : pBytef;
begin
{ local copies of source and destination pointers }
p := z.next_out;
q := s.read;
{ compute number of bytes to copy as far as end of window }
if ptr2int(q) <= ptr2int(s.write) then
n := uInt(ptr2int(s.write) - ptr2int(q))
else
n := uInt(ptr2int(s.zend) - ptr2int(q));
if (n > z.avail_out) then
n := z.avail_out;
if (n <> 0) and (r = Z_BUF_ERROR) then
r := Z_OK;
{ update counters }
Dec(z.avail_out, n);
Inc(z.total_out, n);
{ update check information }
if Assigned(s.checkfn) then
begin
s.check := s.checkfn(s.check, q, n);
z.adler := s.check;
end;
{ copy as far as end of window }
zmemcpy(p, q, n);
Inc(p, n);
Inc(q, n);
{ see if more to copy at beginning of window }
if (q = s.zend) then
begin
{ wrap pointers }
q := s.window;
if (s.write = s.zend) then
s.write := s.window;
{ compute bytes to copy }
n := uInt(ptr2int(s.write) - ptr2int(q));
if (n > z.avail_out) then
n := z.avail_out;
if (n <> 0) and (r = Z_BUF_ERROR) then
r := Z_OK;
{ update counters }
Dec( z.avail_out, n);
Inc( z.total_out, n);
{ update check information }
if Assigned(s.checkfn) then
begin
s.check := s.checkfn(s.check, q, n);
z.adler := s.check;
end;
{ copy }
zmemcpy(p, q, n);
Inc(p, n);
Inc(q, n);
end;
{ update pointers }
z.next_out := p;
s.read := q;
{ done }
inflate_flush := r;
end;
end.

251
contrib/fundamentals/ZLib/paszlib/minigzip.pas Normal file
View File

@@ -0,0 +1,251 @@
program minigzip;
{
minigzip.c -- simulate gzip using the zlib compression library
Copyright (C) 1995-1998 Jean-loup Gailly.
minigzip is a minimal implementation of the gzip utility. This is
only an example of using zlib and isn't meant to replace the
full-featured gzip. No attempt is made to deal with file systems
limiting names to 14 or 8+3 characters, etc... Error checking is
very limited. So use minigzip only for testing; use gzip for the
real thing. On MSDOS, use only on file names without extension
or in pipe mode.
Pascal tranlastion based on code contributed by Francisco Javier Crespo
Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
}
uses
{$IFDEF VER80}
WinCrt,
{$ENDIF}
gzio, zutil;
const
BUFLEN = 16384 ;
GZ_SUFFIX = '.gz' ;
{$DEFINE MAXSEF_64K}
var
buf : packed array [0..BUFLEN-1] of byte; { Global uses BSS instead of stack }
prog : string;
{ ERROR =====================================================================
Display error message and exit
============================================================================}
procedure error (msg:string);
begin
writeln (prog,': ',msg);
halt(1);
end;
{ GZ_COMPRESS ===============================================================
Compress input to output then close both files
============================================================================}
procedure gz_compress (var infile:file; outfile:gzFile);
var
len : uInt;
ioerr : integer;
err : int;
begin
while true do begin
{$I-}
blockread (infile, buf, BUFLEN, len);
{$I+}
ioerr := IOResult;
if (ioerr <> 0) then begin
writeln ('read error: ',ioerr);
halt(1);
end;
if (len = 0) then break;
if (gzwrite (outfile, @buf, len) <> len)
then error (gzerror (outfile, err));
end; {WHILE}
close (infile);
if (gzclose (outfile) <> 0{Z_OK})
then error ('gzclose error');
end;
{ GZ_UNCOMPRESS =============================================================
Uncompress input to output then close both files
============================================================================}
procedure gz_uncompress (infile:gzFile; var outfile:file);
var
len : int;
written : uInt;
ioerr : integer;
err : int;
begin
while true do begin
len := gzread (infile, @buf, BUFLEN);
if (len < 0)
then error (gzerror (infile, err));
if (len = 0)
then break;
{$I-}
blockwrite (outfile, buf, len, written);
{$I+}
if (written <> len)
then error ('write error');
end; {WHILE}
{$I-}
close (outfile);
{$I+}
ioerr := IOResult;
if (ioerr <> 0) then begin
writeln ('close error: ',ioerr);
halt(1);
end;
if (gzclose (infile) <> 0{Z_OK})
then error ('gzclose error');
end;
{ FILE_COMPRESS =============================================================
Compress the given file:
create a corresponding .gz file and remove the original
============================================================================}
procedure file_compress (filename:string; mode:string);
var
infile : file;
outfile : gzFile;
ioerr : integer;
outname : string;
begin
Assign (infile, filename);
{$I-}
Reset (infile,1);
{$I+}
ioerr := IOResult;
if (ioerr <> 0) then begin
writeln ('open error: ',ioerr);
halt(1);
end;
outname := filename + GZ_SUFFIX;
outfile := gzopen (outname, mode);
if (outfile = NIL) then begin
writeln (prog,': can''t gzopen ',outname);
halt(1);
end;
gz_compress(infile, outfile);
erase (infile);
end;
{ FILE_UNCOMPRESS ===========================================================
Uncompress the given file and remove the original
============================================================================}
procedure file_uncompress (filename:string);
var
inname : string;
outname : string;
infile : gzFile;
outfile : file;
ioerr : integer;
len : integer;
begin
len := Length(filename);
if (copy(filename,len-2,3) = GZ_SUFFIX) then begin
inname := filename;
outname := copy(filename,0,len-3);
end
else begin
inname := filename + GZ_SUFFIX;
outname := filename;
end;
infile := gzopen (inname, 'r');
if (infile = NIL) then begin
writeln (prog,': can''t gzopen ',inname);
halt(1);
end;
Assign (outfile, outname);
{$I-}
Rewrite (outfile,1);
{$I+}
ioerr := IOResult;
if (ioerr <> 0) then begin
writeln ('open error: ',ioerr);
halt(1);
end;
gz_uncompress (infile, outfile);
{ erase (infile); }
end;
{ MINIGZIP =================================================================}
var
uncompr : boolean;
outmode : string[20];
i : integer;
option : string;
begin
uncompr := false;
outmode := 'w6 ';
prog := ParamStr(0);
if (ParamCount = 0) then begin
writeln ('Error: STDIO/STDOUT not supported yet');
writeln;
writeln ('Usage: minigzip [-d] [-f] [-h] [-1 to -9] <file>');
writeln (' -d : decompress');
writeln (' -f : compress with Z_FILTERED');
writeln (' -h : compress with Z_HUFFMAN_ONLY');
writeln (' -1 to -9 : compression level');
exit;
end;
for i:=1 to ParamCount do begin
option := ParamStr(i);
if (option = '-d') then uncompr := true;
if (option = '-f') then outmode[3] := 'f';
if (option = '-h') then outmode[3] := 'h';
if (option[1] = '-') and (option[2] >= '1') and (option[2] <= '9')
then outmode[2] := option[2];
end;
if (uncompr = true)
then file_uncompress (ParamStr(ParamCount))
else file_compress (ParamStr(ParamCount), outmode);
end.

597
contrib/fundamentals/ZLib/paszlib/minizip/MiniUnz.pas Normal file
View File

@@ -0,0 +1,597 @@
Program MiniUnz;
{ mini unzip demo package by Gilles Vollant
Usage : miniunz [-exvlo] file.zip [file_to_extract]
-l or -v list the content of the zipfile.
-e extract a specific file or all files if [file_to_extract] is missing
-x like -e, but extract without path information
-o overwrite an existing file without warning
Pascal tranlastion
Copyright (C) 2000 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
}
{$ifdef WIN32}
{$define Delphi}
{$ifndef FPC}
{$define Delphi32}
{$endif}
{$endif}
uses
{$ifdef Delphi}
SysUtils, Windows,
{$else}
WinDos, strings,
{$endif}
zutil,
gzlib, ziputils,
unzip;
const
CASESENSITIVITY = 0;
WRITEBUFFERSIZE = 8192;
{ change_file_date : change the date/time of a file
filename : the filename of the file where date/time must be modified
dosdate : the new date at the MSDos format (4 bytes)
tmu_date : the SAME new date at the tm_unz format }
procedure change_file_date(const filename : PChar;
dosdate : uLong;
tmu_date : tm_unz);
{$ifdef Delphi32}
var
hFile : THandle;
ftm,ftLocal,ftCreate,ftLastAcc,ftLastWrite : TFileTime;
begin
hFile := CreateFile(filename,GENERIC_READ or GENERIC_WRITE,
0,NIL,OPEN_EXISTING,0,0);
GetFileTime(hFile, @ftCreate, @ftLastAcc, @ftLastWrite);
DosDateTimeToFileTime(WORD((dosdate shl 16)), WORD(dosdate), ftLocal);
LocalFileTimeToFileTime(ftLocal, ftm);
SetFileTime(hFile,@ftm, @ftLastAcc, @ftm);
CloseHandle(hFile);
end;
{$else}
{$ifdef FPC}
var
hFile : THandle;
ftm,ftLocal,ftCreate,ftLastAcc,ftLastWrite : TFileTime;
begin
hFile := CreateFile(filename,GENERIC_READ or GENERIC_WRITE,
0,NIL,OPEN_EXISTING,0,0);
GetFileTime(hFile, @ftCreate, @ftLastAcc, @ftLastWrite);
DosDateTimeToFileTime(WORD((dosdate shl 16)), WORD(dosdate), @ftLocal);
LocalFileTimeToFileTime(ftLocal, @ftm);
SetFileTime(hFile,ftm, ftLastAcc, ftm);
CloseHandle(hFile);
end;
{$else} { msdos }
var
f: file;
begin
Assign(f, filename);
Reset(f, 1); { open file for reading }
{ (Otherwise, close will update time) }
SetFTime(f,dosDate);
Close(f);
end;
{$endif}
{$endif}
{ mymkdir and change_file_date are not 100 % portable
As I don't know well Unix, I wait feedback for the unix portion }
function mymkdir(dirname : PChar) : boolean;
var
S : string;
begin
S := StrPas(dirname);
{$I-}
mkdir(S);
mymkdir := IOresult = 0;
end;
function makedir (newdir : PChar) : boolean;
var
buffer : PChar;
p : PChar;
len : int;
var
hold : char;
begin
makedir := false;
len := strlen(newdir);
if (len <= 0) then
exit;
buffer := PChar(zcalloc (NIL, len+1, 1));
strcopy(buffer,newdir);
if (buffer[len-1] = '/') then
buffer[len-1] := #0;
if mymkdir(buffer) then
begin
if Assigned(buffer) then
zcfree(NIL, buffer);
makedir := true;
exit;
end;
p := buffer+1;
while true do
begin
while( (p^<>#0) and (p^ <> '\') and (p^ <> '/') ) do
Inc(p);
hold := p^;
p^ := #0;
if (not mymkdir(buffer)) {and (errno = ENOENT)} then
begin
WriteLn('couldn''t create directory ',buffer);
if Assigned(buffer) then
zcfree(NIL, buffer);
exit;
end;
if (hold = #0) then
break;
p^ := hold;
Inc(p);
end;
if Assigned(buffer) then
zcfree(NIL, buffer);
makedir := true;
end;
procedure do_banner;
begin
WriteLn('MiniUnz 0.15, demo package written by Gilles Vollant');
WriteLn('Pascal port by Jacques Nomssi Nzali');
WriteLn('more info at http://wwww.tu-chemnitz.de/~nomssi/paszlib.html');
WriteLn;
end;
procedure do_help;
begin
WriteLn('Usage : miniunz [-exvlo] file.zip [file_to_extract]');
WriteLn;
end;
function LeadingZero(w : Word) : String;
var
s : String;
begin
Str(w:0,s);
if Length(s) = 1 then
s := '0' + s;
LeadingZero := s;
end;
function HexToStr(w : long) : string;
const
ByteToChar : array[0..$F] of char ='0123456789ABCDEF';
var
s : string;
i : int;
x : long;
begin
s := '';
x := w;
for i := 0 to 3 do
begin
s := ByteToChar[Byte(x) shr 4] + ByteToChar[Byte(x) and $F] + s;
x := x shr 8;
end;
HexToStr := s;
end;
function do_list(uf : unzFile) : int;
var
i : uLong;
gi : unz_global_info;
err : int;
var
filename_inzip : array[0..255] of char;
file_info : unz_file_info;
ratio : uLong;
string_method : string[255];
var
iLevel : uInt;
begin
err := unzGetGlobalInfo(uf, gi);
if (err <> UNZ_OK) then
WriteLn('error ',err,' with zipfile in unzGetGlobalInfo');
WriteLn(' Length Method Size Ratio Date Time CRC-32 Name');
WriteLn(' ------ ------ ---- ----- ---- ---- ------ ----');
for i := 0 to gi.number_entry-1 do
begin
ratio := 0;
err := unzGetCurrentFileInfo(uf, @file_info, filename_inzip, sizeof(filename_inzip),NIL,0,NIL,0);
if (err <> UNZ_OK) then
begin
WriteLn('error ',err,' with zipfile in unzGetCurrentFileInfo');
break;
end;
if (file_info.uncompressed_size>0) then
ratio := (file_info.compressed_size*100) div file_info.uncompressed_size;
if (file_info.compression_method=0) then
string_method := 'Stored'
else
if (file_info.compression_method=Z_DEFLATED) then
begin
iLevel := uInt((file_info.flag and $06) div 2);
Case iLevel of
0: string_method := 'Defl:N';
1: string_method := 'Defl:X';
2,3: string_method := 'Defl:F'; { 2:fast , 3 : extra fast}
else
string_method := 'Unkn. ';
end;
end;
WriteLn(file_info.uncompressed_size:7, ' ',
string_method:6, ' ',
file_info.compressed_size:7, ' ',
ratio:3,'% ', LeadingZero(uLong(file_info.tmu_date.tm_mon)+1),'-',
LeadingZero(uLong(file_info.tmu_date.tm_mday)):2,'-',
LeadingZero(uLong(file_info.tmu_date.tm_year mod 100)):2,' ',
LeadingZero(uLong(file_info.tmu_date.tm_hour)),':',
LeadingZero(uLong(file_info.tmu_date.tm_min)),' ',
HexToStr(uLong(file_info.crc)),' ',
filename_inzip);
if ((i+1)<gi.number_entry) then
begin
err := unzGoToNextFile(uf);
if (err <> UNZ_OK) then
begin
WriteLn('error ',err,' with zipfile in unzGoToNextFile');
break;
end;
end;
end;
do_list := 0;
end;
function do_extract_currentfile(
uf : unzFile;
const popt_extract_without_path : int;
var popt_overwrite : int) : int;
var
filename_inzip : packed array[0..255] of char;
filename_withoutpath : PChar;
p: PChar;
err : int;
fout : FILEptr;
buf : pointer;
size_buf : uInt;
file_info : unz_file_info;
var
write_filename : PChar;
skip : int;
var
rep : char;
ftestexist : FILEptr;
var
answer : string[127];
var
c : char;
begin
fout := NIL;
err := unzGetCurrentFileInfo(uf, @file_info, filename_inzip,
sizeof(filename_inzip), NIL, 0, NIL,0);
if (err <> UNZ_OK) then
begin
WriteLn('error ',err, ' with zipfile in unzGetCurrentFileInfo');
do_extract_currentfile := err;
exit;
end;
size_buf := WRITEBUFFERSIZE;
buf := zcalloc (NIL, size_buf, 1);
if (buf = NIL) then
begin
WriteLn('Error allocating memory');
do_extract_currentfile := UNZ_INTERNALERROR;
exit;
end;
filename_withoutpath := filename_inzip;
p := filename_withoutpath;
while (p^ <> #0) do
begin
if (p^='/') or (p^='\') then
filename_withoutpath := p+1;
Inc(p);
end;
if (filename_withoutpath^=#0) then
begin
if (popt_extract_without_path=0) then
begin
WriteLn('creating directory: ',filename_inzip);
mymkdir(filename_inzip);
end;
end
else
begin
skip := 0;
if (popt_extract_without_path=0) then
write_filename := filename_inzip
else
write_filename := filename_withoutpath;
err := unzOpenCurrentFile(uf);
if (err <> UNZ_OK) then
WriteLn('error ',err,' with zipfile in unzOpenCurrentFile');
if ((popt_overwrite=0) and (err=UNZ_OK)) then
begin
rep := #0;
ftestexist := fopen(write_filename,fopenread);
if (ftestexist <> NIL) then
begin
fclose(ftestexist);
repeat
Write('The file ',write_filename,
' exist. Overwrite ? [y]es, [n]o, [A]ll: ');
ReadLn(answer);
rep := answer[1] ;
if ((rep>='a') and (rep<='z')) then
Dec(rep, $20);
until (rep = 'Y') or (rep = 'N') or (rep = 'A');
end;
if (rep = 'N') then
skip := 1;
if (rep = 'A') then
popt_overwrite := 1;
end;
if (skip=0) and (err=UNZ_OK) then
begin
fout := fopen(write_filename,fopenwrite);
{ some zipfile don't contain directory alone before file }
if (fout=NIL) and (popt_extract_without_path=0) and
(filename_withoutpath <> PChar(@filename_inzip)) then
begin
c := (filename_withoutpath-1)^;
(filename_withoutpath-1)^ := #0;
makedir(write_filename);
(filename_withoutpath-1)^ := c;
fout := fopen(write_filename, fopenwrite);
end;
if (fout=NIL) then
WriteLn('error opening ',write_filename);
end;
if (fout <> NIL) then
begin
WriteLn(' extracting: ',write_filename);
repeat
err := unzReadCurrentFile(uf,buf,size_buf);
if (err<0) then
begin
WriteLn('error ',err,' with zipfile in unzReadCurrentFile');
break;
end;
if (err>0) then
begin
if (fwrite(buf,err,1,fout) <> 1) then
begin
WriteLn('error in writing extracted file');
err := UNZ_ERRNO;
break;
end;
end;
until (err=0);
fclose(fout);
if (err=0) then
change_file_date(write_filename,file_info.dosDate,
file_info.tmu_date);
end;
if (err=UNZ_OK) then
begin
err := unzCloseCurrentFile (uf);
if (err <> UNZ_OK) then
WriteLn('error ',err,' with zipfile in unzCloseCurrentFile')
else
unzCloseCurrentFile(uf); { don't lose the error }
end;
end;
if buf <> NIL then
zcfree(NIL, buf);
do_extract_currentfile := err;
end;
function do_extract(uf : unzFile;
opt_extract_without_path : int;
opt_overwrite : int) : int;
var
i : uLong;
gi : unz_global_info;
err : int;
begin
err := unzGetGlobalInfo (uf, gi);
if (err <> UNZ_OK) then
WriteLn('error ',err,' with zipfile in unzGetGlobalInfo ');
for i:=0 to gi.number_entry-1 do
begin
if (do_extract_currentfile(uf, opt_extract_without_path,
opt_overwrite) <> UNZ_OK) then
break;
if ((i+1)<gi.number_entry) then
begin
err := unzGoToNextFile(uf);
if (err <> UNZ_OK) then
begin
WriteLn('error ',err,' with zipfile in unzGoToNextFile');
break;
end;
end;
end;
do_extract := 0;
end;
function do_extract_onefile(uf : unzFile;
const filename : PChar;
opt_extract_without_path : int;
opt_overwrite : int) : int;
begin
if (unzLocateFile(uf,filename,CASESENSITIVITY) <> UNZ_OK) then
begin
WriteLn('file ',filename,' not found in the zipfile');
do_extract_onefile := 2;
exit;
end;
if (do_extract_currentfile(uf, opt_extract_without_path,
opt_overwrite) = UNZ_OK) then
do_extract_onefile := 0
else
do_extract_onefile := 1;
end;
{ -------------------------------------------------------------------- }
function main : int;
const
zipfilename : PChar = NIL;
filename_to_extract : PChar = NIL;
var
i : int;
opt_do_list : int;
opt_do_extract : int;
opt_do_extract_withoutpath : int;
opt_overwrite : int;
filename_try : array[0..512-1] of char;
uf : unzFile;
var
p : int;
pstr : string[255];
c : char;
begin
opt_do_list := 0;
opt_do_extract := 1;
opt_do_extract_withoutpath := 0;
opt_overwrite := 0;
uf := NIL;
do_banner;
if (ParamCount=0) then
begin
do_help;
Halt(0);
end
else
begin
for i := 1 to ParamCount do
begin
pstr := ParamStr(i);
if pstr[1]='-' then
begin
for p := 2 to Length(pstr) do
begin
c := pstr[p];
Case UpCase(c) of
'L',
'V' : opt_do_list := 1;
'X' : opt_do_extract := 1;
'E' : begin
opt_do_extract := 1;
opt_do_extract_withoutpath := 1;
end;
'O' : opt_overwrite := 1;
end;
end;
end
else
begin
pstr := pstr + #0;
if (zipfilename = NIL) then
zipfilename := StrNew(PChar(@pstr[1]))
else
if (filename_to_extract=NIL) then
filename_to_extract := StrNew(PChar(@pstr[1]));
end;
end; { for }
end;
if (zipfilename <> NIL) then
begin
strcopy(filename_try,zipfilename);
uf := unzOpen(zipfilename);
if (uf = NIL) then
begin
strcat(filename_try,'.zip');
uf := unzOpen(filename_try);
end;
end;
if (uf = NIL) then
begin
WriteLn('Cannot open ',zipfilename,' or ',zipfilename,'.zip');
Halt(1);
end;
WriteLn(filename_try,' opened');
if (opt_do_list=1) then
begin
main := do_list(uf);
exit;
end
else
if (opt_do_extract=1) then
begin
if (filename_to_extract = NIL) then
begin
main := do_extract(uf,opt_do_extract_withoutpath,opt_overwrite);
exit;
end
else
begin
main := do_extract_onefile(uf,filename_to_extract,
opt_do_extract_withoutpath,opt_overwrite);
exit;
end;
end;
unzCloseCurrentFile(uf);
strDispose(zipfilename);
strDispose(filename_to_extract);
main := 0;
end;
begin
main;
Write('Done...');
Readln;
end.

344
contrib/fundamentals/ZLib/paszlib/minizip/MiniZip.pas Normal file
View File

@@ -0,0 +1,344 @@
Program MiniZip;
{ minizip demo package by Gilles Vollant
Usage : minizip [-o] file.zip [files_to_add]
a file.zip file is created, all files listed in [files_to_add] are added
to the new .zip file.
-o an existing .zip file with be overwritten without warning
Pascal tranlastion
Copyright (C) 2000 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
}
{$ifdef WIN32}
{$define Delphi}
{$ifndef FPC}
{$define Delphi32}
{$endif}
{$endif}
uses
{$ifdef Delphi}
SysUtils, Windows,
{$else}
WinDos, strings,
{$endif}
zutil, gzlib, ziputils, zip;
const
WRITEBUFFERSIZE = Z_BUFSIZE;
MAXFILENAME = Z_MAXFILENAMEINZIP;
{$ifdef Delphi32}
function filetime(f : PChar; { name of file to get info on }
var tmzip : tm_zip; { return value: access, modific. and creation times }
var dt : uLong) : uLong; { dostime }
var
ret : int;
var
ftLocal : TFileTime; // FILETIME;
hFind : THandle; // HANDLE;
ff32 : TWIN32FindData; // WIN32_FIND_DATA;
begin
ret := 0;
hFind := FindFirstFile(f, ff32);
if (hFind <> INVALID_HANDLE_VALUE) then
begin
FileTimeToLocalFileTime(ff32.ftLastWriteTime,ftLocal);
FileTimeToDosDateTime(ftLocal,LongRec(dt).hi,LongRec(dt).lo);
FindClose(hFind);
ret := 1;
end;
filetime := ret;
end;
{$else}
{$ifdef FPC}
function filetime(f : PChar; { name of file to get info on }
var tmzip : tm_zip; { return value: access, modific. and creation times }
var dt : uLong) : uLong; { dostime }
var
ret : int;
var
ftLocal : TFileTime; // FILETIME;
hFind : THandle; // HANDLE;
ff32 : TWIN32FindData; // WIN32_FIND_DATA;
begin
ret := 0;
hFind := FindFirstFile(f, @ff32);
if (hFind <> INVALID_HANDLE_VALUE) then
begin
FileTimeToLocalFileTime(ff32.ftLastWriteTime,@ftLocal);
FileTimeToDosDateTime(ftLocal,@LongRec(dt).hi,@LongRec(dt).lo);
FindClose(hFind);
ret := 1;
end;
filetime := ret;
end;
{$else}
function filetime(f : PChar; { name of file to get info on }
var tmzip : tm_zip; { return value: access, modific. and creation times }
var dt : uLong) : uLong; { dostime }
var
fl : file;
yy, mm, dd, dow : Word;
h, m, s, hund : Word; { For GetTime}
dtrec : TDateTime; { For Pack/UnpackTime}
begin
{$i-}
Assign(fl, f);
Reset(fl, 1);
if IOresult = 0 then
begin
GetFTime(fl,dt); { Get creation time }
UnpackTime(dt, dtrec);
Close(fl);
tmzip.tm_sec := dtrec.sec;
tmzip.tm_min := dtrec.min;
tmzip.tm_hour := dtrec.hour;
tmzip.tm_mday := dtrec.day;
tmzip.tm_mon := dtrec.month;
tmzip.tm_year := dtrec.year;
end;
filetime := 0;
end;
{$endif}
{$endif}
function check_exist_file(const filename : PChar) : int;
var
ftestexist : FILE;
ret : int;
begin
ret := 1;
Assign(ftestexist, filename);
{$i-}
reset(ftestexist);
if IOresult <> 0 then
ret := 0
else
system.close(ftestexist);
check_exist_file := ret;
end;
procedure do_banner;
begin
WriteLn('MiniZip 0.15, demo package written by Gilles Vollant');
WriteLn('Pascal port by Jacques Nomssi Nzali');
WriteLn('more info at http://www.tu-chemnitz.de/~nomssi/paszlib.html');
WriteLn;
end;
procedure do_help;
begin
WriteLn('Usage : minizip [-o] file.zip [files_to_add]');
WriteLn;
end;
function main : int;
var
argstr : string;
i : int;
opt_overwrite : int;
opt_compress_level : int;
zipfilenamearg : int;
filename_try : array[0..MAXFILENAME-1] of char;
zipok : int;
err : int;
size_buf : int;
buf : voidp;
var
p : PChar;
c : char;
var
len : int;
dot_found : int;
var
rep : char;
answer : string[128];
var
zf : zipFile;
errclose : int;
var
fin : FILEptr;
size_read : int;
filenameinzip : {const} PChar;
zi : zip_fileinfo;
begin
opt_overwrite := 0;
opt_compress_level := Z_DEFAULT_COMPRESSION;
zipfilenamearg := 0;
err := 0;
main := 0;
do_banner;
if (ParamCount=0) then
begin
do_help;
main := 0;
exit;
end
else
begin
for i:=1 to ParamCount-1+1 do
begin
argstr := ParamStr(i)+#0;
if (argstr[1]='-') then
begin
p := @argstr[1+1]; {const char *p=argv[i]+1;}
while (p^<>#0) do
begin
c := p^;
Inc(p);
if (c='o') or (c='O') then
opt_overwrite := 1;
if (c>='0') and (c<='9') then
opt_compress_level := Byte(c)-Byte('0');
end;
end
else
if (zipfilenamearg = 0) then
zipfilenamearg := i;
end;
end;
size_buf := WRITEBUFFERSIZE;
buf := ALLOC(size_buf);
if (buf=NIL) then
begin
WriteLn('Error allocating memory');
main := ZIP_INTERNALERROR;
exit;
end;
if (zipfilenamearg=0) then
zipok := 0
else
begin
dot_found := 0;
zipok := 1 ;
argstr := ParamStr(zipfilenamearg) + #0;
strcopy(filename_try, PChar(@argstr[1]));
len := strlen(filename_try);
for i:=0 to len-1 do
if (filename_try[i]='.') then
dot_found := 1;
if (dot_found = 0) then
strcat(filename_try,'.zip');
if (opt_overwrite=0) then
if (check_exist_file(filename_try)<>0) then
begin
repeat
WriteLn('The file ',filename_try,
' exist. Overwrite ? [y]es, [n]o : ');
ReadLn(answer);
rep := answer[1] ;
if (rep>='a') and (rep<='z') then
Dec(rep, $20);
until (rep='Y') or (rep='N');
if (rep='N') then
zipok := 0;
end;
end;
if (zipok=1) then
begin
zf := zipOpen(filename_try,0);
if (zf = NIL) then
begin
WriteLn('error opening ', filename_try);
err := ZIP_ERRNO;
end
else
WriteLn('creating ',filename_try);
i := zipfilenamearg+1;
while (i<=ParamCount) and (err=ZIP_OK) do
begin
argstr := ParamStr(i)+#0;
if (argstr[1] <>'-') and (argstr[1] <>'/') then
begin
filenameinzip := PChar(@argstr[1]);
zi.tmz_date.tm_sec := 0;
zi.tmz_date.tm_min := 0;
zi.tmz_date.tm_hour := 0;
zi.tmz_date.tm_mday := 0;
zi.tmz_date.tm_min := 0;
zi.tmz_date.tm_year := 0;
zi.dosDate := 0;
zi.internal_fa := 0;
zi.external_fa := 0;
filetime(filenameinzip,zi.tmz_date,zi.dosDate);
if (opt_compress_level <> 0) then
err := zipOpenNewFileInZip(zf,filenameinzip, @zi,
NIL,0,NIL,0,NIL { comment}, Z_DEFLATED, opt_compress_level)
else
err := zipOpenNewFileInZip(zf,filenameinzip, @zi,
NIL,0,NIL,0,NIL, 0, opt_compress_level);
if (err <> ZIP_OK) then
WriteLn('error in opening ',filenameinzip,' in zipfile')
else
begin
fin := fopen(filenameinzip, fopenread);
if (fin=NIL) then
begin
err := ZIP_ERRNO;
WriteLn('error in opening ',filenameinzip,' for reading');
end;
if (err = ZIP_OK) then
repeat
err := ZIP_OK;
size_read := fread(buf,1,size_buf,fin);
if (size_read < size_buf) then
if feof(fin)=0 then
begin
WriteLn('error in reading ',filenameinzip);
err := ZIP_ERRNO;
end;
if (size_read>0) then
begin
err := zipWriteInFileInZip (zf,buf,size_read);
if (err<0) then
WriteLn('error in writing ',filenameinzip,' in the zipfile');
end;
until (err <> ZIP_OK) or (size_read=0);
fclose(fin);
end;
if (err<0) then
err := ZIP_ERRNO
else
begin
err := zipCloseFileInZip(zf);
if (err<>ZIP_OK) then
WriteLn('error in closing ',filenameinzip,' in the zipfile');
end;
Inc(i);
end; { while }
end; { if }
errclose := zipClose(zf,NIL);
if (errclose <> ZIP_OK) then
WriteLn('error in closing ',filename_try);
end;
TRYFREE(buf); {FreeMem(buf, size_buf);}
end;
begin
main;
Write('Done...');
ReadLn;
end.

1629
contrib/fundamentals/ZLib/paszlib/minizip/UnZip.pas Normal file
View File

File diff suppressed because it is too large Load Diff

831
contrib/fundamentals/ZLib/paszlib/minizip/Zip.pas Normal file
View File

@@ -0,0 +1,831 @@
Unit zip;
{ zip.c -- IO on .zip files using zlib
zip.h -- IO for compress .zip files using zlib
Version 0.15 alpha, Mar 19th, 1998,
Copyright (C) 1998 Gilles Vollant
This package allows to create .ZIP file, compatible with PKZip 2.04g
WinZip, InfoZip tools and compatible.
Encryption and multi volume ZipFile (span) are not supported.
Old compressions used by old PKZip 1.x are not supported
For decompression of .zip files, look at unzip.pas
Pascal tranlastion
Copyright (C) 2000 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt }
interface
{$ifdef WIN32}
{$define Delphi}
{$endif}
uses
zutil,
gzLib,
ziputils;
const
ZIP_OK = (0);
ZIP_ERRNO = (Z_ERRNO);
ZIP_PARAMERROR = (-102);
ZIP_INTERNALERROR = (-104);
(*
{ tm_zip contain date/time info }
type
tm_zip = record
tm_sec : uInt; { seconds after the minute - [0,59] }
tm_min : uInt; { minutes after the hour - [0,59] }
tm_hour : uInt; { hours since midnight - [0,23] }
tm_mday : uInt; { day of the month - [1,31] }
tm_mon : uInt; { months since January - [0,11] }
tm_year : uInt; { years - [1980..2044] }
end;
*)
type
zip_fileinfo = record
tmz_date : tm_zip; { date in understandable format }
dosDate : uLong; { if dos_date = 0, tmu_date is used }
{ flag : uLong; } { general purpose bit flag 2 bytes }
internal_fa : uLong; { internal file attributes 2 bytes }
external_fa : uLong; { external file attributes 4 bytes }
end;
zip_fileinfo_ptr = ^zip_fileinfo;
function zipOpen (const pathname : PChar; append : int) : zipFile; {ZEXPORT}
{ Create a zipfile.
pathname contain on Windows NT a filename like "c:\\zlib\\zlib111.zip" or on
an Unix computer "zlib/zlib111.zip".
if the file pathname exist and append=1, the zip will be created at the end
of the file. (useful if the file contain a self extractor code)
If the zipfile cannot be opened, the return value is NIL.
Else, the return value is a zipFile Handle, usable with other function
of this zip package. }
function zipOpenNewFileInZip(afile : zipFile;
{const} filename : PChar;
const zipfi : zip_fileinfo_ptr;
const extrafield_local : voidp;
size_extrafield_local : uInt;
const extrafield_global : voidp;
size_extrafield_global : uInt;
const comment : PChar;
method : int;
level : int): int; {ZEXPORT}
{ Open a file in the ZIP for writing.
filename : the filename in zip (if NIL, '-' without quote will be used
zipfi^ contain supplemental information
if extrafield_local<>NIL and size_extrafield_local>0, extrafield_local
contains the extrafield data the the local header
if extrafield_global<>NIL and size_extrafield_global>0, extrafield_global
contains the extrafield data the the local header
if comment <> NIL, comment contain the comment string
method contain the compression method (0 for store, Z_DEFLATED for deflate)
level contain the level of compression (can be Z_DEFAULT_COMPRESSION) }
function zipWriteInFileInZip (afile : zipFile;
const buf : voidp;
len : unsigned) : int; {ZEXPORT}
{ Write data in the zipfile }
function zipCloseFileInZip (afile : zipFile): int; {ZEXPORT}
{ Close the current file in the zipfile }
function zipClose (afile : zipFile; const global_comment : PChar): int; {ZEXPORT}
{ Close the zipfile }
implementation
uses
{$ifdef Delphi}
SysUtils,
{$else}
strings,
{$endif}
zDeflate, crc;
const
VERSIONMADEBY = ($0); { platform depedent }
const
zip_copyright : PChar = ' zip 0.15 Copyright 1998 Gilles Vollant ';
const
SIZEDATA_INDATABLOCK = (4096-(4*4));
LOCALHEADERMAGIC = $04034b50;
{CENTRALHEADERMAGIC = $02014b50;}
ENDHEADERMAGIC = $06054b50;
FLAG_LOCALHEADER_OFFSET = $06;
CRC_LOCALHEADER_OFFSET = $0e;
SIZECENTRALHEADER = $2e; { 46 }
type
linkedlist_datablock_internal_ptr = ^linkedlist_datablock_internal;
linkedlist_datablock_internal = record
next_datablock : linkedlist_datablock_internal_ptr;
avail_in_this_block : uLong;
filled_in_this_block : uLong;
unused : uLong; { for future use and alignement }
data : array[0..SIZEDATA_INDATABLOCK-1] of byte;
end;
type
linkedlist_data = record
first_block : linkedlist_datablock_internal_ptr;
last_block : linkedlist_datablock_internal_ptr;
end;
linkedlist_data_ptr = ^linkedlist_data;
type
curfile_info = record
stream : z_stream; { zLib stream structure for inflate }
stream_initialised : boolean; { TRUE is stream is initialised }
pos_in_buffered_data : uInt; { last written byte in buffered_data }
pos_local_header : uLong; { offset of the local header of the file
currenty writing }
central_header : PChar; { central header data for the current file }
size_centralheader : uLong; { size of the central header for cur file }
flag : uLong; { flag of the file currently writing }
method : int; { compression method of file currenty wr.}
buffered_data : array[0..Z_BUFSIZE-1] of byte;{ buffer contain compressed data to be written}
dosDate : uLong;
crc32 : uLong;
end;
type
zip_internal = record
filezip : FILEptr;
central_dir : linkedlist_data; { datablock with central dir in construction}
in_opened_file_inzip : boolean; { TRUE if a file in the zip is currently writ.}
ci : curfile_info; { info on the file curretly writing }
begin_pos : uLong; { position of the beginning of the zipfile }
number_entry : uLong;
end;
zip_internal_ptr = ^zip_internal;
function allocate_new_datablock : linkedlist_datablock_internal_ptr;
var
ldi : linkedlist_datablock_internal_ptr;
begin
ldi := linkedlist_datablock_internal_ptr( ALLOC(sizeof(linkedlist_datablock_internal)) );
if (ldi<>NIL) then
begin
ldi^.next_datablock := NIL ;
ldi^.filled_in_this_block := 0 ;
ldi^.avail_in_this_block := SIZEDATA_INDATABLOCK ;
end;
allocate_new_datablock := ldi;
end;
procedure free_datablock(ldi : linkedlist_datablock_internal_ptr);
var
ldinext : linkedlist_datablock_internal_ptr;
begin
while (ldi<>NIL) do
begin
ldinext := ldi^.next_datablock;
TRYFREE(ldi);
ldi := ldinext;
end;
end;
procedure init_linkedlist(var ll : linkedlist_data);
begin
ll.last_block := NIL;
ll.first_block := NIL;
end;
procedure free_linkedlist(var ll : linkedlist_data);
begin
free_datablock(ll.first_block);
ll.last_block := NIL;
ll.first_block := NIL;
end;
function add_data_in_datablock(ll : linkedlist_data_ptr;
const buf : voidp;
len : uLong) : int;
var
ldi : linkedlist_datablock_internal_ptr;
from_copy : {const} pBytef ;
var
copy_this : uInt;
i : uInt;
to_copy : pBytef;
begin
if (ll=NIL) then
begin
add_data_in_datablock := ZIP_INTERNALERROR;
exit;
end;
if (ll^.last_block = NIL) then
begin
ll^.last_block := allocate_new_datablock;
ll^.first_block := ll^.last_block;
if (ll^.first_block = NIL) then
begin
add_data_in_datablock := ZIP_INTERNALERROR;
exit;
end;
end;
ldi := ll^.last_block;
from_copy := pBytef(buf);
while (len>0) do
begin
if (ldi^.avail_in_this_block=0) then
begin
ldi^.next_datablock := allocate_new_datablock;
if (ldi^.next_datablock = NIL) then
begin
add_data_in_datablock := ZIP_INTERNALERROR;
exit;
end;
ldi := ldi^.next_datablock ;
ll^.last_block := ldi;
end;
if (ldi^.avail_in_this_block < len) then
copy_this := uInt(ldi^.avail_in_this_block)
else
copy_this := uInt(len);
to_copy := @(ldi^.data[ldi^.filled_in_this_block]);
for i :=0 to copy_this-1 do
pzByteArray(to_copy)^[i] := pzByteArray(from_copy)^[i];
Inc(ldi^.filled_in_this_block, copy_this);
Dec(ldi^.avail_in_this_block, copy_this);
Inc(from_copy, copy_this);
Dec(len, copy_this);
end;
add_data_in_datablock := ZIP_OK;
end;
function write_datablock(fout : FILEptr; ll : linkedlist_data_ptr) : int;
var
ldi : linkedlist_datablock_internal_ptr;
begin
ldi := ll^.first_block;
while (ldi<>NIL) do
begin
if (ldi^.filled_in_this_block > 0) then
begin
if (fwrite(@ldi^.data,uInt(ldi^.filled_in_this_block),1,fout)<>1) then
begin
write_datablock := ZIP_ERRNO;
exit;
end;
end;
ldi := ldi^.next_datablock;
end;
write_datablock := ZIP_OK;
end;
{**************************************************************************}
{ ===========================================================================
Outputs a long in LSB order to the given file
nbByte = 1, 2 or 4 (byte, short or long) }
function ziplocal_putValue (afile : FILEptr; x : uLong; nbByte : int) : int;
var
buf : array[0..4-1] of byte;
n : int;
begin
for n := 0 to nbByte-1 do
begin
buf[n] := Byte(x and $ff);
x := x shr 8;
end;
if (fwrite(@buf,nbByte,1,afile)<>1) then
ziplocal_putValue := ZIP_ERRNO
else
ziplocal_putValue := ZIP_OK;
end;
procedure ziplocal_putValue_inmemory (dest : voidp;
x : uLong;
nbByte : int);
var
buf : pzByteArray;
n : int;
begin
buf := pzByteArray(dest);
for n := 0 to nbByte-1 do
begin
buf^[n] := Bytef(x and $ff);
x := x shr 8;
end;
end;
{**************************************************************************}
function ziplocal_TmzDateToDosDate(var ptm : tm_zip; dosDate : uLong) : uLong;
var
year : uLong;
begin
year := uLong(ptm.tm_year);
if (year>1980) then
Dec(year, 1980)
else
if (year>80) then
Dec(year, 80);
ziplocal_TmzDateToDosDate := uLong (
((ptm.tm_mday) + (32 * (ptm.tm_mon+1)) + (512 * year)) shl 16) or
((ptm.tm_sec div 2) + (32* ptm.tm_min) + (2048 * uLong(ptm.tm_hour)));
end;
{**************************************************************************}
function zipOpen (const pathname : PChar; append : int) : zipFile; {ZEXPORT}
var
ziinit : zip_internal;
zi : zip_internal_ptr;
begin
if (append = 0) then
ziinit.filezip := fopen(pathname, fopenwrite)
else
ziinit.filezip := fopen(pathname, fappendwrite);
if (ziinit.filezip = NIL) then
begin
zipOpen := NIL;
exit;
end;
ziinit.begin_pos := ftell(ziinit.filezip);
ziinit.in_opened_file_inzip := False;
ziinit.ci.stream_initialised := False;
ziinit.number_entry := 0;
init_linkedlist(ziinit.central_dir);
zi := zip_internal_ptr(ALLOC(sizeof(zip_internal)));
if (zi=NIL) then
begin
fclose(ziinit.filezip);
zipOpen := NIL;
exit;
end;
zi^ := ziinit;
zipOpen := zipFile(zi);
end;
function zipOpenNewFileInZip (afile : zipFile;
{const} filename : PChar;
const zipfi : zip_fileinfo_ptr;
const extrafield_local : voidp;
size_extrafield_local : uInt;
const extrafield_global : voidp;
size_extrafield_global : uInt;
const comment : PChar;
method : int;
level : int) : int; {ZEXPORT}
var
zi : zip_internal_ptr;
size_filename : uInt;
size_comment : uInt;
i : uInt;
err : int;
begin
err := ZIP_OK;
if (afile = NIL) then
begin
zipOpenNewFileInZip := ZIP_PARAMERROR;
exit;
end;
if ((method<>0) and (method<>Z_DEFLATED)) then
begin
zipOpenNewFileInZip := ZIP_PARAMERROR;
exit;
end;
zi := zip_internal_ptr(afile);
if (zi^.in_opened_file_inzip = True) then
begin
err := zipCloseFileInZip (afile);
if (err <> ZIP_OK) then
begin
zipOpenNewFileInZip := err;
exit;
end;
end;
if (filename=NIL) then
filename := '-';
if (comment=NIL) then
size_comment := 0
else
size_comment := strlen(comment);
size_filename := strlen(filename);
if (zipfi = NIL) then
zi^.ci.dosDate := 0
else
begin
if (zipfi^.dosDate <> 0) then
zi^.ci.dosDate := zipfi^.dosDate
else
zi^.ci.dosDate := ziplocal_TmzDateToDosDate(zipfi^.tmz_date,zipfi^.dosDate);
end;
zi^.ci.flag := 0;
if ((level=8) or (level=9)) then
zi^.ci.flag := zi^.ci.flag or 2;
if ((level=2)) then
zi^.ci.flag := zi^.ci.flag or 4;
if ((level=1)) then
zi^.ci.flag := zi^.ci.flag or 6;
zi^.ci.crc32 := 0;
zi^.ci.method := method;
zi^.ci.stream_initialised := False;
zi^.ci.pos_in_buffered_data := 0;
zi^.ci.pos_local_header := ftell(zi^.filezip);
zi^.ci.size_centralheader := SIZECENTRALHEADER + size_filename +
size_extrafield_global + size_comment;
zi^.ci.central_header := PChar( ALLOC( uInt(zi^.ci.size_centralheader)) );
ziplocal_putValue_inmemory(zi^.ci.central_header,uLong(CENTRALHEADERMAGIC),4);
{ version info }
ziplocal_putValue_inmemory(zi^.ci.central_header+4,uLong(VERSIONMADEBY),2);
ziplocal_putValue_inmemory(zi^.ci.central_header+6,uLong(20),2);
ziplocal_putValue_inmemory(zi^.ci.central_header+8,uLong(zi^.ci.flag),2);
ziplocal_putValue_inmemory(zi^.ci.central_header+10,uLong(zi^.ci.method),2);
ziplocal_putValue_inmemory(zi^.ci.central_header+12,uLong(zi^.ci.dosDate),4);
ziplocal_putValue_inmemory(zi^.ci.central_header+16,uLong(0),4); {crc}
ziplocal_putValue_inmemory(zi^.ci.central_header+20,uLong(0),4); {compr size}
ziplocal_putValue_inmemory(zi^.ci.central_header+24,uLong(0),4); {uncompr size}
ziplocal_putValue_inmemory(zi^.ci.central_header+28,uLong(size_filename),2);
ziplocal_putValue_inmemory(zi^.ci.central_header+30,uLong(size_extrafield_global),2);
ziplocal_putValue_inmemory(zi^.ci.central_header+32,uLong(size_comment),2);
ziplocal_putValue_inmemory(zi^.ci.central_header+34,uLong(0),2); {disk nm start}
if (zipfi=NIL) then
ziplocal_putValue_inmemory(zi^.ci.central_header+36,uLong(0),2)
else
ziplocal_putValue_inmemory(zi^.ci.central_header+36,uLong(zipfi^.internal_fa),2);
if (zipfi=NIL) then
ziplocal_putValue_inmemory(zi^.ci.central_header+38,uLong(0),4)
else
ziplocal_putValue_inmemory(zi^.ci.central_header+38,uLong(zipfi^.external_fa),4);
ziplocal_putValue_inmemory(zi^.ci.central_header+42,uLong(zi^.ci.pos_local_header),4);
i := 0;
while (i < size_filename) do
begin
(zi^.ci.central_header+SIZECENTRALHEADER+i)^ := (filename+i)^;
Inc(i);
end;
i := 0;
while (i < size_extrafield_global) do
begin
(zi^.ci.central_header+SIZECENTRALHEADER+size_filename+i)^ :=
({const} PChar(extrafield_global)+i)^;
Inc(i);
end;
i:= 0;
while (i < size_comment) do
begin
(zi^.ci.central_header+SIZECENTRALHEADER+size_filename+ size_extrafield_global+i)^ := (filename+i)^;
Inc(i);
end;
if (zi^.ci.central_header = NIL) then
begin
zipOpenNewFileInZip := ZIP_INTERNALERROR;
exit;
end;
{ write the local header }
err := ziplocal_putValue(zi^.filezip, uLong(LOCALHEADERMAGIC),4);
if (err=ZIP_OK) then
err := ziplocal_putValue(zi^.filezip,uLong(20),2); { version needed to extract }
if (err=ZIP_OK) then
err := ziplocal_putValue(zi^.filezip,uLong(zi^.ci.flag),2);
if (err=ZIP_OK) then
err := ziplocal_putValue(zi^.filezip,uLong(zi^.ci.method),2);
if (err=ZIP_OK) then
err := ziplocal_putValue(zi^.filezip,uLong(zi^.ci.dosDate),4);
if (err=ZIP_OK) then
err := ziplocal_putValue(zi^.filezip,uLong(0),4); { crc 32, unknown }
if (err=ZIP_OK) then
err := ziplocal_putValue(zi^.filezip,uLong(0),4); { compressed size, unknown }
if (err=ZIP_OK) then
err := ziplocal_putValue(zi^.filezip,uLong(0),4); { uncompressed size, unknown }
if (err=ZIP_OK) then
err := ziplocal_putValue(zi^.filezip,uLong(size_filename),2);
if (err=ZIP_OK) then
err := ziplocal_putValue(zi^.filezip,uLong(size_extrafield_local),2);
if ((err=ZIP_OK) and (size_filename>0)) then
begin
if (fwrite(filename,uInt(size_filename),1,zi^.filezip)<>1) then
err := ZIP_ERRNO;
end;
if ((err=ZIP_OK) and (size_extrafield_local>0)) then
begin
if (fwrite(extrafield_local, uInt(size_extrafield_local),1,zi^.filezip) <>1) then
err := ZIP_ERRNO;
end;
zi^.ci.stream.avail_in := uInt(0);
zi^.ci.stream.avail_out := uInt(Z_BUFSIZE);
zi^.ci.stream.next_out := pBytef(@zi^.ci.buffered_data);
zi^.ci.stream.total_in := 0;
zi^.ci.stream.total_out := 0;
if ((err=ZIP_OK) and (zi^.ci.method = Z_DEFLATED)) then
begin
zi^.ci.stream.zalloc := NIL;
zi^.ci.stream.zfree := NIL;
zi^.ci.stream.opaque := NIL;
err := deflateInit2(zi^.ci.stream, level,
Z_DEFLATED, -MAX_WBITS, DEF_MEM_LEVEL, 0);
if (err=Z_OK) then
zi^.ci.stream_initialised := True;
end;
if (err=Z_OK) then
zi^.in_opened_file_inzip := True;
zipOpenNewFileInZip := err;
end;
function zipWriteInFileInZip (afile : zipFile; const buf : voidp; len : unsigned) : int; {ZEXPORT}
var
zi : zip_internal_ptr;
err : int;
var
uTotalOutBefore : uLong;
var
copy_this,i : uInt;
begin
err := ZIP_OK;
if (afile = NIL) then
begin
zipWriteInFileInZip := ZIP_PARAMERROR;
exit;
end;
zi := zip_internal_ptr(afile);
if (zi^.in_opened_file_inzip = False) then
begin
zipWriteInFileInZip := ZIP_PARAMERROR;
exit;
end;
zi^.ci.stream.next_in := buf;
zi^.ci.stream.avail_in := len;
zi^.ci.crc32 := crc32(zi^.ci.crc32,buf,len);
while ((err=ZIP_OK) and (zi^.ci.stream.avail_in>0)) do
begin
if (zi^.ci.stream.avail_out = 0) then
begin
if fwrite(@zi^.ci.buffered_data,uInt(zi^.ci.pos_in_buffered_data),1,zi^.filezip)<>1 then
err := ZIP_ERRNO;
zi^.ci.pos_in_buffered_data := 0;
zi^.ci.stream.avail_out := uInt(Z_BUFSIZE);
zi^.ci.stream.next_out := pBytef(@zi^.ci.buffered_data);
end;
if (zi^.ci.method = Z_DEFLATED) then
begin
uTotalOutBefore := zi^.ci.stream.total_out;
err := deflate(zi^.ci.stream, Z_NO_FLUSH);
Inc(zi^.ci.pos_in_buffered_data, uInt(zi^.ci.stream.total_out - uTotalOutBefore) );
end
else
begin
if (zi^.ci.stream.avail_in < zi^.ci.stream.avail_out) then
copy_this := zi^.ci.stream.avail_in
else
copy_this := zi^.ci.stream.avail_out;
for i := 0 to copy_this-1 do
(PChar(zi^.ci.stream.next_out)+i)^ :=
( {const} PChar(zi^.ci.stream.next_in) +i)^;
Dec(zi^.ci.stream.avail_in, copy_this);
Dec(zi^.ci.stream.avail_out, copy_this);
Inc(zi^.ci.stream.next_in, copy_this);
Inc(zi^.ci.stream.next_out, copy_this);
Inc(zi^.ci.stream.total_in, copy_this);
Inc(zi^.ci.stream.total_out, copy_this);
Inc(zi^.ci.pos_in_buffered_data, copy_this);
end;
end;
zipWriteInFileInZip := 0;
end;
function zipCloseFileInZip (afile : zipFile) : int; {ZEXPORT}
var
zi : zip_internal_ptr;
err : int;
var
uTotalOutBefore : uLong;
var
cur_pos_inzip : long;
begin
err := ZIP_OK;
if (afile = NIL) then
begin
zipCloseFileInZip := ZIP_PARAMERROR;
exit;
end;
zi := zip_internal_ptr(afile);
if (zi^.in_opened_file_inzip = False) then
begin
zipCloseFileInZip := ZIP_PARAMERROR;
exit;
end;
zi^.ci.stream.avail_in := 0;
if (zi^.ci.method = Z_DEFLATED) then
while (err=ZIP_OK) do
begin
if (zi^.ci.stream.avail_out = 0) then
begin
if fwrite(@zi^.ci.buffered_data,uInt(zi^.ci.pos_in_buffered_data),1,zi^.filezip) <>1 then
err := ZIP_ERRNO;
zi^.ci.pos_in_buffered_data := 0;
zi^.ci.stream.avail_out := uInt(Z_BUFSIZE);
zi^.ci.stream.next_out := pBytef(@zi^.ci.buffered_data);
end;
uTotalOutBefore := zi^.ci.stream.total_out;
err := deflate(zi^.ci.stream, Z_FINISH);
Inc(zi^.ci.pos_in_buffered_data, uInt(zi^.ci.stream.total_out - uTotalOutBefore) );
end;
if (err=Z_STREAM_END) then
err := ZIP_OK; { this is normal }
if (zi^.ci.pos_in_buffered_data>0) and (err=ZIP_OK) then
begin
if fwrite(@zi^.ci.buffered_data,uInt(zi^.ci.pos_in_buffered_data),1,zi^.filezip) <>1 then
err := ZIP_ERRNO;
end;
if ((zi^.ci.method = Z_DEFLATED) and (err=ZIP_OK)) then
begin
err := deflateEnd(zi^.ci.stream);
zi^.ci.stream_initialised := False;
end;
ziplocal_putValue_inmemory(zi^.ci.central_header+16, uLong(zi^.ci.crc32),4); {crc}
ziplocal_putValue_inmemory(zi^.ci.central_header+20, uLong(zi^.ci.stream.total_out),4); {compr size}
ziplocal_putValue_inmemory(zi^.ci.central_header+24, uLong(zi^.ci.stream.total_in),4); {uncompr size}
if (err=ZIP_OK) then
err := add_data_in_datablock(@zi^.central_dir,zi^.ci.central_header, uLong(zi^.ci.size_centralheader));
TRYFREE(zi^.ci.central_header);
if (err=ZIP_OK) then
begin
cur_pos_inzip := ftell(zi^.filezip);
if fseek(zi^.filezip, zi^.ci.pos_local_header + 14,SEEK_SET)<>0 then
err := ZIP_ERRNO;
if (err=ZIP_OK) then
err := ziplocal_putValue(zi^.filezip, uLong(zi^.ci.crc32),4); { crc 32, unknown }
if (err=ZIP_OK) then { compressed size, unknown }
err := ziplocal_putValue(zi^.filezip, uLong(zi^.ci.stream.total_out),4);
if (err=ZIP_OK) then { uncompressed size, unknown }
err := ziplocal_putValue(zi^.filezip,uLong(zi^.ci.stream.total_in),4);
if fseek(zi^.filezip, cur_pos_inzip,SEEK_SET)<>0 then
err := ZIP_ERRNO;
end;
Inc(zi^.number_entry);
zi^.in_opened_file_inzip := False;
zipCloseFileInZip := err;
end;
function zipClose (afile : zipFile;
const global_comment : PChar) : int; {ZEXPORT}
var
zi : zip_internal_ptr;
err : int;
size_centraldir : uLong;
centraldir_pos_inzip : uLong;
size_global_comment : uInt;
var
ldi : linkedlist_datablock_internal_ptr;
begin
err := 0;
size_centraldir := 0;
if (afile = NIL) then
begin
zipClose := ZIP_PARAMERROR;
exit;
end;
zi := zip_internal_ptr(afile);
if (zi^.in_opened_file_inzip = True) then
begin
err := zipCloseFileInZip (afile);
end;
if (global_comment=NIL) then
size_global_comment := 0
else
size_global_comment := strlen(global_comment);
centraldir_pos_inzip := ftell(zi^.filezip);
if (err=ZIP_OK) then
begin
ldi := zi^.central_dir.first_block ;
while (ldi<>NIL) do
begin
if ((err=ZIP_OK) and (ldi^.filled_in_this_block>0)) then
begin
if fwrite(@ldi^.data,uInt(ldi^.filled_in_this_block), 1,zi^.filezip)<>1 then
err := ZIP_ERRNO;
end;
Inc(size_centraldir, ldi^.filled_in_this_block);
ldi := ldi^.next_datablock;
end;
end;
free_datablock(zi^.central_dir.first_block);
if (err=ZIP_OK) then { Magic End }
err := ziplocal_putValue(zi^.filezip, uLong(ENDHEADERMAGIC),4);
if (err=ZIP_OK) then { number of this disk }
err := ziplocal_putValue(zi^.filezip, uLong(0),2);
if (err=ZIP_OK) then { number of the disk with the start of the central directory }
err := ziplocal_putValue(zi^.filezip, uLong(0),2);
if (err=ZIP_OK) then { total number of entries in the central dir on this disk }
err := ziplocal_putValue(zi^.filezip, uLong(zi^.number_entry),2);
if (err=ZIP_OK) then { total number of entries in the central dir }
err := ziplocal_putValue(zi^.filezip, uLong(zi^.number_entry),2);
if (err=ZIP_OK) then { size of the central directory }
err := ziplocal_putValue(zi^.filezip, uLong(size_centraldir),4);
if (err=ZIP_OK) then { offset of start of central directory with respect to the
starting disk number }
err := ziplocal_putValue(zi^.filezip, uLong(centraldir_pos_inzip) ,4);
if (err=ZIP_OK) then { zipfile comment length }
err := ziplocal_putValue(zi^.filezip, uLong(size_global_comment),2);
if ((err=ZIP_OK) and (size_global_comment>0)) then
begin
if fwrite(global_comment, uInt(size_global_comment),1,zi^.filezip)<>1 then
err := ZIP_ERRNO;
end;
fclose(zi^.filezip);
TRYFREE(zi);
zipClose := err;
end;
end.

331
contrib/fundamentals/ZLib/paszlib/minizip/ZipUtil.pas Normal file
View File

@@ -0,0 +1,331 @@
Unit ziputils;
{ ziputils.pas - IO on .zip files using zlib
- definitions, declarations and routines used by both
zip.pas and unzip.pas
The file IO is implemented here.
based on work by Gilles Vollant
March 23th, 2000,
Copyright (C) 2000 Jacques Nomssi Nzali }
interface
{$undef UseStream}
{$ifdef WIN32}
{$define Delphi}
{$ifdef UseStream}
{$define Streams}
{$endif}
{$endif}
uses
{$ifdef Delphi}
classes, SysUtils,
{$endif}
zutil;
{ -------------------------------------------------------------- }
{$ifdef Streams}
type
FILEptr = TFileStream;
{$else}
type
FILEptr = ^file;
{$endif}
type
seek_mode = (SEEK_SET, SEEK_CUR, SEEK_END);
open_mode = (fopenread, fopenwrite, fappendwrite);
function fopen(filename : PChar; mode : open_mode) : FILEptr;
procedure fclose(fp : FILEptr);
function fseek(fp : FILEptr; recPos : uLong; mode : seek_mode) : int;
function fread(buf : voidp; recSize : uInt;
recCount : uInt; fp : FILEptr) : uInt;
function fwrite(buf : voidp; recSize : uInt;
recCount : uInt; fp : FILEptr) : uInt;
function ftell(fp : FILEptr) : uLong; { ZIP }
function feof(fp : FILEptr) : uInt; { MiniZIP }
{ ------------------------------------------------------------------- }
type
zipFile = voidp;
unzFile = voidp;
type
z_off_t = long;
{ tm_zip contain date/time info }
type
tm_zip = record
tm_sec : uInt; { seconds after the minute - [0,59] }
tm_min : uInt; { minutes after the hour - [0,59] }
tm_hour : uInt; { hours since midnight - [0,23] }
tm_mday : uInt; { day of the month - [1,31] }
tm_mon : uInt; { months since January - [0,11] }
tm_year : uInt; { years - [1980..2044] }
end;
tm_unz = tm_zip;
const
Z_BUFSIZE = (16384);
Z_MAXFILENAMEINZIP = (256);
const
CENTRALHEADERMAGIC = $02014b50;
const
SIZECENTRALDIRITEM = $2e;
SIZEZIPLOCALHEADER = $1e;
function ALLOC(size : int) : voidp;
procedure TRYFREE(p : voidp);
const
Paszip_copyright : PChar = ' Paszip Copyright 2000 Jacques Nomssi Nzali ';
implementation
function ALLOC(size : int) : voidp;
begin
ALLOC := zcalloc (NIL, size, 1);
end;
procedure TRYFREE(p : voidp);
begin
if Assigned(p) then
zcfree(NIL, p);
end;
{$ifdef Streams}
{ ---------------------------------------------------------------- }
function fopen(filename : PChar; mode : open_mode) : FILEptr;
var
fp : FILEptr;
begin
fp := NIL;
try
Case mode of
fopenread: fp := TFileStream.Create(filename, fmOpenRead);
fopenwrite: fp := TFileStream.Create(filename, fmCreate);
fappendwrite :
begin
fp := TFileStream.Create(filename, fmOpenReadWrite);
fp.Seek(soFromEnd, 0);
end;
end;
except
on EFOpenError do
fp := NIL;
end;
fopen := fp;
end;
procedure fclose(fp : FILEptr);
begin
fp.Free;
end;
function fread(buf : voidp;
recSize : uInt;
recCount : uInt;
fp : FILEptr) : uInt;
var
totalSize, readcount : uInt;
begin
if Assigned(buf) then
begin
totalSize := recCount * uInt(recSize);
readCount := fp.Read(buf^, totalSize);
if (readcount <> totalSize) then
fread := readcount div recSize
else
fread := recCount;
end
else
fread := 0;
end;
function fwrite(buf : voidp;
recSize : uInt;
recCount : uInt;
fp : FILEptr) : uInt;
var
totalSize, written : uInt;
begin
if Assigned(buf) then
begin
totalSize := recCount * uInt(recSize);
written := fp.Write(buf^, totalSize);
if (written <> totalSize) then
fwrite := written div recSize
else
fwrite := recCount;
end
else
fwrite := 0;
end;
function fseek(fp : FILEptr;
recPos : uLong;
mode : seek_mode) : int;
const
fsmode : array[seek_mode] of Word
= (soFromBeginning, soFromCurrent, soFromEnd);
begin
fp.Seek(recPos, fsmode[mode]);
fseek := 0; { = 0 for success }
end;
function ftell(fp : FILEptr) : uLong;
begin
ftell := fp.Position;
end;
function feof(fp : FILEptr) : uInt;
begin
feof := 0;
if Assigned(fp) then
if fp.Position = fp.Size then
feof := 1
else
feof := 0;
end;
{$else}
{ ---------------------------------------------------------------- }
function fopen(filename : PChar; mode : open_mode) : FILEptr;
var
fp : FILEptr;
OldFileMode : byte;
begin
fp := NIL;
OldFileMode := FileMode;
GetMem(fp, SizeOf(file));
Assign(fp^, filename);
{$i-}
Case mode of
fopenread:
begin
FileMode := 0;
Reset(fp^, 1);
end;
fopenwrite:
begin
FileMode := 1;
ReWrite(fp^, 1);
end;
fappendwrite :
begin
FileMode := 2;
Reset(fp^, 1);
Seek(fp^, FileSize(fp^));
end;
end;
FileMode := OldFileMode;
if IOresult<>0 then
begin
FreeMem(fp, SizeOf(file));
fp := NIL;
end;
fopen := fp;
end;
procedure fclose(fp : FILEptr);
begin
if Assigned(fp) then
begin
{$i-}
system.close(fp^);
if IOresult=0 then;
FreeMem(fp, SizeOf(file));
end;
end;
function fread(buf : voidp;
recSize : uInt;
recCount : uInt;
fp : FILEptr) : uInt;
var
totalSize, readcount : uInt;
begin
if Assigned(buf) then
begin
totalSize := recCount * uInt(recSize);
{$i-}
system.BlockRead(fp^, buf^, totalSize, readcount);
if (readcount <> totalSize) then
fread := readcount div recSize
else
fread := recCount;
end
else
fread := 0;
end;
function fwrite(buf : voidp;
recSize : uInt;
recCount : uInt;
fp : FILEptr) : uInt;
var
totalSize, written : uInt;
begin
if Assigned(buf) then
begin
totalSize := recCount * uInt(recSize);
{$i-}
system.BlockWrite(fp^, buf^, totalSize, written);
if (written <> totalSize) then
fwrite := written div recSize
else
fwrite := recCount;
end
else
fwrite := 0;
end;
function fseek(fp : FILEptr;
recPos : uLong;
mode : seek_mode) : int;
begin
{$i-}
case mode of
SEEK_SET : system.Seek(fp^, recPos);
SEEK_CUR : system.Seek(fp^, FilePos(fp^)+recPos);
SEEK_END : system.Seek(fp^, FileSize(fp^)-1-recPos); { ?? check }
end;
fseek := IOresult; { = 0 for success }
end;
function ftell(fp : FILEptr) : uLong;
begin
ftell := FilePos(fp^);
end;
function feof(fp : FILEptr) : uInt;
begin
feof := 0;
if Assigned(fp) then
if eof(fp^) then
feof := 1
else
feof := 0;
end;
{$endif}
{ ---------------------------------------------------------------- }
end.

2252
contrib/fundamentals/ZLib/paszlib/trees.pas Normal file
View File

File diff suppressed because it is too large Load Diff

124
contrib/fundamentals/ZLib/paszlib/zCompres.pas Normal file
View File

@@ -0,0 +1,124 @@
Unit zCompres;
{ compress.c -- compress a memory buffer
Copyright (C) 1995-1998 Jean-loup Gailly.
Pascal tranlastion
Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
Modifiied 02/2003 by Sergey A. Galin for Delphi 6+ and Kylix compatibility.
See README in directory above for more information.
}
interface
{$I zconf.inc}
uses
ZUtil, gZlib, zDeflate;
{ utility functions }
{EXPORT}
function compress (dest : pBytef;
var destLen : uLong;
const source : array of Byte;
sourceLen : uLong) : int;
{ Compresses the source buffer into the destination buffer. sourceLen is
the byte length of the source buffer. Upon entry, destLen is the total
size of the destination buffer, which must be at least 0.1% larger than
sourceLen plus 12 bytes. Upon exit, destLen is the actual size of the
compressed buffer.
This function can be used to compress a whole file at once if the
input file is mmap'ed.
compress returns Z_OK if success, Z_MEM_ERROR if there was not
enough memory, Z_BUF_ERROR if there was not enough room in the output
buffer. }
{EXPORT}
function compress2 (dest : pBytef;
var destLen : uLong;
const source : array of byte;
sourceLen : uLong;
level : int) : int;
{ Compresses the source buffer into the destination buffer. The level
parameter has the same meaning as in deflateInit. sourceLen is the byte
length of the source buffer. Upon entry, destLen is the total size of the
destination buffer, which must be at least 0.1% larger than sourceLen plus
12 bytes. Upon exit, destLen is the actual size of the compressed buffer.
compress2 returns Z_OK if success, Z_MEM_ERROR if there was not enough
memory, Z_BUF_ERROR if there was not enough room in the output buffer,
Z_STREAM_ERROR if the level parameter is invalid. }
implementation
{ ===========================================================================
}
function compress2 (dest : pBytef;
var destLen : uLong;
const source : array of byte;
sourceLen : uLong;
level : int) : int;
var
stream : z_stream;
err : int;
begin
stream.next_in := pBytef(@source);
stream.avail_in := uInt(sourceLen);
{$ifdef MAXSEG_64K}
{ Check for source > 64K on 16-bit machine: }
if (uLong(stream.avail_in) <> sourceLen) then
begin
compress2 := Z_BUF_ERROR;
exit;
end;
{$endif}
stream.next_out := dest;
stream.avail_out := uInt(destLen);
if (uLong(stream.avail_out) <> destLen) then
begin
compress2 := Z_BUF_ERROR;
exit;
end;
stream.zalloc := NIL; { alloc_func(0); }
stream.zfree := NIL; { free_func(0); }
stream.opaque := NIL; { voidpf(0); }
err := deflateInit(stream, level);
if (err <> Z_OK) then
begin
compress2 := err;
exit;
end;
err := deflate(stream, Z_FINISH);
if (err <> Z_STREAM_END) then
begin
deflateEnd(stream);
if err = Z_OK then
compress2 := Z_BUF_ERROR
else
compress2 := err;
exit;
end;
destLen := stream.total_out;
err := deflateEnd(stream);
compress2 := err;
end;
{ ===========================================================================
}
function compress (dest : pBytef;
var destLen : uLong;
const source : array of Byte;
sourceLen : uLong) : int;
begin
compress := compress2(dest, destLen, source, sourceLen, Z_DEFAULT_COMPRESSION);
end;
end.

2144
contrib/fundamentals/ZLib/paszlib/zDeflate.pas Normal file
View File

File diff suppressed because it is too large Load Diff

755
contrib/fundamentals/ZLib/paszlib/zInflate.pas Normal file
View File

@@ -0,0 +1,755 @@
Unit zInflate;
{ inflate.c -- zlib interface to inflate modules
Copyright (C) 1995-1998 Mark Adler
Pascal tranlastion
Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
Modifiied 02/2003 by Sergey A. Galin for Delphi 6+ and Kylix compatibility.
See README in directory above for more information.
}
interface
{$I zconf.inc}
{.DEFINE ZINFLATE_DEBUG}
uses
ZUtil, gZlib, InfBlock, infutil;
function inflateInit(var z : z_stream) : int;
{ Initializes the internal stream state for decompression. The fields
zalloc, zfree and opaque must be initialized before by the caller. If
zalloc and zfree are set to Z_NULL, inflateInit updates them to use default
allocation functions.
inflateInit returns Z_OK if success, Z_MEM_ERROR if there was not
enough memory, Z_VERSION_ERROR if the zlib library version is incompatible
with the version assumed by the caller. msg is set to null if there is no
error message. inflateInit does not perform any decompression: this will be
done by inflate(). }
function inflateInit_(z : z_streamp;
const version : string;
stream_size : int) : int;
function inflateInit2_(var z: z_stream;
w : int;
const version : string;
stream_size : int) : int;
function inflateInit2(var z: z_stream;
windowBits : int) : int;
{
This is another version of inflateInit with an extra parameter. The
fields next_in, avail_in, zalloc, zfree and opaque must be initialized
before by the caller.
The windowBits parameter is the base two logarithm of the maximum window
size (the size of the history buffer). It should be in the range 8..15 for
this version of the library. The default value is 15 if inflateInit is used
instead. If a compressed stream with a larger window size is given as
input, inflate() will return with the error code Z_DATA_ERROR instead of
trying to allocate a larger window.
inflateInit2 returns Z_OK if success, Z_MEM_ERROR if there was not enough
memory, Z_STREAM_ERROR if a parameter is invalid (such as a negative
memLevel). msg is set to null if there is no error message. inflateInit2
does not perform any decompression apart from reading the zlib header if
present: this will be done by inflate(). (So next_in and avail_in may be
modified, but next_out and avail_out are unchanged.)
}
function inflateEnd(var z : z_stream) : int;
{
All dynamically allocated data structures for this stream are freed.
This function discards any unprocessed input and does not flush any
pending output.
inflateEnd returns Z_OK if success, Z_STREAM_ERROR if the stream state
was inconsistent. In the error case, msg may be set but then points to a
static string (which must not be deallocated).
}
function inflateReset(var z : z_stream) : int;
{
This function is equivalent to inflateEnd followed by inflateInit,
but does not free and reallocate all the internal decompression state.
The stream will keep attributes that may have been set by inflateInit2.
inflateReset returns Z_OK if success, or Z_STREAM_ERROR if the source
stream state was inconsistent (such as zalloc or state being NULL).
}
function inflate(var z : z_stream;
f : int) : int;
{
inflate decompresses as much data as possible, and stops when the input
buffer becomes empty or the output buffer becomes full. It may introduce
some output latency (reading input without producing any output)
except when forced to flush.
The detailed semantics are as follows. inflate performs one or both of the
following actions:
- Decompress more input starting at next_in and update next_in and avail_in
accordingly. If not all input can be processed (because there is not
enough room in the output buffer), next_in is updated and processing
will resume at this point for the next call of inflate().
- Provide more output starting at next_out and update next_out and avail_out
accordingly. inflate() provides as much output as possible, until there
is no more input data or no more space in the output buffer (see below
about the flush parameter).
Before the call of inflate(), the application should ensure that at least
one of the actions is possible, by providing more input and/or consuming
more output, and updating the next_* and avail_* values accordingly.
The application can consume the uncompressed output when it wants, for
example when the output buffer is full (avail_out == 0), or after each
call of inflate(). If inflate returns Z_OK and with zero avail_out, it
must be called again after making room in the output buffer because there
might be more output pending.
If the parameter flush is set to Z_SYNC_FLUSH, inflate flushes as much
output as possible to the output buffer. The flushing behavior of inflate is
not specified for values of the flush parameter other than Z_SYNC_FLUSH
and Z_FINISH, but the current implementation actually flushes as much output
as possible anyway.
inflate() should normally be called until it returns Z_STREAM_END or an
error. However if all decompression is to be performed in a single step
(a single call of inflate), the parameter flush should be set to
Z_FINISH. In this case all pending input is processed and all pending
output is flushed; avail_out must be large enough to hold all the
uncompressed data. (The size of the uncompressed data may have been saved
by the compressor for this purpose.) The next operation on this stream must
be inflateEnd to deallocate the decompression state. The use of Z_FINISH
is never required, but can be used to inform inflate that a faster routine
may be used for the single inflate() call.
If a preset dictionary is needed at this point (see inflateSetDictionary
below), inflate sets strm-adler to the adler32 checksum of the
dictionary chosen by the compressor and returns Z_NEED_DICT; otherwise
it sets strm->adler to the adler32 checksum of all output produced
so far (that is, total_out bytes) and returns Z_OK, Z_STREAM_END or
an error code as described below. At the end of the stream, inflate()
checks that its computed adler32 checksum is equal to that saved by the
compressor and returns Z_STREAM_END only if the checksum is correct.
inflate() returns Z_OK if some progress has been made (more input processed
or more output produced), Z_STREAM_END if the end of the compressed data has
been reached and all uncompressed output has been produced, Z_NEED_DICT if a
preset dictionary is needed at this point, Z_DATA_ERROR if the input data was
corrupted (input stream not conforming to the zlib format or incorrect
adler32 checksum), Z_STREAM_ERROR if the stream structure was inconsistent
(for example if next_in or next_out was NULL), Z_MEM_ERROR if there was not
enough memory, Z_BUF_ERROR if no progress is possible or if there was not
enough room in the output buffer when Z_FINISH is used. In the Z_DATA_ERROR
case, the application may then call inflateSync to look for a good
compression block.
}
function inflateSetDictionary(var z : z_stream;
dictionary : pBytef; {const array of byte}
dictLength : uInt) : int;
{
Initializes the decompression dictionary from the given uncompressed byte
sequence. This function must be called immediately after a call of inflate
if this call returned Z_NEED_DICT. The dictionary chosen by the compressor
can be determined from the Adler32 value returned by this call of
inflate. The compressor and decompressor must use exactly the same
dictionary (see deflateSetDictionary).
inflateSetDictionary returns Z_OK if success, Z_STREAM_ERROR if a
parameter is invalid (such as NULL dictionary) or the stream state is
inconsistent, Z_DATA_ERROR if the given dictionary doesn't match the
expected one (incorrect Adler32 value). inflateSetDictionary does not
perform any decompression: this will be done by subsequent calls of
inflate().
}
function inflateSync(var z : z_stream) : int;
{
Skips invalid compressed data until a full flush point (see above the
description of deflate with Z_FULL_FLUSH) can be found, or until all
available input is skipped. No output is provided.
inflateSync returns Z_OK if a full flush point has been found, Z_BUF_ERROR
if no more input was provided, Z_DATA_ERROR if no flush point has been found,
or Z_STREAM_ERROR if the stream structure was inconsistent. In the success
case, the application may save the current current value of total_in which
indicates where valid compressed data was found. In the error case, the
application may repeatedly call inflateSync, providing more input each time,
until success or end of the input data.
}
function inflateSyncPoint(var z : z_stream) : int;
implementation
uses
adler;
function inflateReset(var z : z_stream) : int;
begin
if (z.state = Z_NULL) then
begin
inflateReset := Z_STREAM_ERROR;
exit;
end;
z.total_out := 0;
z.total_in := 0;
z.msg := '';
if z.state^.nowrap then
z.state^.mode := BLOCKS
else
z.state^.mode := METHOD;
inflate_blocks_reset(z.state^.blocks^, z, Z_NULL);
{$IFDEF ZINFLATE_DEBUG}
Tracev('inflate: reset');
{$ENDIF}
inflateReset := Z_OK;
end;
function inflateEnd(var z : z_stream) : int;
begin
if (z.state = Z_NULL) or not Assigned(z.zfree) then
begin
inflateEnd := Z_STREAM_ERROR;
exit;
end;
if (z.state^.blocks <> Z_NULL) then
inflate_blocks_free(z.state^.blocks, z);
ZFREE(z, z.state);
z.state := Z_NULL;
{$IFDEF ZINFLATE_DEBUG}
Tracev('inflate: end');
{$ENDIF}
inflateEnd := Z_OK;
end;
function inflateInit2_(var z: z_stream;
w : int;
const version : string;
stream_size : int) : int;
begin
if (version = '') or (version[1] <> ZLIB_VERSION[1]) or
(stream_size <> sizeof(z_stream)) then
begin
inflateInit2_ := Z_VERSION_ERROR;
exit;
end;
{ initialize state }
{ SetLength(strm.msg, 255); }
z.msg := '';
if not Assigned(z.zalloc) then
begin
{$IFDEF FPC} z.zalloc := @zcalloc; {$ELSE}
z.zalloc := zcalloc;
{$endif}
z.opaque := voidpf(0);
end;
if not Assigned(z.zfree) then
{$IFDEF FPC} z.zfree := @zcfree; {$ELSE}
z.zfree := zcfree;
{$ENDIF}
z.state := pInternal_state( ZALLOC(z,1,sizeof(internal_state)) );
if (z.state = Z_NULL) then
begin
inflateInit2_ := Z_MEM_ERROR;
exit;
end;
z.state^.blocks := Z_NULL;
{ handle undocumented nowrap option (no zlib header or check) }
z.state^.nowrap := FALSE;
if (w < 0) then
begin
w := - w;
z.state^.nowrap := TRUE;
end;
{ set window size }
if (w < 8) or (w > 15) then
begin
inflateEnd(z);
inflateInit2_ := Z_STREAM_ERROR;
exit;
end;
z.state^.wbits := uInt(w);
{ create inflate_blocks state }
if z.state^.nowrap then
z.state^.blocks := inflate_blocks_new(z, NIL, uInt(1) shl w)
else
{$IFDEF FPC}
z.state^.blocks := inflate_blocks_new(z, @adler32, uInt(1) shl w);
{$ELSE}
z.state^.blocks := inflate_blocks_new(z, adler32, uInt(1) shl w);
{$ENDIF}
if (z.state^.blocks = Z_NULL) then
begin
inflateEnd(z);
inflateInit2_ := Z_MEM_ERROR;
exit;
end;
{$IFDEF ZINFLATE_DEBUG}
Tracev('inflate: allocated');
{$ENDIF}
{ reset state }
inflateReset(z);
inflateInit2_ := Z_OK;
end;
function inflateInit2(var z: z_stream; windowBits : int) : int;
begin
inflateInit2 := inflateInit2_(z, windowBits, ZLIB_VERSION, sizeof(z_stream));
end;
function inflateInit(var z : z_stream) : int;
{ inflateInit is a macro to allow checking the zlib version
and the compiler's view of z_stream: }
begin
inflateInit := inflateInit2_(z, DEF_WBITS, ZLIB_VERSION, sizeof(z_stream));
end;
function inflateInit_(z : z_streamp;
const version : string;
stream_size : int) : int;
begin
{ initialize state }
if (z = Z_NULL) then
inflateInit_ := Z_STREAM_ERROR
else
inflateInit_ := inflateInit2_(z^, DEF_WBITS, version, stream_size);
end;
function inflate(var z : z_stream;
f : int) : int;
var
r : int;
b : uInt;
begin
if (z.state = Z_NULL) or (z.next_in = Z_NULL) then
begin
inflate := Z_STREAM_ERROR;
exit;
end;
if f = Z_FINISH then
f := Z_BUF_ERROR
else
f := Z_OK;
r := Z_BUF_ERROR;
while True do
case (z.state^.mode) of
BLOCKS:
begin
r := inflate_blocks(z.state^.blocks^, z, r);
if (r = Z_DATA_ERROR) then
begin
z.state^.mode := BAD;
z.state^.sub.marker := 0; { can try inflateSync }
continue; { break C-switch }
end;
if (r = Z_OK) then
r := f;
if (r <> Z_STREAM_END) then
begin
inflate := r;
exit;
end;
r := f;
inflate_blocks_reset(z.state^.blocks^, z, @z.state^.sub.check.was);
if (z.state^.nowrap) then
begin
z.state^.mode := DONE;
continue; { break C-switch }
end;
z.state^.mode := CHECK4; { falltrough }
end;
CHECK4:
begin
{NEEDBYTE}
if (z.avail_in = 0) then
begin
inflate := r;
exit;
end;
r := f;
{z.state^.sub.check.need := uLong(NEXTBYTE(z)) shl 24;}
Dec(z.avail_in);
Inc(z.total_in);
z.state^.sub.check.need := uLong(z.next_in^) shl 24;
Inc(z.next_in);
z.state^.mode := CHECK3; { falltrough }
end;
CHECK3:
begin
{NEEDBYTE}
if (z.avail_in = 0) then
begin
inflate := r;
exit;
end;
r := f;
{Inc( z.state^.sub.check.need, uLong(NEXTBYTE(z)) shl 16);}
Dec(z.avail_in);
Inc(z.total_in);
Inc(z.state^.sub.check.need, uLong(z.next_in^) shl 16);
Inc(z.next_in);
z.state^.mode := CHECK2; { falltrough }
end;
CHECK2:
begin
{NEEDBYTE}
if (z.avail_in = 0) then
begin
inflate := r;
exit;
end;
r := f;
{Inc( z.state^.sub.check.need, uLong(NEXTBYTE(z)) shl 8);}
Dec(z.avail_in);
Inc(z.total_in);
Inc(z.state^.sub.check.need, uLong(z.next_in^) shl 8);
Inc(z.next_in);
z.state^.mode := CHECK1; { falltrough }
end;
CHECK1:
begin
{NEEDBYTE}
if (z.avail_in = 0) then
begin
inflate := r;
exit;
end;
r := f;
{Inc( z.state^.sub.check.need, uLong(NEXTBYTE(z)) );}
Dec(z.avail_in);
Inc(z.total_in);
Inc(z.state^.sub.check.need, uLong(z.next_in^) );
Inc(z.next_in);
if (z.state^.sub.check.was <> z.state^.sub.check.need) then
begin
z.state^.mode := BAD;
z.msg := 'incorrect data check';
z.state^.sub.marker := 5; { can't try inflateSync }
continue; { break C-switch }
end;
{$IFDEF ZINFLATE_DEBUG}
Tracev('inflate: zlib check ok');
{$ENDIF}
z.state^.mode := DONE; { falltrough }
end;
DONE:
begin
inflate := Z_STREAM_END;
exit;
end;
METHOD:
begin
{NEEDBYTE}
if (z.avail_in = 0) then
begin
inflate := r;
exit;
end;
r := f; {}
{z.state^.sub.method := NEXTBYTE(z);}
Dec(z.avail_in);
Inc(z.total_in);
z.state^.sub.method := z.next_in^;
Inc(z.next_in);
if ((z.state^.sub.method and $0f) <> Z_DEFLATED) then
begin
z.state^.mode := BAD;
z.msg := 'unknown compression method';
z.state^.sub.marker := 5; { can't try inflateSync }
continue; { break C-switch }
end;
if ((z.state^.sub.method shr 4) + 8 > z.state^.wbits) then
begin
z.state^.mode := BAD;
z.msg := 'invalid window size';
z.state^.sub.marker := 5; { can't try inflateSync }
continue; { break C-switch }
end;
z.state^.mode := FLAG;
{ fall trough }
end;
FLAG:
begin
{NEEDBYTE}
if (z.avail_in = 0) then
begin
inflate := r;
exit;
end;
r := f; {}
{b := NEXTBYTE(z);}
Dec(z.avail_in);
Inc(z.total_in);
b := z.next_in^;
Inc(z.next_in);
if (((z.state^.sub.method shl 8) + b) mod 31) <> 0 then {% mod ?}
begin
z.state^.mode := BAD;
z.msg := 'incorrect header check';
z.state^.sub.marker := 5; { can't try inflateSync }
continue; { break C-switch }
end;
{$IFDEF ZINFLATE_DEBUG}
Tracev('inflate: zlib header ok');
{$ENDIF}
if ((b and PRESET_DICT) = 0) then
begin
z.state^.mode := BLOCKS;
continue; { break C-switch }
end;
z.state^.mode := DICT4;
{ falltrough }
end;
DICT4:
begin
if (z.avail_in = 0) then
begin
inflate := r;
exit;
end;
r := f;
{z.state^.sub.check.need := uLong(NEXTBYTE(z)) shl 24;}
Dec(z.avail_in);
Inc(z.total_in);
z.state^.sub.check.need := uLong(z.next_in^) shl 24;
Inc(z.next_in);
z.state^.mode := DICT3; { falltrough }
end;
DICT3:
begin
if (z.avail_in = 0) then
begin
inflate := r;
exit;
end;
r := f;
{Inc(z.state^.sub.check.need, uLong(NEXTBYTE(z)) shl 16);}
Dec(z.avail_in);
Inc(z.total_in);
Inc(z.state^.sub.check.need, uLong(z.next_in^) shl 16);
Inc(z.next_in);
z.state^.mode := DICT2; { falltrough }
end;
DICT2:
begin
if (z.avail_in = 0) then
begin
inflate := r;
exit;
end;
r := f;
{Inc(z.state^.sub.check.need, uLong(NEXTBYTE(z)) shl 8);}
Dec(z.avail_in);
Inc(z.total_in);
Inc(z.state^.sub.check.need, uLong(z.next_in^) shl 8);
Inc(z.next_in);
z.state^.mode := DICT1; { falltrough }
end;
DICT1:
begin
if (z.avail_in = 0) then
begin
inflate := r;
exit;
end;
{ r := f; --- wird niemals benutzt }
{Inc(z.state^.sub.check.need, uLong(NEXTBYTE(z)) );}
Dec(z.avail_in);
Inc(z.total_in);
Inc(z.state^.sub.check.need, uLong(z.next_in^) );
Inc(z.next_in);
z.adler := z.state^.sub.check.need;
z.state^.mode := DICT0;
inflate := Z_NEED_DICT;
exit;
end;
DICT0:
begin
z.state^.mode := BAD;
z.msg := 'need dictionary';
z.state^.sub.marker := 0; { can try inflateSync }
inflate := Z_STREAM_ERROR;
exit;
end;
BAD:
begin
inflate := Z_DATA_ERROR;
exit;
end;
else
begin
inflate := Z_STREAM_ERROR;
exit;
end;
end;
{$ifdef NEED_DUMMY_result}
result := Z_STREAM_ERROR; { Some dumb compilers complain without this }
{$endif}
end;
function inflateSetDictionary(var z : z_stream;
dictionary : pBytef; {const array of byte}
dictLength : uInt) : int;
var
length : uInt;
begin
length := dictLength;
if (z.state = Z_NULL) or (z.state^.mode <> DICT0) then
begin
inflateSetDictionary := Z_STREAM_ERROR;
exit;
end;
if (adler32(Long(1), dictionary, dictLength) <> z.adler) then
begin
inflateSetDictionary := Z_DATA_ERROR;
exit;
end;
z.adler := Long(1);
if (length >= (uInt(1) shl z.state^.wbits)) then
begin
length := (1 shl z.state^.wbits)-1;
Inc( dictionary, dictLength - length);
end;
inflate_set_dictionary(z.state^.blocks^, dictionary^, length);
z.state^.mode := BLOCKS;
inflateSetDictionary := Z_OK;
end;
function inflateSync(var z : z_stream) : int;
const
mark : packed array[0..3] of byte = (0, 0, $ff, $ff);
var
n : uInt; { number of bytes to look at }
p : pBytef; { pointer to bytes }
m : uInt; { number of marker bytes found in a row }
r, w : uLong; { temporaries to save total_in and total_out }
begin
{ set up }
if (z.state = Z_NULL) then
begin
inflateSync := Z_STREAM_ERROR;
exit;
end;
if (z.state^.mode <> BAD) then
begin
z.state^.mode := BAD;
z.state^.sub.marker := 0;
end;
n := z.avail_in;
if (n = 0) then
begin
inflateSync := Z_BUF_ERROR;
exit;
end;
p := z.next_in;
m := z.state^.sub.marker;
{ search }
while (n <> 0) and (m < 4) do
begin
if (p^ = mark[m]) then
Inc(m)
else
if (p^ <> 0) then
m := 0
else
m := 4 - m;
Inc(p);
Dec(n);
end;
{ restore }
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
z.avail_in := n;
z.state^.sub.marker := m;
{ return no joy or set up to restart on a new block }
if (m <> 4) then
begin
inflateSync := Z_DATA_ERROR;
exit;
end;
r := z.total_in;
w := z.total_out;
inflateReset(z);
z.total_in := r;
z.total_out := w;
z.state^.mode := BLOCKS;
inflateSync := Z_OK;
end;
{
returns true if inflate is currently at the end of a block generated
by Z_SYNC_FLUSH or Z_FULL_FLUSH. This function is used by one PPP
implementation to provide an additional safety check. PPP uses Z_SYNC_FLUSH
but removes the length bytes of the resulting empty stored block. When
decompressing, PPP checks that at the end of input packet, inflate is
waiting for these length bytes.
}
function inflateSyncPoint(var z : z_stream) : int;
begin
if (z.state = Z_NULL) or (z.state^.blocks = Z_NULL) then
begin
inflateSyncPoint := Z_STREAM_ERROR;
exit;
end;
inflateSyncPoint := inflate_blocks_sync_point(z.state^.blocks^);
end;
end.

94
contrib/fundamentals/ZLib/paszlib/zUnCompr.pas Normal file
View File

@@ -0,0 +1,94 @@
Unit zUnCompr;
{ uncompr.c -- decompress a memory buffer
Copyright (C) 1995-1998 Jean-loup Gailly.
Pascal tranlastion
Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
Modifiied 02/2003 by Sergey A. Galin for Delphi 6+ and Kylix compatibility.
See README in directory above for more information.
}
interface
{$I zconf.inc}
uses
zutil, gzlib, zInflate;
{ ===========================================================================
Decompresses the source buffer into the destination buffer. sourceLen is
the byte length of the source buffer. Upon entry, destLen is the total
size of the destination buffer, which must be large enough to hold the
entire uncompressed data. (The size of the uncompressed data must have
been saved previously by the compressor and transmitted to the decompressor
by some mechanism outside the scope of this compression library.)
Upon exit, destLen is the actual size of the compressed buffer.
This function can be used to decompress a whole file at once if the
input file is mmap'ed.
uncompress returns Z_OK if success, Z_MEM_ERROR if there was not
enough memory, Z_BUF_ERROR if there was not enough room in the output
buffer, or Z_DATA_ERROR if the input data was corrupted.
}
function uncompress (dest : pBytef;
var destLen : uLong;
const source : array of byte;
sourceLen : uLong) : int;
implementation
function uncompress (dest : pBytef;
var destLen : uLong;
const source : array of byte;
sourceLen : uLong) : int;
var
stream : z_stream;
err : int;
begin
stream.next_in := pBytef(@source);
stream.avail_in := uInt(sourceLen);
{ Check for source > 64K on 16-bit machine: }
if (uLong(stream.avail_in) <> sourceLen) then
begin
uncompress := Z_BUF_ERROR;
exit;
end;
stream.next_out := dest;
stream.avail_out := uInt(destLen);
if (uLong(stream.avail_out) <> destLen) then
begin
uncompress := Z_BUF_ERROR;
exit;
end;
stream.zalloc := NIL; { alloc_func(0); }
stream.zfree := NIL; { free_func(0); }
err := inflateInit(stream);
if (err <> Z_OK) then
begin
uncompress := err;
exit;
end;
err := inflate(stream, Z_FINISH);
if (err <> Z_STREAM_END) then
begin
inflateEnd(stream);
if err = Z_OK then
uncompress := Z_BUF_ERROR
else
uncompress := err;
exit;
end;
destLen := stream.total_out;
err := inflateEnd(stream);
uncompress := err;
end;
end.

36
contrib/fundamentals/ZLib/paszlib/zconf.inc Normal file
View File

@@ -0,0 +1,36 @@
{ -------------------------------------------------------------------- }
{
Modified 04/2015 by David J Butler for inclusion in Fundamentals library.
}
{$INCLUDE ..\..\flcInclude.inc}
{ -------------------------------------------------------------------- }
{
Modifiied 02/2003 by Sergey A. Galin for Delphi 6+ and Kylix compatibility.
See README in directory above for more information.
}
{$DEFINE X32}
{$DEFINE Delphi32}
{$DEFINE Delphi}
{$DEFINE Kylix}
{$WARN UNSAFE_CODE OFF}
{$WARN UNSAFE_TYPE OFF}
{$DEFINE MAX_MATCH_IS_258}
{$IFNDEF X32}
{$DEFINE UNALIGNED_OK} { requires SizeOf(ush) = 2 ! }
{$ENDIF}
{$UNDEF DYNAMIC_CRC_TABLE}
{$UNDEF FASTEST}
{$DEFINE patch112} { apply patch from the zlib home page }
{ -------------------------------------------------------------------- }