Permalink
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
4687 lines (4358 sloc) 177 KB
/// ZIP/LZ77 Deflate/Inflate Compression in pure pascal
// - this unit is a part of the freeware Synopse framework,
// licensed in the LGPL v3; version 1.18
unit PasZip;
{
This file is part of Synopse framework.
Synopse framework. Copyright (C) 2018 Arnaud Bouchez
Synopse Informatique - https://synopse.info
This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation; either version 3 of the License, or (at
your option) any later version.
This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this library. If not, see <http://www.gnu.org/licenses/>.
PasZip.pas from madZip.pas - original version: 0.1b, date: 2003-06-09
clearly inspired from fpc's RTL paszlib
------------------------------------------------------------------------
compression stuff compatible with LZ77 Deflate/Inflate
Improvements by A.Bouchez on 2006-2010 - http://bouchez.info
- CRC32 table can be generated by code (save 1KB in executable)
- Inflate made 50% faster than MadLib's original by tuned Move() usage
and some critical part rewrite
- included .zip archive reading from file, resource or direct memory
- included .zip archive write into a file (new .zip creation, not update)
Version 1.18
- enhanced compatibility with new targets and compilers (Win32, Win64,
Delphi 2009+, FPC)
- even more refactoring, and fixes
}
{$WARNINGS OFF}
{$Q-,R-} // Turn range checking and overflow checking off
{ $D-,L-}
{$I Synopse.inc}
interface
uses
{$ifdef MSWINDOWS}
Windows,
{$else}
LibC,
Types,
{$endif}
SysUtils;
type
{$ifdef HASCODEPAGE}
RawByteZip = RawByteString;
TZipName = type AnsiString(437);
{$else}
RawByteZip = AnsiString;
TZipName = AnsiString;
{$endif}
{$ifdef DELPHI5OROLDER}
PCardinal = ^cardinal;
{$endif}
/// compress memory using the ZLib DEFLATE algorithm
function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer;
/// uncompress memory using the ZLib INFLATE algorithm
function UnCompressMem(src, dst: pointer; srcLen, dstLen: integer): integer;
/// compress memory using the ZLib DEFLATE algorithm
function CompressString(const data: RawByteZip; failIfGrow: boolean = false): RawByteZip;
/// uncompress memory using the ZLib INFLATE algorithm
function UncompressString(const data: RawByteZip): RawByteZip;
{$ifdef MSWINDOWS} { use Windows MapFile }
function CompressFile(const srcFile, dstFile: TFileName; failIfGrow: boolean = false): boolean;
function UncompressFile(const srcFile, dstFile: TFileName;
lastWriteTime: int64 = 0; attr: dword = 0): boolean;
function GetCompressedFileInfo(const comprFile: TFileName; var size: int64;
var crc32: dword): boolean;
function GetUncompressedFileInfo(const uncomprFile: TFileName; var size: int64;
var crc32: dword): boolean;
function IsCompressedFileEqual(const uncomprFile, comprFile: TFileName): boolean;
/// You can create a "zip" compatible archive by calling the "Zip" function.
// - The first parameter is the full file path of the new zip archive.
// - The second parameter must be an array of the files you want to have zipped
// into the archive (full file path again, please).
// - The third array (only file names, please) allows you to store the files into
// the zip under a different name.
// - Generally the resulting zip archive should not contain any directory structure:
// all zipped files are directly stored in the archive's root, if NoSubDirectories
// is set to TRUE.
function Zip(const zip: TFileName; const files, zipAs: array of TFileName;
NoSubDirectories: boolean = false): boolean;
{$endif}
/// create a void .zip file
procedure CreateVoidZip(const aFileName: TFileName);
/// create a compatible .gz file (returns file size)
function GzCompress(src: pointer; srcLen: integer; const fName: TFileName): cardinal;
/// calculate the CRC32 hash of a specified memory buffer
function UpdateCrc32(aCRC32: cardinal; inBuf: pointer; inLen: integer): cardinal;
{$DEFINE DYNAMIC_CRC_TABLE}
{ if defined, the crc32Tab[] is created on staturp: save 1KB of code size }
/// the static buffer used for fast CRC32 hashing
{$ifdef DYNAMIC_CRC_TABLE}
var
crc32Tab: array[0..255] of cardinal;
{$else}
const
crc32Tab: array[0..255] of cardinal = ($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}
type
/// generic file information structure, as used in .zip file format
// - used in any header, contains info about following block
TFileInfo = packed record
neededVersion: word; // $14
flags: word; // 0
zzipMethod: word; // 8 (deflate)
zlastModTime: word; // dos format
zlastModDate: word; // dos format
zcrc32: dword;
zzipSize: dword;
zfullSize: dword;
nameLen: word; // length(name)
extraLen: word; // 0
end;
PFileInfo = ^TFileInfo;
/// internal file information structure, as used in .zip file format
// - used locally inside the file stream, followed by the name and then the data
TLocalFileHeader = packed record
signature: dword; // $04034b50
fileInfo: TFileInfo;
end;
/// directory file information structure, as used in .zip file format
// - used at the end of the zip file to recap all entries
TFileHeader = packed record
signature: dword; // $02014b50
madeBy: word; // $14
fileInfo: TFileInfo;
commentLen: word; // 0
firstDiskNo: word; // 0
intFileAttr: word; // 0 = binary; 1 = text
extFileAttr: dword; // dos file attributes
localHeadOff: dword; // @TLocalFileHeader
end;
/// last header structure, as used in .zip file format
// - this header ends the file and is used to find the TFileHeader entries
TLastHeader = packed record
signature: dword; // $06054b50
thisDisk: word; // 0
headerDisk: word; // 0
thisFiles: word; // 1
totalFiles: word; // 1
headerSize: dword; // sizeOf(TFileHeaders + names)
headerOffset: dword; // @TFileHeader
commentLen: word; // 0
end;
{$ifdef MSWINDOWS}
type
/// stores an entry of a file inside a .zip archive
TZipEntry = packed record
/// the information of this file, as stored in the .zip archive
info: PFileInfo;
/// points to the compressed data in the .zip archive, mapped in memory
data: PAnsiChar;
/// ASCIIZ name of the file inside the .zip archive
// - not a string, but a fixed-length array of char
Name: array[0..127 - SizeOf(pointer)*2] of AnsiChar;
end;
/// read-only access to a .zip archive file
// - can open directly a specified .zip file (will be memory mapped for fast access)
// - can open a .zip archive file content from a resource (embedded in the executable)
// - can open a .zip archive file content from memory
TZipRead = class
private
file_, map: dword; // we use a memory mapped file to access the zip content
buf: PByteArray;
fZipStartOffset: cardinal;
fShowMessageBoxOnError: boolean;
procedure UnMap;
public
/// the number of files inside a .zip archive
Count: integer;
/// the files inside the .zip archive
Entry: array of TZipEntry;
/// open a .zip archive file as Read Only
constructor Create(const aFileName: TFileName; ZipStartOffset: cardinal = 0;
Size: cardinal = 0; ShowMessageBoxOnError: boolean = true); overload;
/// open a .zip archive file directly from a resource
constructor Create(Instance: THandle; const ResName: string; ResType: PChar); overload;
/// open a .zip archive file directly from memory
constructor Create(BufZip: pByteArray; Size: cardinal); overload;
/// release associated memory
destructor Destroy; override;
/// get the index of a file inside the .zip archive
function NameToIndex(const aZipName: TZipName): integer;
/// uncompress a file stored inside the .zip archive into a destination folder
function UnZipFile(aIndex: integer; DestPath: TFileName; ForceWriteFlush:
boolean): boolean;
/// uncompress a file stored inside the .zip archive into memory
function UnZip(aIndex: integer): RawByteZip; overload;
/// read the file from the supplied folder, and check its content according
// to the crc32 stored inside the .zip archive header (no decompression is made)
function CheckFile(aIndex: integer; DestPath: TFileName): boolean;
/// get any initial .exe file
function GetInitialExeContent: RawByteZip;
/// the starting offset of the .zip content, after the initial .exe, if any
// - can be used to copy the initial .exe file
property ZipStartOffset: cardinal read fZipStartOffset;
end;
{$endif}
/// write-only access for creating a .zip archive file
// - not to be used to update a .zip file, but to create a new one
// - update can be done manualy by using a TZipRead instance and the
// AddFromZip() method
TZipWrite = class
protected
fAppendOffset: cardinal;
fFileName: TFileName;
fMagic: cardinal;
public
/// the associated file handle
Handle: integer;
/// the total number of entries
Count: integer;
/// the resulting file entries
Entry: array of record
/// the file name
name: TZipName;
/// the corresponding file header
fhr: TFileHeader;
end;
/// initialize the .zip file
constructor Create(const aFileName: TFileName); overload;
/// compress (using the deflate method) a memory buffer, and add it to the zip file
// - by default, the 1st of January, 2010 is used if not date is supplied
procedure AddDeflated(const aZipName: TZipName; Buf: pointer; Size:
integer; CompressLevel: integer = 6; FileAge: integer = 1 + 1 shl 5 + 30
shl 9); overload;
/// compress (using the deflate method) a file, and add it to the zip file
procedure AddDeflated(const aFileName: TFileName; RemovePath: boolean = true;
CompressLevel: integer = 6); overload;
/// add a memory buffer to the zip file, without compression
// - content is stored, not deflated
// (in that case, no deflate code is added to the executable)
// - by default, the 1st of January, 2010 is used if not date is supplied
procedure AddStored(const aZipName: TZipName; Buf: pointer; Size: integer;
FileAge: integer = 1 + 1 shl 5 + 30 shl 9);
{$ifdef MSWINDOWS}
/// add a file from an already compressed zip entry
procedure AddFromZip(const ZipEntry: TZipEntry);
{$endif}
/// append a file content into the destination file
// - useful to add the initial Setup.exe file, e.g.
procedure Append(const Content: RawByteZip);
/// release associated memory, and close destination file
destructor Destroy; override;
end;
implementation
// special tuned Move() routine, including data overlap bug correction
{$ifdef PUREPASCAL}
procedure MoveWithOverlap(Src: PByte; Dst: PByte; Count: Integer);
var
i: integer;
begin // should be fast enough in practice
for i := 1 to Count do begin
Dst^ := Src^;
inc(Dst);
inc(Src);
end;
end;
{$else}
procedure MoveWithOverlap(Src: PByte; Dst: PByte; Count: Integer);
asm // eax=source edx=dest ecx=count
push edx
sub edx, eax
cmp edx, ecx // avoid move error if dest and source overlaps
pop edx // restore original edx=dest
ja System.Move // call FastMove() routine for normal code
or ecx, ecx
jz @@Exit
push edi
mov edi, edx // restore original edi=dest
@@overlap: // byte by byte slower but accurate move routine
mov dl, [eax]
inc eax
mov [edi], dl
inc edi
dec ecx
jnz @@overlap
pop edi
@@Exit:
end;
{$endif}
//----------------- general library stuff
const
CMemLevel = 8;
CWindowBits = 15;
type
TPInt64 = ^int64;
TPCardinal = ^cardinal;
TPWord = ^word;
TAByte = array[0..maxInt - 1] of byte;
TPAByte = ^TAByte;
TAWord = array[0..maxInt shr 1 - 1] of word;
TPAWord = ^TAWord;
TAInteger = array[0..maxInt shr 2 - 1] of integer;
TPAInteger = ^TAInteger;
TACardinal = array[0..maxInt shr 2 - 1] of cardinal;
TPACardinal = ^TACardinal;
TAInt64 = array[0..maxInt shr 3 - 1] of int64;
TPAInt64 = ^TAInt64;
PInflateHuft = ^TInflateHuft;
TInflateHuft = packed record
Exop, // number of extra bits or operation
Bits: Byte; // number of bits in this code or subcode
Base: Cardinal; // literal, Length base, or distance base or table offset
end;
THuftFields = array[0..(MaxInt div SizeOf(TInflateHuft)) - 1] of TInflateHuft;
PHuftField = ^THuftFields;
PPInflateHuft = ^PInflateHuft;
TInflateCodesMode = ( // waiting for "I:"=input, "O:"=output, "X:"=nothing
icmStart, // X: set up for Len
icmLen, // I: get length/literal/eob next
icmLenNext, // I: getting length extra (have base)
icmDistance, // I: get distance next
icmDistExt, // I: getting distance extra
icmCopy, // O: copying bytes in window, waiting for space
icmLit, // O: got literal, waiting for output space
icmWash, // O: got eob, possibly still output waiting
icmZEnd, // X: got eob and all data flushed
icmBadCode // X: got error
);
// inflate codes private state
PInflateCodesState = ^TInflateCodesState;
TInflateCodesState = record
Mode: TInflateCodesMode; // current inflate codes mode
// mode dependent information
Len: Cardinal;
Sub: record // submode
case Byte of
0:(Code: record // if Len or Distance, where in tree
Tree: PInflateHuft; // pointer into tree
need: Cardinal; // bits needed
end);
1:(lit: Cardinal); // if icmLit, literal
2:(copy: record // if EXT or icmCopy, where and how much
get: Cardinal; // bits to get for extra
Distance: Cardinal; // distance back to copy from
end);
end;
// mode independent information
LiteralTreeBits: Byte; // LiteralTree bits decoded per branch
DistanceTreeBits: Byte; // DistanceTree bits decoder per branch
LiteralTree: PInflateHuft; // literal/length/eob tree
DistanceTree: PInflateHuft; // distance tree
end;
TInflateBlockMode = (ibmZType, // get type bits (3, including end bit)
ibmLens, // get lengths for stored
ibmStored, // processing stored block
ibmTable, // get table lengths
ibmBitTree, // get bit lengths tree for a dynamic block
ibmDistTree, // get length, distance trees for a dynamic block
ibmCodes, // processing fixed or dynamic block
ibmDry, // output remaining window bytes
ibmBlockDone, // finished last block, done
ibmBlockBad // got a data error -> stuck here
);
// inflate blocks semi-private state
PInflateBlocksState = ^TInflateBlocksState;
TInflateBlocksState = record
Mode: TInflateBlockMode; // current inflate block mode
// mode dependent information
Sub: record // submode
case Byte of
0: (left: Cardinal); // if ibmStored, bytes left to copy
1: (Trees: record // if DistanceTree, decoding info for trees
Table: Cardinal; // table lengths (14 Bits)
Index: Cardinal; // index into blens (or BitOrder)
blens: TPACardinal; // bit lengths of codes
BB: Cardinal; // bit length tree depth
TB: PInflateHuft; // bit length decoding tree
end);
2: (decode: record // if ibmCodes, current state
TL: PInflateHuft;
TD: PInflateHuft; // trees to free
codes: PInflateCodesState;
end);
end;
Last: Boolean; // True if this block is the last block
// mode independent information
bitk: Cardinal; // bits in bit buffer
bitb: Cardinal; // bit buffer
hufts: PHuftField; // single allocation for tree space
window: PByte; // sliding window
zend: PByte; // one byte after sliding window
read: PByte; // window read pointer
write: PByte; // window write pointer
end;
// The application must update NextInput and AvailableInput when AvailableInput has dropped to zero. It must update
// NextOutput and AvailableOutput when AvailableOutput has dropped to zero. All other fields are set by the
// compression library and must not be updated by the application.
//
// The fields TotalInput and TotalOutput can be used for statistics or progress reports. After compression, TotalInput
// 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).
PZState = ^TZState;
TZState = record
NextInput: PByte; // next input byte
AvailableInput: Cardinal; // number of bytes available at NextInput
TotalInput: Cardinal; // total number of input bytes read so far
NextOutput: PByte; // next output byte should be put there
AvailableOutput: Cardinal; // remaining free space at NextOutput
TotalOutput: Cardinal; // total number of bytes output so far
State: PInflateBlocksState; // not visible by applications
end;
const
// Return codes for the compression/decompression functions. Negative
// values are errors, positive values are used for special but normal events.
Z_OK = 0;
Z_STREAM_END = 1;
Z_STREAM_ERROR = -2;
Z_DATA_ERROR = -3;
Z_MEM_ERROR = -4;
Z_BUF_ERROR = -5;
// three kinds of block type
STORED_BLOCK = 0;
STATIC_TREES = 1;
DYN_TREES = 2;
// minimum and maximum match lengths
MIN_MATCH = 3;
MAX_MATCH = 258;
//----------------- deflation support
const
LENGTH_CODES = 29; // number of length codes, not counting the special END_BLOCK code
LITERALS = 256; // number of literal bytes 0..255
L_CODES = (LITERALS + 1 + LENGTH_CODES);
// number of literal or length codes, including the END_BLOCK code
D_CODES = 30; // number of distance codes
BL_CODES = 19; // number of codes used to transfer the bit lengths
HEAP_SIZE = (2 * L_CODES + 1); // maximum heap size
MAX_BITS = 15; // all codes must not exceed MAX_BITS bits
type
// data structure describing a single value and its code string
PTreeEntry = ^TTreeEntry;
TTreeEntry = record
fc: record
case Byte of
0:
(Frequency: Word); // frequency count
1:
(Code: Word); // bit string
end;
dl: record
case Byte of
0:
(dad: Word); // father node in Huffman tree
1:
(Len: Word); // length of bit string
end;
end;
TLiteralTree = array[0..HEAP_SIZE - 1] of TTreeEntry; // literal and length tree
TDistanceTree = array[0..2 * D_CODES] of TTreeEntry; // distance tree
THuffmanTree = array[0..2 * BL_CODES] of TTreeEntry; // Huffman tree for bit lengths
PTree = ^TTree;
TTree = array[0..(MaxInt div SizeOf(TTreeEntry)) - 1] of TTreeEntry; // generic tree type
PStaticTreeDescriptor = ^TStaticTreeDescriptor;
TStaticTreeDescriptor = record
StaticTree: PTree; // static tree or nil
ExtraBits: TPAInteger; // extra bits for each code or nil
ExtraBase: Integer; // base index for ExtraBits
Elements: Integer; // max number of elements in the tree
MaxLength: Integer; // max bit length for the codes
end;
PTreeDescriptor = ^TTreeDescriptor;
TTreeDescriptor = record
DynamicTree: PTree;
MaxCode: Integer; // largest code with non zero frequency
StaticDescriptor: PStaticTreeDescriptor; // the corresponding static tree
end;
PDeflateState = ^TDeflateState;
TDeflateState = record
ZState: PZState; // pointer back to this zlib stream
PendingBuffer: TPAByte; // output still pending
PendingBufferSize: Integer;
PendingOutput: PByte; // next pending byte to output to the stream
Pending: Integer; // nb of bytes in the pending buffer
WindowSize: Cardinal; // LZ77 window size (32K by default)
WindowBits: Cardinal; // log2(WindowSize) (8..16)
WindowMask: Cardinal; // WindowSize - 1
// Sliding window. Input bytes are read into the second half of the window,
// and move to the first half later to keep a dictionary of at least WSize
// bytes. With this organization, matches are limited to a distance of
// WSize - MAX_MATCH bytes, but this ensures that IO is always
// performed with a length multiple of the block Size. Also, it limits
// the window Size to 64K, which is quite useful on MSDOS.
// To do: use the user input buffer as sliding window.
Window: TPAByte;
// Actual size of Window: 2 * WSize, except when the user input buffer
// is directly used as sliding window.
CurrentWindowSize: Integer;
// Link to older string with same hash index. to limit the size of this
// array to 64K, this link is maintained only for the last 32K strings.
// An index in this array is thus a window index modulo 32K.
Previous: TPAWord;
Head: TPAWord; // heads of the hash chains or nil
InsertHash: Cardinal; // hash index of string to be inserted
HashSize: Cardinal; // number of elements in hash table
HashBits: Cardinal; // log2(HashSize)
HashMask: Cardinal; // HashSize - 1
// Number of bits by which InsertHash must be shifted at each input step.
// It must be such that after MIN_MATCH steps, the oldest byte no longer
// takes part in the hash key, that is:
// HashShift * MIN_MATCH >= HashBits
HashShift: Cardinal;
// Window position at the beginning of the current output block. Gets
// negative when the window is moved backwards.
BlockStart: Integer;
MatchLength: Cardinal; // length of best match
PreviousMatch: Cardinal; // previous match
MatchAvailable: Boolean; // set if previous match exists
StringStart: Cardinal; // start of string to insert
MatchStart: Cardinal; // start of matching string
Lookahead: Cardinal; // number of valid bytes ahead in window
// Length of the best match at previous step. Matches not greater than this
// are discarded. This is used in the lazy match evaluation.
PreviousLength: Cardinal;
LiteralTree: TLiteralTree; // literal and length tree
DistanceTree: TDistanceTree; // distance tree
BitLengthTree: THuffmanTree; // Huffman tree for bit lengths
LiteralDescriptor: TTreeDescriptor; // Descriptor for literal tree
DistanceDescriptor: TTreeDescriptor; // Descriptor for distance tree
BitLengthDescriptor: TTreeDescriptor; // Descriptor for bit length tree
BitLengthCounts: array[0..MAX_BITS] of Word; // number of codes at each bit length for an optimal tree
Heap: array[0..2 * L_CODES] of Integer; // heap used to build the Huffman trees
HeapLength: Integer; // number of elements in the heap
HeapMaximum: Integer; // element of largest frequency
// The sons of Heap[N] are Heap[2 * N] and Heap[2 * N + 1]. Heap[0] is not used.
// The same heap array is used to build all trees.
Depth: array[0..2 * L_CODES] of Byte; // depth of each subtree used as tie breaker for trees of equal frequency
LiteralBuffer: TPAByte; // buffer for literals or lengths
// Size of match buffer for literals/lengths. There are 4 reasons for limiting LiteralBufferSize to 64K:
// - frequencies can be kept in 16 bit counters
// - If compression is not successful for the first block, all input
// data is still in the window so we can still emit a stored block even
// when input comes from standard input. This can also be done for
// all blocks if LiteralBufferSize is not greater than 32K.
// - if compression is not successful for a file smaller than 64K, we can
// even emit a stored file instead of a stored block (saving 5 bytes).
// This is applicable only for zip (not gzip or zlib).
// - creating new Huffman trees less frequently may not provide fast
// adaptation to changes in the input data statistics. (Take for
// example a binary file with poorly compressible code followed by
// a highly compressible string table.) Smaller buffer sizes give
// fast adaptation but have of course the overhead of transmitting
// trees more frequently.
// - I can't count above 4
LiteralBufferSize: Cardinal;
LastLiteral: Cardinal; // running index in LiteralBuffer
// Buffer for distances. To simplify the code, DistanceBuffer and LiteralBuffer have
// the same number of elements. To use different lengths, an extra flag array would be necessary.
DistanceBuffer: TPAWord;
OptimalLength: Integer; // bit length of current block with optimal trees
StaticLength: Integer; // bit length of current block with static trees
CompressedLength: Integer; // total bit length of compressed file
Matches: Cardinal; // number of string matches in current block
LastEOBLength: Integer; // bit length of EOB code for last block
BitsBuffer: Word; // Output buffer. Bits are inserted starting at the bottom (least significant bits).
ValidBits: Integer; // Number of valid bits in BitsBuffer. All Bits above the last valid bit are always zero.
end;
//----------------- Huffmann trees
const
DIST_CODE_LEN = 512; // see definition of array dist_code below
// The static literal tree. Since the bit lengths are imposed, there is no need for the L_CODES Extra codes used
// during heap construction. However the codes 286 and 287 are needed to build a canonical tree (see TreeInit below).
StaticLiteralTree: array[0..L_CODES + 1] of TTreeEntry = (
(fc: (Frequency: 12); dl: (Len: 8)), (fc: (Frequency: 140); dl: (Len: 8)), (fc: (Frequency: 76); dl: (Len: 8)),
(fc: (Frequency: 204); dl: (Len: 8)), (fc: (Frequency: 44); dl: (Len: 8)), (fc: (Frequency: 172); dl: (Len: 8)),
(fc: (Frequency: 108); dl: (Len: 8)), (fc: (Frequency: 236); dl: (Len: 8)), (fc: (Frequency: 28); dl: (Len: 8)),
(fc: (Frequency: 156); dl: (Len: 8)), (fc: (Frequency: 92); dl: (Len: 8)), (fc: (Frequency: 220); dl: (Len: 8)),
(fc: (Frequency: 60); dl: (Len: 8)), (fc: (Frequency: 188); dl: (Len: 8)), (fc: (Frequency: 124); dl: (Len: 8)),
(fc: (Frequency: 252); dl: (Len: 8)), (fc: (Frequency: 2); dl: (Len: 8)), (fc: (Frequency: 130); dl: (Len: 8)),
(fc: (Frequency: 66); dl: (Len: 8)), (fc: (Frequency: 194); dl: (Len: 8)), (fc: (Frequency: 34); dl: (Len: 8)),
(fc: (Frequency: 162); dl: (Len: 8)), (fc: (Frequency: 98); dl: (Len: 8)), (fc: (Frequency: 226); dl: (Len: 8)),
(fc: (Frequency: 18); dl: (Len: 8)), (fc: (Frequency: 146); dl: (Len: 8)), (fc: (Frequency: 82); dl: (Len: 8)),
(fc: (Frequency: 210); dl: (Len: 8)), (fc: (Frequency: 50); dl: (Len: 8)), (fc: (Frequency: 178); dl: (Len: 8)),
(fc: (Frequency: 114); dl: (Len: 8)), (fc: (Frequency: 242); dl: (Len: 8)), (fc: (Frequency: 10); dl: (Len: 8)),
(fc: (Frequency: 138); dl: (Len: 8)), (fc: (Frequency: 74); dl: (Len: 8)), (fc: (Frequency: 202); dl: (Len: 8)),
(fc: (Frequency: 42); dl: (Len: 8)), (fc: (Frequency: 170); dl: (Len: 8)), (fc: (Frequency: 106); dl: (Len: 8)),
(fc: (Frequency: 234); dl: (Len: 8)), (fc: (Frequency: 26); dl: (Len: 8)), (fc: (Frequency: 154); dl: (Len: 8)),
(fc: (Frequency: 90); dl: (Len: 8)), (fc: (Frequency: 218); dl: (Len: 8)), (fc: (Frequency: 58); dl: (Len: 8)),
(fc: (Frequency: 186); dl: (Len: 8)), (fc: (Frequency: 122); dl: (Len: 8)), (fc: (Frequency: 250); dl: (Len: 8)),
(fc: (Frequency: 6); dl: (Len: 8)), (fc: (Frequency: 134); dl: (Len: 8)), (fc: (Frequency: 70); dl: (Len: 8)),
(fc: (Frequency: 198); dl: (Len: 8)), (fc: (Frequency: 38); dl: (Len: 8)), (fc: (Frequency: 166); dl: (Len: 8)),
(fc: (Frequency: 102); dl: (Len: 8)), (fc: (Frequency: 230); dl: (Len: 8)), (fc: (Frequency: 22); dl: (Len: 8)),
(fc: (Frequency: 150); dl: (Len: 8)), (fc: (Frequency: 86); dl: (Len: 8)), (fc: (Frequency: 214); dl: (Len: 8)),
(fc: (Frequency: 54); dl: (Len: 8)), (fc: (Frequency: 182); dl: (Len: 8)), (fc: (Frequency: 118); dl: (Len: 8)),
(fc: (Frequency: 246); dl: (Len: 8)), (fc: (Frequency: 14); dl: (Len: 8)), (fc: (Frequency: 142); dl: (Len: 8)),
(fc: (Frequency: 78); dl: (Len: 8)), (fc: (Frequency: 206); dl: (Len: 8)), (fc: (Frequency: 46); dl: (Len: 8)),
(fc: (Frequency: 174); dl: (Len: 8)), (fc: (Frequency: 110); dl: (Len: 8)), (fc: (Frequency: 238); dl: (Len: 8)),
(fc: (Frequency: 30); dl: (Len: 8)), (fc: (Frequency: 158); dl: (Len: 8)), (fc: (Frequency: 94); dl: (Len: 8)),
(fc: (Frequency: 222); dl: (Len: 8)), (fc: (Frequency: 62); dl: (Len: 8)), (fc: (Frequency: 190); dl: (Len: 8)),
(fc: (Frequency: 126); dl: (Len: 8)), (fc: (Frequency: 254); dl: (Len: 8)), (fc: (Frequency: 1); dl: (Len: 8)),
(fc: (Frequency: 129); dl: (Len: 8)), (fc: (Frequency: 65); dl: (Len: 8)), (fc: (Frequency: 193); dl: (Len: 8)),
(fc: (Frequency: 33); dl: (Len: 8)), (fc: (Frequency: 161); dl: (Len: 8)), (fc: (Frequency: 97); dl: (Len: 8)),
(fc: (Frequency: 225); dl: (Len: 8)), (fc: (Frequency: 17); dl: (Len: 8)), (fc: (Frequency: 145); dl: (Len: 8)),
(fc: (Frequency: 81); dl: (Len: 8)), (fc: (Frequency: 209); dl: (Len: 8)), (fc: (Frequency: 49); dl: (Len: 8)),
(fc: (Frequency: 177); dl: (Len: 8)), (fc: (Frequency: 113); dl: (Len: 8)), (fc: (Frequency: 241); dl: (Len: 8)),
(fc: (Frequency: 9); dl: (Len: 8)), (fc: (Frequency: 137); dl: (Len: 8)), (fc: (Frequency: 73); dl: (Len: 8)),
(fc: (Frequency: 201); dl: (Len: 8)), (fc: (Frequency: 41); dl: (Len: 8)), (fc: (Frequency: 169); dl: (Len: 8)),
(fc: (Frequency: 105); dl: (Len: 8)), (fc: (Frequency: 233); dl: (Len: 8)), (fc: (Frequency: 25); dl: (Len: 8)),
(fc: (Frequency: 153); dl: (Len: 8)), (fc: (Frequency: 89); dl: (Len: 8)), (fc: (Frequency: 217); dl: (Len: 8)),
(fc: (Frequency: 57); dl: (Len: 8)), (fc: (Frequency: 185); dl: (Len: 8)), (fc: (Frequency: 121); dl: (Len: 8)),
(fc: (Frequency: 249); dl: (Len: 8)), (fc: (Frequency: 5); dl: (Len: 8)), (fc: (Frequency: 133); dl: (Len: 8)),
(fc: (Frequency: 69); dl: (Len: 8)), (fc: (Frequency: 197); dl: (Len: 8)), (fc: (Frequency: 37); dl: (Len: 8)),
(fc: (Frequency: 165); dl: (Len: 8)), (fc: (Frequency: 101); dl: (Len: 8)), (fc: (Frequency: 229); dl: (Len: 8)),
(fc: (Frequency: 21); dl: (Len: 8)), (fc: (Frequency: 149); dl: (Len: 8)), (fc: (Frequency: 85); dl: (Len: 8)),
(fc: (Frequency: 213); dl: (Len: 8)), (fc: (Frequency: 53); dl: (Len: 8)), (fc: (Frequency: 181); dl: (Len: 8)),
(fc: (Frequency: 117); dl: (Len: 8)), (fc: (Frequency: 245); dl: (Len: 8)), (fc: (Frequency: 13); dl: (Len: 8)),
(fc: (Frequency: 141); dl: (Len: 8)), (fc: (Frequency: 77); dl: (Len: 8)), (fc: (Frequency: 205); dl: (Len: 8)),
(fc: (Frequency: 45); dl: (Len: 8)), (fc: (Frequency: 173); dl: (Len: 8)), (fc: (Frequency: 109); dl: (Len: 8)),
(fc: (Frequency: 237); dl: (Len: 8)), (fc: (Frequency: 29); dl: (Len: 8)), (fc: (Frequency: 157); dl: (Len: 8)),
(fc: (Frequency: 93); dl: (Len: 8)), (fc: (Frequency: 221); dl: (Len: 8)), (fc: (Frequency: 61); dl: (Len: 8)),
(fc: (Frequency: 189); dl: (Len: 8)), (fc: (Frequency: 125); dl: (Len: 8)), (fc: (Frequency: 253); dl: (Len: 8)),
(fc: (Frequency: 19); dl: (Len: 9)), (fc: (Frequency: 275); dl: (Len: 9)), (fc: (Frequency: 147); dl: (Len: 9)),
(fc: (Frequency: 403); dl: (Len: 9)), (fc: (Frequency: 83); dl: (Len: 9)), (fc: (Frequency: 339); dl: (Len: 9)),
(fc: (Frequency: 211); dl: (Len: 9)), (fc: (Frequency: 467); dl: (Len: 9)), (fc: (Frequency: 51); dl: (Len: 9)),
(fc: (Frequency: 307); dl: (Len: 9)), (fc: (Frequency: 179); dl: (Len: 9)), (fc: (Frequency: 435); dl: (Len: 9)),
(fc: (Frequency: 115); dl: (Len: 9)), (fc: (Frequency: 371); dl: (Len: 9)), (fc: (Frequency: 243); dl: (Len: 9)),
(fc: (Frequency: 499); dl: (Len: 9)), (fc: (Frequency: 11); dl: (Len: 9)), (fc: (Frequency: 267); dl: (Len: 9)),
(fc: (Frequency: 139); dl: (Len: 9)), (fc: (Frequency: 395); dl: (Len: 9)), (fc: (Frequency: 75); dl: (Len: 9)),
(fc: (Frequency: 331); dl: (Len: 9)), (fc: (Frequency: 203); dl: (Len: 9)), (fc: (Frequency: 459); dl: (Len: 9)),
(fc: (Frequency: 43); dl: (Len: 9)), (fc: (Frequency: 299); dl: (Len: 9)), (fc: (Frequency: 171); dl: (Len: 9)),
(fc: (Frequency: 427); dl: (Len: 9)), (fc: (Frequency: 107); dl: (Len: 9)), (fc: (Frequency: 363); dl: (Len: 9)),
(fc: (Frequency: 235); dl: (Len: 9)), (fc: (Frequency: 491); dl: (Len: 9)), (fc: (Frequency: 27); dl: (Len: 9)),
(fc: (Frequency: 283); dl: (Len: 9)), (fc: (Frequency: 155); dl: (Len: 9)), (fc: (Frequency: 411); dl: (Len: 9)),
(fc: (Frequency: 91); dl: (Len: 9)), (fc: (Frequency: 347); dl: (Len: 9)), (fc: (Frequency: 219); dl: (Len: 9)),
(fc: (Frequency: 475); dl: (Len: 9)), (fc: (Frequency: 59); dl: (Len: 9)), (fc: (Frequency: 315); dl: (Len: 9)),
(fc: (Frequency: 187); dl: (Len: 9)), (fc: (Frequency: 443); dl: (Len: 9)), (fc: (Frequency: 123); dl: (Len: 9)),
(fc: (Frequency: 379); dl: (Len: 9)), (fc: (Frequency: 251); dl: (Len: 9)), (fc: (Frequency: 507); dl: (Len: 9)),
(fc: (Frequency: 7); dl: (Len: 9)), (fc: (Frequency: 263); dl: (Len: 9)), (fc: (Frequency: 135); dl: (Len: 9)),
(fc: (Frequency: 391); dl: (Len: 9)), (fc: (Frequency: 71); dl: (Len: 9)), (fc: (Frequency: 327); dl: (Len: 9)),
(fc: (Frequency: 199); dl: (Len: 9)), (fc: (Frequency: 455); dl: (Len: 9)), (fc: (Frequency: 39); dl: (Len: 9)),
(fc: (Frequency: 295); dl: (Len: 9)), (fc: (Frequency: 167); dl: (Len: 9)), (fc: (Frequency: 423); dl: (Len: 9)),
(fc: (Frequency: 103); dl: (Len: 9)), (fc: (Frequency: 359); dl: (Len: 9)), (fc: (Frequency: 231); dl: (Len: 9)),
(fc: (Frequency: 487); dl: (Len: 9)), (fc: (Frequency: 23); dl: (Len: 9)), (fc: (Frequency: 279); dl: (Len: 9)),
(fc: (Frequency: 151); dl: (Len: 9)), (fc: (Frequency: 407); dl: (Len: 9)), (fc: (Frequency: 87); dl: (Len: 9)),
(fc: (Frequency: 343); dl: (Len: 9)), (fc: (Frequency: 215); dl: (Len: 9)), (fc: (Frequency: 471); dl: (Len: 9)),
(fc: (Frequency: 55); dl: (Len: 9)), (fc: (Frequency: 311); dl: (Len: 9)), (fc: (Frequency: 183); dl: (Len: 9)),
(fc: (Frequency: 439); dl: (Len: 9)), (fc: (Frequency: 119); dl: (Len: 9)), (fc: (Frequency: 375); dl: (Len: 9)),
(fc: (Frequency: 247); dl: (Len: 9)), (fc: (Frequency: 503); dl: (Len: 9)), (fc: (Frequency: 15); dl: (Len: 9)),
(fc: (Frequency: 271); dl: (Len: 9)), (fc: (Frequency: 143); dl: (Len: 9)), (fc: (Frequency: 399); dl: (Len: 9)),
(fc: (Frequency: 79); dl: (Len: 9)), (fc: (Frequency: 335); dl: (Len: 9)), (fc: (Frequency: 207); dl: (Len: 9)),
(fc: (Frequency: 463); dl: (Len: 9)), (fc: (Frequency: 47); dl: (Len: 9)), (fc: (Frequency: 303); dl: (Len: 9)),
(fc: (Frequency: 175); dl: (Len: 9)), (fc: (Frequency: 431); dl: (Len: 9)), (fc: (Frequency: 111); dl: (Len: 9)),
(fc: (Frequency: 367); dl: (Len: 9)), (fc: (Frequency: 239); dl: (Len: 9)), (fc: (Frequency: 495); dl: (Len: 9)),
(fc: (Frequency: 31); dl: (Len: 9)), (fc: (Frequency: 287); dl: (Len: 9)), (fc: (Frequency: 159); dl: (Len: 9)),
(fc: (Frequency: 415); dl: (Len: 9)), (fc: (Frequency: 95); dl: (Len: 9)), (fc: (Frequency: 351); dl: (Len: 9)),
(fc: (Frequency: 223); dl: (Len: 9)), (fc: (Frequency: 479); dl: (Len: 9)), (fc: (Frequency: 63); dl: (Len: 9)),
(fc: (Frequency: 319); dl: (Len: 9)), (fc: (Frequency: 191); dl: (Len: 9)), (fc: (Frequency: 447); dl: (Len: 9)),
(fc: (Frequency: 127); dl: (Len: 9)), (fc: (Frequency: 383); dl: (Len: 9)), (fc: (Frequency: 255); dl: (Len: 9)),
(fc: (Frequency: 511); dl: (Len: 9)), (fc: (Frequency: 0); dl: (Len: 7)), (fc: (Frequency: 64); dl: (Len: 7)),
(fc: (Frequency: 32); dl: (Len: 7)), (fc: (Frequency: 96); dl: (Len: 7)), (fc: (Frequency: 16); dl: (Len: 7)),
(fc: (Frequency: 80); dl: (Len: 7)), (fc: (Frequency: 48); dl: (Len: 7)), (fc: (Frequency: 112); dl: (Len: 7)),
(fc: (Frequency: 8); dl: (Len: 7)), (fc: (Frequency: 72); dl: (Len: 7)), (fc: (Frequency: 40); dl: (Len: 7)),
(fc: (Frequency: 104); dl: (Len: 7)), (fc: (Frequency: 24); dl: (Len: 7)), (fc: (Frequency: 88); dl: (Len: 7)),
(fc: (Frequency: 56); dl: (Len: 7)), (fc: (Frequency: 120); dl: (Len: 7)), (fc: (Frequency: 4); dl: (Len: 7)),
(fc: (Frequency: 68); dl: (Len: 7)), (fc: (Frequency: 36); dl: (Len: 7)), (fc: (Frequency: 100); dl: (Len: 7)),
(fc: (Frequency: 20); dl: (Len: 7)), (fc: (Frequency: 84); dl: (Len: 7)), (fc: (Frequency: 52); dl: (Len: 7)),
(fc: (Frequency: 116); dl: (Len: 7)), (fc: (Frequency: 3); dl: (Len: 8)), (fc: (Frequency: 131); dl: (Len: 8)),
(fc: (Frequency: 67); dl: (Len: 8)), (fc: (Frequency: 195); dl: (Len: 8)), (fc: (Frequency: 35); dl: (Len: 8)),
(fc: (Frequency: 163); dl: (Len: 8)), (fc: (Frequency: 99); dl: (Len: 8)), (fc: (Frequency: 227); dl: (Len: 8))
);
// The static distance tree. (Actually a trivial tree since all lens use 5 Bits.)
StaticDescriptorTree: array[0..D_CODES - 1] of TTreeEntry = (
(fc: (Frequency: 0); dl: (Len: 5)), (fc: (Frequency: 16); dl: (Len: 5)), (fc: (Frequency: 8); dl: (Len: 5)),
(fc: (Frequency: 24); dl: (Len: 5)), (fc: (Frequency: 4); dl: (Len: 5)), (fc: (Frequency: 20); dl: (Len: 5)),
(fc: (Frequency: 12); dl: (Len: 5)), (fc: (Frequency: 28); dl: (Len: 5)), (fc: (Frequency: 2); dl: (Len: 5)),
(fc: (Frequency: 18); dl: (Len: 5)), (fc: (Frequency: 10); dl: (Len: 5)), (fc: (Frequency: 26); dl: (Len: 5)),
(fc: (Frequency: 6); dl: (Len: 5)), (fc: (Frequency: 22); dl: (Len: 5)), (fc: (Frequency: 14); dl: (Len: 5)),
(fc: (Frequency: 30); dl: (Len: 5)), (fc: (Frequency: 1); dl: (Len: 5)), (fc: (Frequency: 17); dl: (Len: 5)),
(fc: (Frequency: 9); dl: (Len: 5)), (fc: (Frequency: 25); dl: (Len: 5)), (fc: (Frequency: 5); dl: (Len: 5)),
(fc: (Frequency: 21); dl: (Len: 5)), (fc: (Frequency: 13); dl: (Len: 5)), (fc: (Frequency: 29); dl: (Len: 5)),
(fc: (Frequency: 3); dl: (Len: 5)), (fc: (Frequency: 19); dl: (Len: 5)), (fc: (Frequency: 11); dl: (Len: 5)),
(fc: (Frequency: 27); dl: (Len: 5)), (fc: (Frequency: 7); dl: (Len: 5)), (fc: (Frequency: 23); dl: (Len: 5))
);
// Distance codes. The first 256 values correspond to the distances 3 .. 258, the last 256 values correspond to the
// top 8 Bits of the 15 bit distances.
DistanceCode: array[0..DIST_CODE_LEN - 1] of Byte = (
0, 1, 2, 3, 4, 4, 5, 5, 6, 6, 6, 6, 7, 7, 7, 7, 8, 8, 8, 8,
8, 8, 8, 8, 9, 9, 9, 9, 9, 9, 9, 9, 10, 10, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11,
11, 11, 11, 11, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12,
12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 13, 13, 13, 13,
13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
13, 13, 13, 13, 13, 13, 13, 13, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 16, 17,
18, 18, 19, 19, 20, 20, 20, 20, 21, 21, 21, 21, 22, 22, 22, 22, 22, 22, 22, 22,
23, 23, 23, 23, 23, 23, 23, 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,
24, 24, 24, 24, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,
26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26,
26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 27, 27,
27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27,
27, 27, 27, 27, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
28, 28, 28, 28, 28, 28, 28, 28, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29,
29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29,
29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29,
29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29
);
// length code for each normalized match length (0 = MIN_MATCH)
LengthCode: array[0..MAX_MATCH - MIN_MATCH] of Byte = (
0, 1, 2, 3, 4, 5, 6, 7, 8, 8, 9, 9, 10, 10, 11, 11, 12, 12, 12, 12,
13, 13, 13, 13, 14, 14, 14, 14, 15, 15, 15, 15, 16, 16, 16, 16, 16, 16, 16, 16,
17, 17, 17, 17, 17, 17, 17, 17, 18, 18, 18, 18, 18, 18, 18, 18, 19, 19, 19, 19,
19, 19, 19, 19, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 22, 22, 22, 22,
22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 23, 23, 23, 23, 23, 23, 23, 23,
23, 23, 23, 23, 23, 23, 23, 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,
24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,
25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,
25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 26, 26, 26, 26, 26, 26, 26, 26,
26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26,
26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27,
27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 28
);
// first normalized length for each code (0 = MIN_MATCH)
BaseLength: array[0..LENGTH_CODES - 1] of byte = (
0, 1, 2, 3, 4, 5, 6, 7, 8, 10, 12, 14, 16, 20, 24, 28, 32, 40, 48, 56,
64, 80, 96, 112, 128, 160, 192, 224, 0
);
// first normalized distance for each code (0 = distance of 1)
BaseDistance: array[0..D_CODES - 1] of Integer = (
0, 1, 2, 3, 4, 6, 8, 12, 16, 24,
32, 48, 64, 96, 128, 192, 256, 384, 512, 768,
1024, 1536, 2048, 3072, 4096, 6144, 8192, 12288, 16384, 24576
);
MIN_LOOKAHEAD = (MAX_MATCH + MIN_MATCH + 1);
MAX_BL_BITS = 7; // bit length codes must not exceed MAX_BL_BITS bits
END_BLOCK = 256; // end of block literal code
REP_3_6 = 16; // repeat previous bit length 3-6 times (2 Bits of repeat count)
REPZ_3_10 = 17; // repeat a zero length 3-10 times (3 Bits of repeat count)
REPZ_11_138 = 18; // repeat a zero length 11-138 times (7 Bits of repeat count)
// extra bits for each length code
ExtraLengthBits: array[0..LENGTH_CODES - 1] of Integer = (
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
);
// extra bits for each distance code
ExtraDistanceBits: array[0..D_CODES - 1] of Integer = (
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
);
// extra bits for each bit length code
ExtraBitLengthBits: array[0..BL_CODES - 1] of Integer = (
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 3, 7
);
// The lengths of the bit length codes are sent in order of decreasing probability,
// to avoid transmitting the lengths for unused bit length codes.
BitLengthOrder: array[0..BL_CODES - 1] of Byte = (
16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15
);
// Number of bits used within BitsBuffer. (BitsBuffer might be implemented on more than 16 bits on some systems.)
BufferSize = 16;
StaticLiteralDescriptor: TStaticTreeDescriptor = (
StaticTree: @StaticLiteralTree; // pointer to array of TTreeEntry
ExtraBits: @ExtraLengthBits; // pointer to array of integer
ExtraBase: LITERALS + 1;
Elements: L_CODES;
MaxLength: MAX_BITS
);
StaticDistanceDescriptor: TStaticTreeDescriptor = (
StaticTree: @StaticDescriptorTree;
ExtraBits: @ExtraDistanceBits;
ExtraBase: 0;
Elements: D_CODES;
MaxLength: MAX_BITS
);
StaticBitLengthDescriptor: TStaticTreeDescriptor = (
StaticTree: nil;
ExtraBits: @ExtraBitLengthBits;
ExtraBase: 0;
Elements: BL_CODES;
MaxLength: MAX_BL_BITS
);
//----------------- Inflate support
{$ifndef FPC}
type
PtrUInt = {$ifdef CPU64}NativeUInt{$else}cardinal{$endif};
{$endif FPC}
const
InflateMask: array[0..16] of Cardinal = ($0000, $0001, $0003, $0007, $000F,
$001F, $003F, $007F, $00FF, $01FF, $03FF, $07FF, $0FFF, $1FFF, $3FFF, $7FFF, $FFFF);
function InflateFlush(var S: TInflateBlocksState; var Z: TZState; R: Integer): Integer;
// copies as much as possible from the sliding window to the output area
var
N: Cardinal;
P: PByte;
Q: PByte;
begin
// local copies of source and destination pointers
P := Z.NextOutput;
Q := S.Read;
// compute number of bytes to copy as far as end of window
if PtrUInt(Q) <= PtrUInt(S.Write) then
N := PtrUInt(S.Write) - PtrUInt(Q)
else
N := PtrUInt(S.zend) - PtrUInt(Q);
if N > Z.AvailableOutput then
N := Z.AvailableOutput;
if (N <> 0) and (R = Z_BUF_ERROR) then
R := Z_OK;
// update counters
Dec(Z.AvailableOutput, N);
Inc(Z.TotalOutput, N);
// copy as far as end of Window
Move(Q^, P^, 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 := PtrUInt(S.write) - PtrUInt(Q);
if N > Z.AvailableOutput then
N := Z.AvailableOutput;
if (N <> 0) and (R = Z_BUF_ERROR) then
R := Z_OK;
// update counters
Dec(Z.AvailableOutput, N);
Inc(Z.TotalOutput, N);
// copy
Move(Q^, P^, N);
Inc(P, N);
Inc(Q, N);
end;
// update pointers
Z.NextOutput := P;
S.Read := Q;
Result := R;
end;
function InflateFast(LiteralBits, DistanceBits: Cardinal; TL, TD: PInflateHuft;
var S: TInflateBlocksState; var Z: TZState): Integer;
// 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.
var
Temp: PInflateHuft;
Extra: Cardinal; // extra bits or operation
BitsBuffer: Cardinal;
K: Cardinal; // bits in bit buffer
P: PByte; // input data pointer
N: Cardinal; // bytes available there
Q: PByte; // output window write pointer
M: Cardinal; // bytes to end of window or read pointer
ml: Cardinal; // mask for literal/length tree
md: Cardinal; // mask for distance tree
C: Cardinal; // bytes to copy
D: Cardinal; // distance back to copy from
R: PByte; // copy source pointer
begin
// load input, output, bit values
P := Z.NextInput;
N := Z.AvailableInput;
BitsBuffer := S.bitb;
K := S.bitk;
Q := S.write;
if PtrUInt(Q) < PtrUInt(S.Read) then
M := PtrUInt(S.read) - PtrUInt(Q) - 1
else
M := PtrUInt(S.zend) - PtrUInt(Q);
// initialize masks
ml := InflateMask[LiteralBits];
md := InflateMask[DistanceBits];
// do until not enough input or output space for fast loop,
// assume called with (M >= 258) and (N >= 10)
repeat
// get literal/length Code
while K < 20 do begin
Dec(N);
BitsBuffer := BitsBuffer or (cardinal(P^) shl K);
Inc(K, 8);
Inc(P);
end;
Temp := @PHuftField(TL)[BitsBuffer and ml];
Extra := Temp.exop;
if Extra = 0 then begin
BitsBuffer := BitsBuffer shr Temp.Bits;
Dec(K, Temp.Bits);
Q^ := Temp.Base;
Inc(Q);
Dec(M);
if (M >= 258) and (N >= 10) then
continue
else
break;
end;
repeat
BitsBuffer := BitsBuffer shr Temp.Bits;
Dec(K, Temp.Bits);
if (Extra and 16) <> 0 then begin
// get extra bits for length
Extra := Extra and 15;
C := Temp.Base + (BitsBuffer and InflateMask[Extra]);
BitsBuffer := BitsBuffer shr Extra;
Dec(K, Extra);
// decode distance base of block to copy
while K < 15 do begin
Dec(N);
BitsBuffer := BitsBuffer or (Cardinal(P^) shl K);
Inc(P);
Inc(K, 8);
end;
Temp := @PHuftField(TD)[BitsBuffer and md];
Extra := Temp.exop;
repeat
BitsBuffer := BitsBuffer shr Temp.Bits;
Dec(K, Temp.Bits);
if (Extra and 16) <> 0 then begin
// get extra bits to add to distance base
Extra := Extra and 15;
while K < Extra do begin
Dec(N);
BitsBuffer := BitsBuffer or (Cardinal(P^) shl K);
Inc(P);
Inc(K, 8);
end;
D := Temp.Base + (BitsBuffer and InflateMask[Extra]);
BitsBuffer := BitsBuffer shr Extra;
Dec(K, Extra);
// do the copy
Dec(M, C);
// offset before Dest
if (PtrUInt(Q) - PtrUInt(S.Window)) >= D then begin
// copy without extra
R := Q;
Dec(R, D);
end
else begin
// offset after destination,
// bytes from offset to end
Extra := D - (PtrUInt(Q) - PtrUInt(S.Window));
R := S.zend;
// pointer to offset
Dec(R, Extra);
if C > Extra then begin
// copy to end of window
Dec(C, Extra);
MoveWithOverlap(R, Q, Extra);
inc(Q, Extra);
// copy rest from start of window
R := S.Window;
end;
end;
// copy all or what's left
Extra := C; // optimize generated code
MoveWithOverlap(R, Q, Extra);
inc(Q,Extra);
Break;
end
else if (Extra and 64) = 0 then begin
Inc(Temp, Temp.Base + (BitsBuffer and InflateMask[Extra]));
Extra := Temp.exop;
end
else begin
C := Z.AvailableInput - N;
if (K shr 3) < C then
C := K shr 3;
Inc(N, C);
Dec(P, C);
Dec(K, C shl 3);
S.bitb := BitsBuffer;
S.bitk := K;
Z.AvailableInput := N;
Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput));
Z.NextInput := P;
S.write := Q;
Result := Z_DATA_ERROR;
Exit;
end;
until False;
Break;
end;
if (Extra and 64) = 0 then begin
Inc(Temp, Temp.Base + (BitsBuffer and InflateMask[Extra]));
Extra := Temp.exop;
if Extra = 0 then begin
BitsBuffer := BitsBuffer shr Temp.Bits;
Dec(K, Temp.Bits);
Q^ := Temp.Base;
Inc(Q);
Dec(M);
Break;
end;
end
else if (Extra and 32) <> 0 then begin
C := Z.AvailableInput - N;
if (K shr 3) < C then
C := K shr 3;
Inc(N, C);
Dec(P, C);
Dec(K, C shl 3);
S.bitb := BitsBuffer;
S.bitk := K;
Z.AvailableInput := N;
Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput));
Z.NextInput := P;
S.write := Q;
Result := Z_STREAM_END;
Exit;
end
else begin
C := Z.AvailableInput - N;
if (K shr 3) < C then
C := K shr 3;
Inc(N, C);
Dec(P, C);
Dec(K, C shl 3);
S.bitb := BitsBuffer;
S.bitk := K;
Z.AvailableInput := N;
Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput));
Z.NextInput := P;
S.write := Q;
Result := Z_DATA_ERROR;
Exit;
end;
until False;
if (M < 258) or (N < 10) then
break;
until false;
// not enough input or output -> restore pointers and return
C := Z.AvailableInput - N;
if (K shr 3) < C then
C := K shr 3;
Inc(N, C);
Dec(P, C);
Dec(K, C shl 3);
S.bitb := BitsBuffer;
S.bitk := K;
Z.AvailableInput := N;
Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput));
Z.NextInput := P;
S.write := Q;
Result := Z_OK;
end;
function InflateCodesNew(LiteralBits: Cardinal; DistanceBits: Cardinal; TL, TD:
PInflateHuft; var Z: TZState): PInflateCodesState;
begin
GetMem(result, SizeOf(TInflateCodesState));
Result.Mode := icmStart;
Result.LiteralTreeBits := LiteralBits;
Result.DistanceTreeBits := DistanceBits;
Result.LiteralTree := TL;
Result.DistanceTree := TD;
end;
function InflateCodes(var S: TInflateBlocksState; var Z: TZState; R: Integer): Integer;
var
J: Cardinal; // temporary storage
Temp: PInflateHuft;
Extra: Cardinal; // extra bits or operation
BitsBuffer: Cardinal;
K: Cardinal; // bits in bit buffer
P: PByte; // input data pointer
N: Cardinal; // bytes available there
Q: PByte; // output window write pointer
M: Cardinal; // bytes to end of window or read pointer
F: PByte; // pointer to copy strings from
C: PInflateCodesState;
begin
C := S.sub.decode.codes; // codes state
// copy input/output information to locals
P := Z.NextInput;
N := Z.AvailableInput;
BitsBuffer := S.bitb;
K := S.bitk;
Q := S.write;
if PtrUInt(Q) < PtrUInt(S.read) then
M := PtrUInt(S.read) - PtrUInt(Q) - 1
else
M := PtrUInt(S.zend) - PtrUInt(Q);
// process input and output based on current state
while True do begin
case C.Mode of
icmStart:
begin
if (M >= 258) and (N >= 10) then begin
S.bitb := BitsBuffer;
S.bitk := K;
Z.AvailableInput := N;
Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput));
Z.NextInput := P;
S.write := Q;
R := InflateFast(C.LiteralTreeBits, C.DistanceTreeBits, C.LiteralTree,
C.DistanceTree, S, Z);
P := Z.NextInput;
N := Z.AvailableInput;
BitsBuffer := S.bitb;
K := S.bitk;
Q := S.write;
if PtrUInt(Q) < PtrUInt(S.read) then
M := PtrUInt(S.read) - PtrUInt(Q) - 1
else
M := PtrUInt(S.zend) - PtrUInt(Q);
if R <> Z_OK then begin
if R = Z_STREAM_END then
C.mode := icmWash
else
C.mode := icmBadCode;
Continue;
end;
end;
C.sub.Code.need := C.LiteralTreeBits;
C.sub.Code.Tree := C.LiteralTree;
C.mode := icmLen;
end;
icmLen: // I: get length/literal/eob next
begin
J := C.sub.Code.need;
while K < J do begin
if N <> 0 then
R := Z_OK
else begin
S.bitb := BitsBuffer;
S.bitk := K;
Z.AvailableInput := N;
Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput));
Z.NextInput := P;
S.write := Q;
Result := InflateFlush(S, Z, R);
Exit;
end;
Dec(N);
BitsBuffer := BitsBuffer or (Cardinal(P^) shl K);
Inc(P);
Inc(K, 8);
end;
Temp := C.sub.Code.Tree;
Inc(Temp, Cardinal(BitsBuffer) and InflateMask[J]);
BitsBuffer := BitsBuffer shr Temp.Bits;
Dec(K, Temp.Bits);
Extra := Temp.exop;
// literal
if Extra = 0 then begin
C.sub.lit := Temp.Base;
C.mode := icmLit;
Continue;
end;
// length
if (Extra and 16) <> 0 then begin
C.sub.copy.get := Extra and 15;
C.Len := Temp.Base;
C.mode := icmLenNext;
Continue;
end;
// next table
if (Extra and 64) = 0 then begin
C.sub.Code.need := Extra;
C.sub.Code.Tree := @PHuftField(Temp)[Temp.Base];
Continue;
end;
// end of block
if (Extra and 32) <> 0 then begin
C.mode := icmWash;
Continue;
end;
// invalid code
C.mode := icmBadCode;
R := Z_DATA_ERROR;
S.bitb := BitsBuffer;
S.bitk := K;
Z.AvailableInput := N;
Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput));
Z.NextInput := P;
S.write := Q;
Result := InflateFlush(S, Z, R);
Exit;
end;
icmLenNext: // I: getting length extra (have base)
begin
J := C.sub.copy.get;
while K < J do begin
if N <> 0 then
R := Z_OK
else begin
S.bitb := BitsBuffer;
S.bitk := K;
Z.AvailableInput := N;
Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput));
Z.NextInput := P;
S.write := Q;
Result := InflateFlush(S, Z, R);
Exit;
end;
Dec(N);
BitsBuffer := BitsBuffer or (Cardinal(P^) shl K);
Inc(P);
Inc(K, 8);
end;
Inc(C.Len, Cardinal(BitsBuffer and InflateMask[J]));
BitsBuffer := BitsBuffer shr J;
Dec(K, J);
C.sub.Code.need := C.DistanceTreeBits;
C.sub.Code.Tree := C.DistanceTree;
C.mode := icmDistance;
end;
icmDistance: // I: get distance next
begin
J := C.sub.Code.need;
while K < J do begin
if N <> 0 then
R := Z_OK
else begin
S.bitb := BitsBuffer;
S.bitk := K;
Z.AvailableInput := N;
Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput));
Z.NextInput := P;
S.write := Q;
Result := InflateFlush(S, Z, R);
Exit;
end;
Dec(N);
BitsBuffer := BitsBuffer or (PtrUInt(P^) shl K);
Inc(P);
Inc(K, 8);
end;
Temp := @PHuftField(C.sub.Code.Tree)[BitsBuffer and InflateMask[J]];
BitsBuffer := BitsBuffer shr Temp.Bits;
Dec(K, Temp.Bits);
Extra := Temp.exop;
// distance
if (Extra and 16) <> 0 then begin
C.sub.copy.get := Extra and 15;
C.sub.copy.Distance := Temp.Base;
C.mode := icmDistExt;
Continue;
end;
// next table
if (Extra and 64) = 0 then begin
C.sub.Code.need := Extra;
C.sub.Code.Tree := @PHuftField(Temp)[Temp.Base];
Continue;
end;
// invalid code
C.mode := icmBadCode;
R := Z_DATA_ERROR;
S.bitb := BitsBuffer;
S.bitk := K;
Z.AvailableInput := N;
Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput));
Z.NextInput := P;
S.write := Q;
Result := InflateFlush(S, Z, R);
Exit;
end;
icmDistExt: // I: getting distance extra
begin
J := C.sub.copy.get;
while K < J do begin
if N <> 0 then
R := Z_OK
else begin
S.bitb := BitsBuffer;
S.bitk := K;
Z.AvailableInput := N;
Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput));
Z.NextInput := P;
S.write := Q;
Result := InflateFlush(S, Z, R);
Exit;
end;
Dec(N);
BitsBuffer := BitsBuffer or (Cardinal(P^) shl K);
Inc(P);
Inc(K, 8);
end;
Inc(C.sub.copy.Distance, Cardinal(BitsBuffer) and InflateMask[J]);
BitsBuffer := BitsBuffer shr J;
Dec(K, J);
C.mode := icmCopy;
end;
icmCopy: // O: copying bytes in window, waiting for space
begin
F := Q;
Dec(F, C.sub.copy.Distance);
if (PtrUInt(Q) - PtrUInt(S.Window)) < C.sub.copy.Distance then begin
F := S.zend;
Dec(F, C.sub.copy.Distance - (PtrUInt(Q) - PtrUInt(S.Window)));
end;
while C.Len <> 0 do begin
if M = 0 then begin
if (Q = S.zend) and (S.read <> S.Window) then begin
Q := S.Window;
if PtrUInt(Q) < PtrUInt(S.read) then
M := PtrUInt(S.read) - PtrUInt(Q) - 1
else
M := PtrUInt(S.zend) - PtrUInt(Q);
end;
if M = 0 then begin
S.write := Q;
R := InflateFlush(S, Z, R);
Q := S.write;
if PtrUInt(Q) < PtrUInt(S.read) then
M := PtrUInt(S.read) - PtrUInt(Q) - 1
else
M := PtrUInt(S.zend) - PtrUInt(Q);
if (Q = S.zend) and (S.read <> S.Window) then begin
Q := S.Window;
if PtrUInt(Q) < PtrUInt(S.read) then
M := PtrUInt(S.read) - PtrUInt(Q) - 1
else
M := PtrUInt(S.zend) - PtrUInt(Q);
end;
if M = 0 then begin
S.bitb := BitsBuffer;
S.bitk := K;
Z.AvailableInput := N;
Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput));
Z.NextInput := P;
S.write := Q;
Result := InflateFlush(S, Z, R);
Exit;
end;
end;
end;
R := Z_OK;
Q^ := F^;
Inc(Q);
Inc(F);
Dec(M);
if (F = S.zend) then
F := S.Window;
Dec(C.Len);
end;
C.mode := icmStart;
end;
icmLit: // O: got literal, waiting for output space
begin
if M = 0 then begin
if (Q = S.zend) and (S.read <> S.Window) then begin
Q := S.Window;
if PtrUInt(Q) < PtrUInt(S.read) then
M := PtrUInt(S.read) - PtrUInt(Q) - 1
else
M := PtrUInt(S.zend) - PtrUInt(Q);
end;
if M = 0 then begin
S.write := Q;
R := InflateFlush(S, Z, R);
Q := S.write;
if PtrUInt(Q) < PtrUInt(S.read) then
M := PtrUInt(S.read) - PtrUInt(Q) - 1
else
M := PtrUInt(S.zend) - PtrUInt(Q);
if (Q = S.zend) and (S.read <> S.Window) then begin
Q := S.Window;
if PtrUInt(Q) < PtrUInt(S.read) then
M := PtrUInt(S.read) - PtrUInt(Q) - 1
else
M := PtrUInt(S.zend) - PtrUInt(Q);
end;
if M = 0 then begin
S.bitb := BitsBuffer;
S.bitk := K;
Z.AvailableInput := N;
Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput));
Z.NextInput := P;
S.write := Q;
Result := InflateFlush(S, Z, R);
Exit;
end;
end;
end;
R := Z_OK;
Q^ := C.sub.lit;
Inc(Q);
Dec(M);
C.mode := icmStart;
end;
icmWash: // O: got eob, possibly More output
begin
// return unused byte, if any
if K > 7 then begin
Dec(K, 8);
Inc(N);
Dec(P);
// can always return one
end;
S.write := Q;
R := InflateFlush(S, Z, R);
Q := S.write;
if PtrUInt(Q) < PtrUInt(S.read) then
M := PtrUInt(S.read) - PtrUInt(Q) - 1
else
M := PtrUInt(S.zend) - PtrUInt(Q);
if S.read <> S.write then begin
S.bitb := BitsBuffer;
S.bitk := K;
Z.AvailableInput := N;
Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput));
Z.NextInput := P;
S.write := Q;
Result := InflateFlush(S, Z, R);
Exit;
end;
C.mode := icmZEnd;
end;
icmZEnd:
begin
R := Z_STREAM_END;
S.bitb := BitsBuffer;
S.bitk := K;
Z.AvailableInput := N;
Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput));
Z.NextInput := P;
S.write := Q;
Result := InflateFlush(S, Z, R);
Exit;
end;
icmBadCode: // X: got error
begin
R := Z_DATA_ERROR;
S.bitb := BitsBuffer;
S.bitk := K;
Z.AvailableInput := N;
Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput));
Z.NextInput := P;
S.write := Q;
Result := InflateFlush(S, Z, R);
Exit;
end;
else
begin
R := Z_STREAM_ERROR;
S.bitb := BitsBuffer;
S.bitk := K;
Z.AvailableInput := N;
Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput));
Z.NextInput := P;
S.write := Q;
Result := InflateFlush(S, Z, R);
Exit;
end;
end;
end;
Result := Z_STREAM_ERROR;
end;
type
TDeflateLengths = array[0..30] of Cardinal;
TDeflateWorkArea = array[0..287] of Cardinal;
const
// Maximum Size of dynamic tree. The maximum found in an integer 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.
MANY = 1440;
// Tables for deflate from PKZIP'S appnote.txt
// copy lengths for literal codes 257..285 (actually lengths - 2; also see note #13 above about 258)
CopyLengths: TDeflateLengths = (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);
INVALID_CODE = 112;
// extra bits for literal codes 257..285
CopyLiteralExtra: TDeflateLengths = (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);
// copy offsets for distance codes 0..29
CopyOffsets: TDeflateLengths = (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, 0);
// extra bits for distance codes
CopyExtra: TDeflateLengths = (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, 0);
// Huffman code decoding is performed using a multi-Level table lookup.
// 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 integer. 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 LiteralTreeBits and DistanceTreeBits
// below. LiteralTreeBits is the number of bits the first level table for literal/
// length codes can decode in one step, and DistanceTreeBits 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 LiteralTreeBits is 8 + 1 and DistanceTreeBits is 5 + 1.
// The optimum values may differ though from machine to machine, and possibly even between compilers.
const
// maximum bit length of any code,
// If BMAX needs to be larger than 16, then H and X[] should be Cardinal.
BMAX = 15;
function BuildHuffmanTables(const B: TACardinal; N, S: Cardinal; const D,
Extra: TDeflateLengths; Temp: PPInflateHuft; var M: Cardinal; HP: PHuftField;
var HN: Cardinal; var V: TDeflateWorkArea): Integer;
// Given a list of code lengths and a maximum table size, make a set of tables to decode that set of codes. Returns 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.
//
// Input parameters:
// B contains the code lenths in bits (all assumed <= BMAX)
// N is the number of codes (<= NMAX)
// S is the number of simple valued codes (0..S - 1)
// D contains a list of base values for non-simple codes
// Extra carries a list of extra bits for non-simple codes
//
// Output parameters:
// Temp points to the starting table
// M receives the maxium lookup bits (actual space for trees)
// HP receives the Huffman tables
// while HN decribes how many of HP is actually used
// finally V is a working area which receives values in order of bit length
var
A: Cardinal; // counter for codes of length K
F: Cardinal; // I repeats in table every F entries
G: Integer; // maximum code Length
H: Integer; // table Level
I: Cardinal; // counter, current code
J: Cardinal; // counter
K: Integer; // number of bits in current code
L: Integer; // bits per table (returned in M)
Mask: Cardinal; // (1 shl W) - 1, to avoid cc - O bug on HP
P: TPCardinal; // pointer into C[], B[], or V[]
Q: PInflateHuft; // points to current table
R: TInflateHuft; // table entry for structure assignment
XP: TPCardinal; // pointer into X
Y: Integer; // number of dummy codes added
Z: Cardinal; // number of entries in current table
W: Integer; // bits before this table = (L * H)
C: array[0..BMAX] of Cardinal; // bit length count table
U: array[0..BMAX - 1] of PInflateHuft; // table stack
X: array[0..BMAX] of Cardinal; // bit offsets, then code stack
begin
// generate counts for each bit length
FillChar(C, SizeOf(C), 0);
// assume all entries <= BMAX
for I := 0 to N - 1 do
Inc(C[B[I]]);
// nil input -> all zero length codes
if C[0] = N then begin
Temp^ := nil;
M := 0;
Result := 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;
// minimum code Length
K := J;
if Cardinal(L) < J then
L := J;
for I := BMAX downto 1 do
if C[I] <> 0 then
Break;
// maximum code length
G := I;
if Cardinal(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
// bad input: more codes than bits
Result := Z_DATA_ERROR;
Exit;
end;
Inc(J);
Y := Y shl 1;
end;
Dec(Y, C[I]);
if Y < 0 then begin
// bad input: more codes than bits
Result := Z_DATA_ERROR;
Exit;
end;
Inc(C[I], Y);
// generate starting offsets into the value table for each length
X[1] := 0;
J := 0;
for I := 1 to G - 1 do begin
inc(J, C[I]);
X[I + 1] := J;
end;
// 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;
// set N to Length of V
N := X[G];
// generate the Huffman codes and for each make the table entries
I := 0;
// first Huffman code is zero
X[0] := 0;
// grab values in bit order
P := @V;
// no tables yet -> Level - 1
H := -1;
// bits decoded = (L * H)
W := -L;
U[0] := nil;
Q := nil;
Z := 0;
// 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);
// add bits already decoded, previous table always L Bits
Inc(W, L);
// compute minimum size table less than or equal to L bits
Z := G - W;
if Z > Cardinal(L) then
Z := L;
// try a K - W bit table
J := K - W;
F := 1 shl J;
// too few codes for K - W bit table
if F > A + 1 then begin
// deduct codes from patterns left
Dec(F, A + 1);
XP := @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);
// enough codes to use up J Bits
if F <= XP^ then
Break;
// else deduct codes from patterns
Dec(F, XP^);
Inc(J);
end;
end;
end;
// table entries for J-bit table
Z := 1 shl J;
// allocate new table (note: doesn't matter for fixed)
if HN + Z > MANY then begin
Result := Z_MEM_ERROR;
Exit;
end;
Q := @HP[HN];
U[H] := Q;
Inc(HN, Z);
// connect to last table, if there is one
if H <> 0 then begin
// save pattern for backing up
X[H] := I;
// bits to dump before this table
R.Bits := L;
// bits in this table
R.exop := J;
J := I shr (W - L);
R.Base := (PtrUInt(Q) - PtrUInt(U[H - 1])) div SizeOf(Q^) - J;
// connect to last table
PHuftField(U[H - 1])[J] := R;
end
else
// first table is returned result
Temp^ := Q;
end;
// set up table entry in R
R.Bits := Byte(K - W);
// out of values -> invalid code
if PtrUInt(P) >= PtrUInt(@V[N]) then
R.exop := 128 + 64
else if P^ < S then begin
// 256 is end-of-block code
if P^ < 256 then
R.exop := 0
else
R.exop := 32 + 64;
// simple code is just the value
R.Base := P^;
Inc(P);
end
else begin
// non-simple -> look up in lists
R.exop := Byte(Extra[P^ - S] + 16 + 64);
R.Base := D[P^ - S];
Inc(P);
end;
// fill xode-like entries with R
F := 1 shl (K - W);
J := I shr W;
while J < Z do begin
PHuftField(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;
J := J shr 1
end;
I := I xor J;
// backup over finished tables
// needed on HP, cc -O bug
Mask := (1 shl W) - 1;
while (I and Mask) <> X[H] do begin
// don't need to update Q
Dec(H);
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
Result := Z_BUF_ERROR
else
Result := Z_OK;
end;
function InflateTreesBits(var C: TACardinal; var BB: Cardinal; var TB:
PInflateHuft; HP: PHuftField; var Z: TZState): Integer;
// C holds 19 code lengths
// BB - bits tree desired/actual depth
// TB - bits tree result
// HP - space for trees
// Z - for messages
var
R: Integer;
HN: Cardinal; // hufts used in space
V: TDeflateWorkArea; // work area for BuildHuffmanTables
begin
HN := 0;
R := BuildHuffmanTables(C, 19, 19, CopyLengths, CopyLiteralExtra, @TB, BB, HP, HN, V);
if (R = Z_BUF_ERROR) or (BB = 0) then
R := Z_DATA_ERROR;
Result := R;
end;
function InflateTreesDynamic(NL: Cardinal; ND: Cardinal; var C: TACardinal;
var LiteralBits: Cardinal; var DistanceBits: Cardinal; var TL: PInflateHuft;
var TD: PInflateHuft; HP: PHuftField; var Z: TZState): Integer;
// NL - number of literal/length codes
// ND - number of distance codes
// C - code lengths
// LiteralBits - literal desired/actual bit depth
// DistanceBits - distance desired/actual bit depth
// TL - literal/length tree result
// TD - distance tree result
// HP - space for trees
// Z - for messages
var
R: Integer;
HN: Cardinal; // hufts used in space
V: TDeflateWorkArea; // work area for BuildHuffmanTables
begin
HN := 0;
// allocate work area
Result := Z_OK;
// build literal/length tree
R := BuildHuffmanTables(C, NL, 257, CopyLengths, CopyLiteralExtra, @TL,
LiteralBits, HP, HN, V);
if (R <> Z_OK) or (LiteralBits = 0) then begin
Result := R;
Exit;
end;
// build distance tree
R := BuildHuffmanTables(TPACardinal(@C[NL])^, ND, 0, CopyOffsets, CopyExtra, @TD,
DistanceBits, HP, HN, V);
if (R <> Z_OK) or ((DistanceBits = 0) and (NL > 257)) then begin
if R = Z_BUF_ERROR then
R := Z_DATA_ERROR
else if R <> Z_MEM_ERROR then
R := Z_DATA_ERROR;
Result := R;
end;
end;
const
// number of hufts used by fixed tables
FIXEDH = 544;
var
// build fixed tables only once -> keep them here
FixedBuild: Boolean;
FixedTablesMemory: array[0..FIXEDH - 1] of TInflateHuft;
FixedLiteralBits: Cardinal;
FixedDistanceBits: Cardinal;
FixedLiteralTable: array[0..288 - 1] of TInflateHuft;
FixedDistanceTable: array[0..32 - 1] of TInflateHuft;
function InflateTreesFixed(var LiteralBits: Cardinal; var DistanceBits: Cardinal;
var TL, TD: PInflateHuft; var Z: TZState): Integer;
var
K: Integer; // temporary variable
C: TDeflateWorkArea; // length list for BuildHuffmanTables
V: TDeflateWorkArea; // work area for BuildHuffmanTables
F: Cardinal; // number of hufts used in FixedTablesMemory
begin
// build fixed tables if not already (multiple overlapped executions ok)
if not FixedBuild then begin
F := 0;
// literal table
for K := 0 to 143 do
C[K] := 8;
for K := 144 to 255 do
C[K] := 9;
for K := 256 to 279 do
C[K] := 7;
for K := 280 to 287 do
C[K] := 8;
FixedLiteralBits := 9;
BuildHuffmanTables(TPACardinal(@C)^, 288, 257, CopyLengths, CopyLiteralExtra, @FixedLiteralTable,
FixedLiteralBits, @FixedTablesMemory, F, V);
// distance table
for K := 0 to 29 do
C[K] := 5;
FixedDistanceBits := 5;
BuildHuffmanTables(TPACardinal(@C)^, 30, 0, CopyOffsets, CopyExtra, @FixedDistanceTable,
FixedDistanceBits, @FixedTablesMemory, F, V);
FixedBuild := True;
end;
LiteralBits := FixedLiteralBits;
DistanceBits := FixedDistanceBits;
TL := @FixedLiteralTable;
TD := @FixedDistanceTable;
Result := Z_OK;
end;
// tables for Deflate from PKZIP'S appnote.txt.
const
// order of the bit length code lengths
BitOrder: array[0..18] of byte = (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 defines 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 InflateBlockReset(var S: TInflateBlocksState; var Z: TZState);
begin
if (S.mode = ibmBitTree) or (S.mode = ibmDistTree) then
FreeMem(S.sub.trees.blens);
if S.mode = ibmCodes then
FreeMem(S.sub.decode.codes);
S.mode := ibmZType;
S.bitk := 0;
S.bitb := 0;
S.write := S.Window;
S.read := S.Window;
end;
function InflateBlocksNew(var Z: TZState; W: Cardinal): PInflateBlocksState;
// W is the window size
var
S: PInflateBlocksState;
begin
GetMem(S, SizeOf(TInflateBlocksState));
if S = nil then
Result := S
else
try
GetMem(S.hufts, SizeOf(TInflateHuft) * MANY);
GetMem(S.Window, W);
S.zend := S.Window;
Inc(S.zend, W);
S.mode := ibmZType;
InflateBlockReset(S^, Z);
Result := S;
except
if Assigned(S.Window) then
FreeMem(S.Window);
if Assigned(S.hufts) then
FreeMem(S.hufts);
FreeMem(S);
raise;
end;
end;
function InflateBlocks(var S: TInflateBlocksState; var Z: TZState; R: Integer): Integer;
// R contains the initial return code
var
Temp: Cardinal;
B: Cardinal; // bit buffer
K: Cardinal; // bits in bit buffer
P: PByte; // input data pointer
N: Cardinal; // bytes available there
Q: PByte; // output Window write pointer
M: Cardinal; // bytes to end of window or read pointer
// fixed code blocks
LiteralBits, DistanceBits: Cardinal;
TL, TD: PInflateHuft;
H: PInflateHuft;
I, J, C: Cardinal;
CodeState: PInflateCodesState;
function UpdatePointers: Integer;
begin
S.bitb := B;
S.bitk := K;
Z.AvailableInput := N;
Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput));
Z.NextInput := P;
S.write := Q;
Result := InflateFlush(S, Z, R);
end;
begin
// copy input/output information to locals
P := Z.NextInput;
N := Z.AvailableInput;
B := S.bitb;
K := S.bitk;
Q := S.write;
if PtrUInt(Q) < PtrUInt(S.read) then
M := PtrUInt(S.read) - PtrUInt(Q) - 1
else
M := PtrUInt(S.zend) - PtrUInt(Q);
// decompress an inflated block
// process input based on current state
while True do begin
case S.mode of
ibmZType:
begin
while K < 3 do begin
if N <> 0 then
R := Z_OK
else begin
Result := UpdatePointers;
Exit;
end;
Dec(N);
B := B or (Cardinal(P^) shl K);
Inc(P);
Inc(K, 8);
end;
Temp := B and 7;
S.last := Boolean(Temp and 1);
case Temp shr 1 of
0: // stored
begin
B := B shr 3;
Dec(K, 3);
// go to byte boundary
Temp := K and 7;
B := B shr Temp;
Dec(K, Temp);
// get length of stored block
S.mode := ibmLens;
end;
1: // fixed
begin
InflateTreesFixed(LiteralBits, DistanceBits, TL, TD, Z);
S.sub.decode.codes := InflateCodesNew(LiteralBits, DistanceBits,
TL, TD, Z);
if S.sub.decode.codes = nil then begin
R := Z_MEM_ERROR;
Result := UpdatePointers;
Exit;
end;
B := B shr 3;
Dec(K, 3);
S.mode := ibmCodes;
end;
2: // dynamic
begin
B := B shr 3;
Dec(K, 3);
S.mode := ibmTable;
end;
3: // illegal
begin
B := B shr 3;
Dec(K, 3);
S.mode := ibmBlockBad;
R := Z_DATA_ERROR;
Result := UpdatePointers;
Exit;
end;
end;
end;
ibmLens:
begin
while K < 32 do begin
if N <> 0 then
R := Z_OK
else begin
Result := UpdatePointers;
Exit;
end;
Dec(N);
B := B or (Cardinal(P^) shl K);
Inc(P);
Inc(K, 8);
end;
if (((not B) shr 16) and $FFFF) <> (B and $FFFF) then begin
S.mode := ibmBlockBad;
R := Z_DATA_ERROR;
Result := UpdatePointers;
Exit;
end;
S.sub.left := B and $FFFF;
K := 0;
B := 0;
if S.sub.left <> 0 then
S.mode := ibmStored
else if S.last then
S.mode := ibmDry
else
S.mode := ibmZType;
end;
ibmStored:
begin
if N = 0 then begin
Result := UpdatePointers;
Exit;
end;
if M = 0 then begin
if (Q = S.zend) and (S.read <> S.Window) then begin
Q := S.Window;
if PtrUInt(Q) < PtrUInt(S.read) then
M := PtrUInt(S.read) - PtrUInt(Q) - 1
else
M := PtrUInt(S.zend) - PtrUInt(Q);
end;
if M = 0 then begin
S.write := Q;
R := InflateFlush(S, Z, R);
Q := S.write;
if PtrUInt(Q) < PtrUInt(S.read) then
M := PtrUInt(S.read) - PtrUInt(Q) - 1
else
M := PtrUInt(S.zend) - PtrUInt(Q);
if (Q = S.zend) and (S.read <> S.Window) then begin
Q := S.Window;
if PtrUInt(Q) < PtrUInt(S.read) then
M := PtrUInt(S.read) - PtrUInt(Q) - 1
else
M := PtrUInt(S.zend) - PtrUInt(Q);
end;
if M = 0 then begin
Result := UpdatePointers;
Exit;
end;
end;
end;
R := Z_OK;
Temp := S.sub.left;
if Temp > N then
Temp := N;
if Temp > M then
Temp := M;
Move(P^, Q^, Temp);
Inc(P, Temp);
Dec(N, Temp);
Inc(Q, Temp);
Dec(M, Temp);
Dec(S.sub.left, Temp);
if S.sub.left = 0 then begin
if S.last then
S.mode := ibmDry
else
S.mode := ibmZType;
end;
end;
ibmTable:
begin
while K < 14 do begin
if N <> 0 then
R := Z_OK
else begin
Result := UpdatePointers;
Exit;
end;
Dec(N);
B := B or (Cardinal(P^) shl K);
Inc(P);
Inc(K, 8);
end;
Temp := B and $3FFF;
S.sub.trees.table := Temp;
if ((Temp and $1F) > 29) or (((Temp shr 5) and $1F) > 29) then begin
S.mode := ibmBlockBad;
R := Z_DATA_ERROR;
Result := UpdatePointers;
Exit;
end;
Temp := 258 + (Temp and $1F) + ((Temp shr 5) and $1F);
GetMem(S.sub.trees.blens, Temp * SizeOf(Cardinal));
B := B shr 14;
Dec(K, 14);
S.sub.trees.Index := 0;
S.mode := ibmBitTree;
end;
ibmBitTree:
begin
while (S.sub.trees.Index < 4 + (S.sub.trees.table shr 10)) do begin
while K < 3 do begin
if N <> 0 then
R := Z_OK
else begin
Result := UpdatePointers;
Exit;
end;
Dec(N);
B := B or (Cardinal(P^) shl K);
Inc(P);
Inc(K, 8);
end;
S.sub.trees.blens[BitOrder[S.sub.trees.Index]] := B and 7;
Inc(S.sub.trees.Index);
B := B shr 3;
Dec(K, 3);
end;
while S.sub.trees.Index < 19 do begin
S.sub.trees.blens[BitOrder[S.sub.trees.Index]] := 0;
Inc(S.sub.trees.Index);
end;
S.sub.trees.BB := 7;
Temp := InflateTreesBits(S.sub.trees.blens^, S.sub.trees.BB, S.sub.trees.TB,
S.hufts, Z);
if Temp <> Z_OK then begin
FreeMem(S.sub.trees.blens);
R := Temp;
if R = Z_DATA_ERROR then
S.mode := ibmBlockBad;
Result := UpdatePointers;
Exit;
end;
S.sub.trees.Index := 0;
S.mode := ibmDistTree;
end;
ibmDistTree:
begin
while True do begin
Temp := S.sub.trees.table;
if not (S.sub.trees.Index < 258 + (Temp and $1F) + ((Temp shr 5) and $1F)) then
Break;
Temp := S.sub.trees.BB;
while K < Temp do begin
if N <> 0 then
R := Z_OK
else begin
Result := UpdatePointers;
Exit;
end;
Dec(N);
B := B or (Cardinal(P^) shl K);
Inc(P);
Inc(K, 8);
end;
H := S.sub.trees.TB;
Inc(H, B and InflateMask[Temp]);
Temp := H^.Bits;
C := H^.Base;
if C < 16 then begin
B := B shr Temp;
Dec(K, Temp);
S.sub.trees.blens^[S.sub.trees.Index] := C;
Inc(S.sub.trees.Index);
end
else begin
// C = 16..18
if C = 18 then begin
I := 7;
J := 11;
end
else begin
I := C - 14;
J := 3;
end;
while K < Temp + I do begin
if N <> 0 then
R := Z_OK
else begin
Result := UpdatePointers;
Exit;
end;
Dec(N);
B := B or (Cardinal(P^) shl K);
Inc(P);
Inc(K, 8);
end;
B := B shr Temp;
Dec(K, Temp);
Inc(J, Cardinal(B) and InflateMask[I]);
B := B shr I;
Dec(K, I);
I := S.sub.trees.Index;
Temp := S.sub.trees.table;
if (I + J > 258 + (Temp and $1F) + ((Temp shr 5) and $1F)) or
((C = 16) and (I < 1)) then begin
FreeMem(S.sub.trees.blens);
S.mode := ibmBlockBad;
R := Z_DATA_ERROR;
Result := UpdatePointers;
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 := nil;
LiteralBits := 9;
DistanceBits := 6;
Temp := S.sub.trees.table;
Temp := InflateTreesDynamic(257 + (Temp and $1F), 1 + ((Temp shr 5) and $1F),
S.sub.trees.blens^, LiteralBits, DistanceBits, TL, TD, S.hufts, Z);
FreeMem(S.sub.trees.blens);
if Temp <> Z_OK then begin
if Integer(Temp) = Z_DATA_ERROR then
S.mode := ibmBlockBad;
R := Temp;
Result := UpdatePointers;
Exit;
end;
CodeState := InflateCodesNew(LiteralBits, DistanceBits, TL, TD, Z);
if CodeState = nil then begin
R := Z_MEM_ERROR;
Result := UpdatePointers;
Exit;
end;
S.sub.decode.codes := CodeState;
S.mode := ibmCodes;
end;
ibmCodes:
begin
// update pointers
S.bitb := B;
S.bitk := K;
Z.AvailableInput := N;
Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput));
Z.NextInput := P;
S.write := Q;
R := InflateCodes(S, Z, R);
if R <> Z_STREAM_END then begin
Result := InflateFlush(S, Z, R);
Exit;
end;
R := Z_OK;
Freemem(S.sub.decode.codes);
// load local pointers
P := Z.NextInput;
N := Z.AvailableInput;
B := S.bitb;
K := S.bitk;
Q := S.write;
if PtrUInt(Q) < PtrUInt(S.read) then
M := PtrUInt(S.read) - PtrUInt(Q) - 1
else
M := PtrUInt(S.zend) - PtrUInt(Q);
if not S.last then begin
S.mode := ibmZType;
Continue;
end;
S.mode := ibmDry;
end;
ibmDry:
begin
S.write := Q;
R := InflateFlush(S, Z, R);
Q := S.write;
if S.read <> S.write then begin
Result := UpdatePointers;
Exit;
end;
S.mode := ibmBlockDone;
end;
ibmBlockDone:
begin
R := Z_STREAM_END;
Result := UpdatePointers;
Exit;
end;
ibmBlockBad:
begin
R := Z_DATA_ERROR;
Result := UpdatePointers;
Exit;
end;
else
R := Z_STREAM_ERROR;
Result := UpdatePointers;
Exit;
end; // case S.mode of
end;
end;
function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer;
function LongestMatch(var S: TDeflateState; CurrentMatch: Cardinal): Cardinal;
// Sets MatchStart to the longest match starting at the given string and returns its length. Matches shorter or equal to
// PreviousLength are discarded, in which case the result is equal to PreviousLength and MatchStart is garbage.
// CurrentMatch is the head of the hash chain for the current string (StringStart) and its distance is <= MaxDistance,
// and PreviousLength >= 1.
// The match length will not be greater than S.Lookahead.
function ScanFast(Scan, Match, StrEnd: pByte): integer;
// faster routine by AB
begin
inc(Scan, 2);
inc(Match);
// We check for insufficient lookahead only every 8th comparison,
// the 256th check will be made at StringStart + 258.
repeat
Inc(Scan);
Inc(Match);
if (Scan^ <> Match^) then
Break;
Inc(Scan);
Inc(Match);
if (Scan^ <> Match^) then
Break;
Inc(Scan);
Inc(Match);
if (Scan^ <> Match^) then
Break;
Inc(Scan);
Inc(Match);
if (Scan^ <> Match^) then
Break;
Inc(Scan);
Inc(Match);
if (Scan^ <> Match^) then
Break;
Inc(Scan);
Inc(Match);
if (Scan^ <> Match^) then
Break;
Inc(Scan);
Inc(Match);
if (Scan^ <> Match^) then
Break;
Inc(Scan);
Inc(Match);
if (Scan^ <> Match^) then
Break;
until (PtrUInt(Scan) >= PtrUInt(StrEnd));
result := MAX_MATCH - Integer(PtrUInt(StrEnd) - PtrUInt(Scan));
end;
const
CGoodLen = 4;
CNiceLen = 16;
CMaxChain = 8;
var
ChainLength: Cardinal; // max hash chain length
Scan: PByte; // current string
Match: PByte; // matched string
Len: Cardinal; // length of current match
BestLen: Cardinal; // best match length so far
NiceMatch: Cardinal;
Limit: Cardinal;
Previous: TPAWord;
WMask: Cardinal;
StrEnd: PByte;
ScanEnd1: Byte;
ScanEnd: Byte;
MaxDistance: Cardinal;
begin
ChainLength := CMaxChain;
Scan := @S.Window[S.StringStart];
BestLen := S.PreviousLength;
NiceMatch := CNiceLen;
MaxDistance := S.WindowSize - MIN_LOOKAHEAD;
// In order to simplify the code, match distances are limited to MaxDistance instead of WSize.
if S.StringStart > MaxDistance then
Limit := S.StringStart - MaxDistance
else
Limit := 0;
// Stop when CurrentMatch becomes <= Limit. To simplify the Code we prevent matches with the string of window index 0.
Previous := S.Previous;
WMask := S.WindowMask;
StrEnd := @S.Window[S.StringStart + MAX_MATCH];
ScanEnd1 := TPAByte(Scan)[BestLen - 1];
ScanEnd := TPAByte(Scan)[BestLen];
// The code is optimized for HashBits >= 8 and MAX_MATCH - 2 multiple of 16.
// It is easy to get rid of this optimization if necessary.
// Do not waste too much time if we already have a good Match.
if S.PreviousLength >= CGoodLen then
ChainLength := ChainLength shr 2;
// Do not look for matches beyond the end of the input. This is necessary to make Deflate deterministic.
if NiceMatch > S.Lookahead then
NiceMatch := S.Lookahead;
repeat
Match := @S.Window[CurrentMatch];
// Skip to next match if the match length cannot increase or if the match length is less than 2.
if (TPAByte(Match)[BestLen] = ScanEnd) and
(TPAByte(Match)[BestLen - 1] = ScanEnd1) and (Match^ = Scan^) then begin
Inc(Match);
if Match^ = TPAByte(Scan)[1] then begin
// The Check at BestLen - 1 can be removed because it will be made again later (this heuristic is not always a win).
// It is not necessary to compare Scan[2] and Match[2] since they are always equal when the other bytes match,
// given that the hash keys are equal and that HashBits >= 8.
Len := ScanFast(Scan, Match, StrEnd); // faster routine by AB
Scan := StrEnd;
Dec(Scan, MAX_MATCH);
if Len > BestLen then begin
S.MatchStart := CurrentMatch;
BestLen := Len;
if Len >= NiceMatch then
Break;
ScanEnd1 := TPAByte(Scan)[BestLen - 1];
ScanEnd := TPAByte(Scan)[BestLen];
end;
end;
end;
CurrentMatch := Previous[CurrentMatch and WMask];
Dec(ChainLength);
until (CurrentMatch <= Limit) or (ChainLength = 0);
if BestLen <= S.Lookahead then
Result := BestLen
else
Result := S.Lookahead;
end;
procedure FillWindow(var S: TDeflateState);
// Fills the window when the lookahead becomes insufficient, updates StringStart and Lookahead.
// Lookahead must be less than MIN_LOOKAHEAD.
// StringStart will be <= CurrentWindowSize - MIN_LOOKAHEAD on exit.
// On exit at least one byte has been read, or AvailableInput = 0. Reads are performed for at least two bytes (required
// for the zip translate_eol option -> not supported here).
function ReadBuffer(ZState: PZState; Buffer: PByte; Size: Cardinal): Integer;
// Reads a new buffer from the current input stream, updates the Adler32 and total number of bytes read. All Deflate
// input goes through this function so some applications may wish to modify it to avoid allocating a large
// ZState.NextInput buffer and copying from it (see also FlushPending).
var
Len: Cardinal;
begin
Len := ZState.AvailableInput;
if Len > Size then
Len := Size;
if Len = 0 then begin
Result := 0;
Exit;
end;
Dec(ZState.AvailableInput, Len);
Move(ZState.NextInput^, Buffer^, Len);
Inc(ZState.NextInput, Len);
Inc(ZState.TotalInput, Len);
Result := Len;
end;
var
N, M: Cardinal;
P: TPWord;
More: Cardinal; // amount of free space at the end of the window
begin
repeat
More := S.CurrentWindowSize - Integer(S.Lookahead) - Integer(S.StringStart);
if (More = 0) and (S.StringStart = 0) and (S.Lookahead = 0) then
More := S.WindowSize
else if More = Cardinal(-1) then begin
// Very unlikely, but sometimes possible if StringStart = 0 and Lookahead = 1 (input done one byte at time)
Dec(More);
// If the Window is almost full and there is insufficient lookahead,
// move the upper half to the lower one to make room in the upper half.
end
else if S.StringStart >= S.WindowSize + (S.WindowSize - MIN_LOOKAHEAD) then begin
Move(S.Window[S.WindowSize], S.Window^, S.WindowSize);
Dec(S.MatchStart, S.WindowSize);
Dec(S.StringStart, S.WindowSize);
// we now have StringStart >= MaxDistance
Dec(S.BlockStart, Integer(S.WindowSize));
// Slide the hash table (could be avoided with 32 bit values at the expense of memory usage). We slide even when
// Level = 0 to keep the hash table consistent if we switch back to Level > 0 later. (Using Level 0 permanently
// is not an optimal usage of zlib, so we don't care about this pathological case.)
P := @S.Head[S.HashSize];
for N := 1 to S.HashSize do begin
Dec(P);
M := P^;
if M >= S.WindowSize then
P^ := M - S.WindowSize
else
P^ := 0;
end;
P := @S.Previous[S.WindowSize];
for N := 1 to S.WindowSize do begin
Dec(P);
M := P^;
if M >= S.WindowSize then
P^ := M - S.WindowSize
else
P^ := 0;
// if N is not on any hash chain Previous[N] is garbage but its value will never be used
end;
Inc(More, S.WindowSize);
end;
if S.ZState.AvailableInput = 0 then
Exit;
// If there was no sliding:
// StringStart <= S.WindowSize + MaxDistance - 1 and Lookahead <= MIN_LOOKAHEAD - 1 and
// More = CurrentWindowSize - Lookahead - StringStart
// => More >= CurrentWindowSize - (MIN_LOOKAHEAD - 1 + S.WindowSize + MaxDistance - 1)
// => More >= CurrentWindowSize - 2 * S.WindowSize + 2
// In the BIG_MEM or MMAP case (not yet supported),
// CurrentWindowSize = input_size + MIN_LOOKAHEAD and
// StringStart + S.Lookahead <= input_size => More >= MIN_LOOKAHEAD.
// Otherwise, CurrentWindowSize = 2 * S.WindowSize so More >= 2.
// If there was sliding More >= S.WindowSize. So in all cases More >= 2.
N := ReadBuffer(S.ZState, @S.Window[S.StringStart + S.Lookahead], More);
Inc(S.Lookahead, N);
// Initialize the hash Value now that we have some input:
if S.Lookahead >= MIN_MATCH then begin
S.InsertHash := S.Window[S.StringStart];
S.InsertHash := ((S.InsertHash shl S.HashShift) xor S.Window[S.StringStart
+ 1]) and S.HashMask;
end;
// If the whole input has less than MIN_MATCH bytes, InsertHash is garbage,
// but this is not important since only literal bytes will be emitted.
until (S.Lookahead >= MIN_LOOKAHEAD) or (S.ZState.AvailableInput = 0);
end;
procedure InitializeBlock(var S: TDeflateState);
var
N: Integer;
begin
// initialize the trees
for N := 0 to L_CODES - 1 do
S.LiteralTree[N].fc.Frequency := 0;
for N := 0 to D_CODES - 1 do
S.DistanceTree[N].fc.Frequency := 0;
for N := 0 to BL_CODES - 1 do
S.BitLengthTree[N].fc.Frequency := 0;
S.LiteralTree[END_BLOCK].fc.Frequency := 1;
S.StaticLength := 0;
S.OptimalLength := 0;
S.Matches := 0;
S.LastLiteral := 0;
end;
procedure FlushBlockOnly(var S: TDeflateState; EOF: Boolean);
// Flushs the current block with given end-of-file flag.
// StringStart must be set to the end of the current match.
procedure FlushPending(var ZState: TZState);
// Flushs as much pending output as possible. All Deflate output goes through this function so some applications may
// wish to modify it to avoid allocating a large ZState.NextOutput buffer and copying into it
// (see also ReadBuffer).
var
Len: Cardinal;
S: PDeflateState;
begin
S := PDeflateState(ZState.State);
Len := S.Pending;
if Len > ZState.AvailableOutput then
Len := ZState.AvailableOutput;
if Len > 0 then begin
Move(S.PendingOutput^, ZState.NextOutput^, Len);
Inc(ZState.NextOutput, Len);
Inc(S.PendingOutput, Len);
Inc(ZState.TotalOutput, Len);
Dec(ZState.AvailableOutput, Len);
Dec(S.Pending, Len);
if S.Pending = 0 then
S.PendingOutput := PByte(S.PendingBuffer);
end;
end;
function TreeFlushBlock(var S: TDeflateState; Buffer: PByte; StoredLength:
Integer; EOF: Boolean): Integer;
// Determines the best encoding for the current block: dynamic trees, static trees or store, and outputs the encoded
// block. Buffer contains the input block (or nil if too old), StoredLength the length of this block and EOF if this
// is the last block.
// Returns the total compressed length so far.
procedure BuildTree(var S: TDeflateState; var Descriptor: TTreeDescriptor);
// Constructs a Huffman tree and assigns the code bit strings and lengths.
// Updates the total bit length for the current block. The field Frequency must be set for all tree elements on entry.
// Result: the fields Len and Code are set to the optimal bit length and corresponding Code. The length OptimalLength
// is updated; StaticLength is also updated if STree is not nil. The field MaxCode is set.
procedure GenerateCodes(Tree: PTree; MaxCode: Integer; const
BitLengthCounts: array of Word);
// Generates the codes for a given tree and bit counts (which need not be optimal).
// The array BitLengthCounts contains the bit length statistics for the given tree and the field Len is set for all
// Tree elements. MaxCode is the largest code with non zero frequency and BitLengthCounts are the number of codes at
// each bit length.
// On exit the field code is set for all tree elements of non zero code length.
function BitReverse(Code: Word; Len: Integer): Word;
// Reverses the first Len bits of Code, using straightforward code (a faster
// imMethod would use a table)
begin
Result := 0;
repeat
Result := Result or (Code and 1);
Code := Code shr 1;
Result := Result shl 1;
Dec(Len);
until Len <= 0;
Result := Result shr 1;
end;
var
NextCode: array[0..MAX_BITS] of Word; // next code value for each bit length
Code: Word; // running code value
Bits: Integer; // bit Index
N: Integer; // code Index
Len: Integer;
begin
Code := 0;
// The distribution counts are first used to generate the code values without bit reversal.
for Bits := 1 to MAX_BITS do begin
Code := (Code + BitLengthCounts[Bits - 1]) shl 1;
NextCode[Bits] := Code;
end;
// Check that the bit counts in BitLengthCounts are consistent. The last code must be all ones.
for N := 0 to MaxCode do begin
Len := Tree[N].dl.Len;
if Len = 0 then
Continue;
Tree[N].fc.Code := BitReverse(NextCode[Len], Len);
Inc(NextCode[Len]);
end;
end;
procedure RestoreHeap(var S: TDeflateState; const Tree: TTree; K: Integer);
// Restores the heap property by moving down tree starting at node K,
// exchanging a Node with the smallest of its two sons if necessary, stopping
// when the heap property is re-established (each father smaller than its two sons).
var
V, J: Integer;
begin
V := S.Heap[K];
J := K shl 1; // left son of K
while J <= S.HeapLength do begin
// set J to the smallest of the two sons:
if (J < S.HeapLength) and
((Tree[S.Heap[J + 1]].fc.Frequency < Tree[S.Heap[J]].fc.Frequency) or
((Tree[S.Heap[J + 1]].fc.Frequency = Tree[S.Heap[J]].fc.Frequency) and
(S.Depth[S.Heap[J + 1]] <= S.Depth[S.Heap[J]]))) then
Inc(J);
// exit if V is smaller than both sons
if ((Tree[V].fc.Frequency < Tree[S.Heap[J]].fc.Frequency) or
((Tree[V].fc.Frequency = Tree[S.Heap[J]].fc.Frequency) and
(S.Depth[V] <= S.Depth[S.Heap[J]])))
then
Break;
// exchange V with the smallest son
S.Heap[K] := S.Heap[J];
K := J;
// and xontinue down the tree, setting J to the left son of K
J := J shl 1;
end;
S.Heap[K] := V;
end;
procedure GenerateBitLengths(var S: TDeflateState; var Descriptor:
TTreeDescriptor);
// Computes the optimal bit lengths for a tree and update the total bit length for the current block.
// The fields Frequency and dad are set, Heap[HeapMaximum] and above are the tree nodes sorted by increasing frequency.
// Result: The field Len is set to the optimal bit length, the array BitLengthCounts contains the frequencies for each
// bit length. The length OptimalLength is updated. StaticLength is also updated if STree is not nil.
var
Tree: PTree;
MaxCode: Integer;
STree: PTree;
Extra: TPAInteger;
Base: Integer;
MaxLength: Integer;
H: Integer; // heap Index
N, M: Integer; // iterate over the tree elements
Bits: Word; // bit length
ExtraBits: Integer;
F: Word; // frequency
Overflow: Integer; // number of elements with bit length too large
begin
Tree := Descriptor.DynamicTree;
MaxCode := Descriptor.MaxCode;
STree := Descriptor.StaticDescriptor.StaticTree;
Extra := Descriptor.StaticDescriptor.ExtraBits;
Base := Descriptor.StaticDescriptor.ExtraBase;
MaxLength := Descriptor.StaticDescriptor.MaxLength;
Overflow := 0;
FillChar(S.BitLengthCounts, SizeOf(S.BitLengthCounts), 0);
// in a first pass, compute the optimal bit lengths (which may overflow in the case of the bit length tree)
Tree[S.Heap[S.HeapMaximum]].dl.Len := 0; // root of the heap
for H := S.HeapMaximum + 1 to HEAP_SIZE - 1 do begin
N := S.Heap[H];
Bits := Tree[Tree[N].dl.Dad].dl.Len + 1;
if Bits > MaxLength then begin
Bits := MaxLength;
Inc(Overflow);
end;
Tree[N].dl.Len := Bits;
// overwrite Tree[N].dl.Dad which is no longer needed
if N > MaxCode then
Continue; // not a leaf node
Inc(S.BitLengthCounts[Bits]);
ExtraBits := 0;
if N >= Base then
ExtraBits := Extra[N - Base];
F := Tree[N].fc.Frequency;
Inc(S.OptimalLength, Integer(F) * (Bits + ExtraBits));
if Assigned(STree) then
Inc(S.StaticLength, Integer(F) * (STree[N].dl.Len + ExtraBits));
end;
// This happens for example on obj2 and pic of the Calgary corpus
if Overflow = 0 then
Exit;
// find the first bit length which could increase
repeat
Bits := MaxLength - 1;
while (S.BitLengthCounts[Bits] = 0) do
Dec(Bits);
// move one leaf down the tree
Dec(S.BitLengthCounts[Bits]);
// move one overflow item as its brother
Inc(S.BitLengthCounts[Bits + 1], 2);
// The brother of the overflow item also movels one step up,
// but this does not affect BitLengthCounts[MaxLength]
Dec(S.BitLengthCounts[MaxLength]);
Dec(Overflow, 2);
until (Overflow <= 0);
// Now recompute all bit lengths, scanning in increasing frequency.
// H is still equal to HEAP_SIZE. (It is simpler to reconstruct all
// lengths instead of fixing only the wrong ones. This idea is taken
// from 'ar' written by Haruhiko Okumura.)
H := HEAP_SIZE;
for Bits := MaxLength downto 1 do begin
N := S.BitLengthCounts[Bits];
while (N <> 0) do begin
Dec(H);
M := S.Heap[H];
if M > MaxCode then
Continue;
if Tree[M].dl.Len <> Bits then begin
Inc(S.OptimalLength, (Bits - Tree[M].dl.Len) * Tree[M].fc.Frequency);
Tree[M].dl.Len := Word(Bits);
end;
Dec(N);
end;
end;
end;
var
Tree: PTree;
STree: PTree;
Elements: Integer;
N, M: Integer; // iterate over heap elements
MaxCode: Integer; // largest code with non zero frequency
Node: Integer; // new node being created
begin
Tree := Descriptor.DynamicTree;
STree := Descriptor.StaticDescriptor.StaticTree;
Elements := Descriptor.StaticDescriptor.Elements;
MaxCode := -1;
// Construct the initial Heap, with least frequent element in Heap[SMALLEST].
// The sons of Heap[N] are Heap[2 * N] and Heap[2 * N + 1]. Heap[0] is not used.
S.HeapLength := 0;
S.HeapMaximum := HEAP_SIZE;
for N := 0 to Elements - 1 do begin
if Tree[N].fc.Frequency = 0 then
Tree[N].dl.Len := 0
else begin
MaxCode := N;
Inc(S.HeapLength);
S.Heap[S.HeapLength] := N;
S.Depth[N] := 0;
end;
end;
// The pkzip format requires that at least one distance code exists and that at least one bit
// should be sent even if there is only one possible code. So to avoid special checks later on we force at least
// two codes of non zero frequency.
while S.HeapLength < 2 do begin
Inc(S.HeapLength);
if MaxCode < 2 then begin
Inc(MaxCode);
S.Heap[S.HeapLength] := MaxCode;
Node := MaxCode;
end
else begin
S.Heap[S.HeapLength] := 0;
Node := 0;
end;
Tree[Node].fc.Frequency := 1;
S.Depth[Node] := 0;
Dec(S.OptimalLength);
if (STree <> nil) then
Dec(S.StaticLength, STree[Node].dl.Len);
// Node is 0 or 1 so it does not have extra bits
end;
Descriptor.MaxCode := MaxCode;
// The elements Heap[HeapLength / 2 + 1 .. HeapLength] are leaves of the Tree,
// establish sub-heaps of increasing lengths.
for N := S.HeapLength div 2 downto 1 do
RestoreHeap(S, Tree^, N);
// construct the Huffman tree by repeatedly combining the least two frequent nodes
Node := Elements; // next internal node of the tree
repeat
N := S.Heap[1];
S.Heap[1] := S.Heap[S.HeapLength];
Dec(S.HeapLength);
RestoreHeap(S, Tree^, 1);
// M := node of next least frequency
M := S.Heap[1];
Dec(S.HeapMaximum);
// keep the nodes sorted by frequency
S.Heap[S.HeapMaximum] := N;
Dec(S.HeapMaximum);
S.Heap[S.HeapMaximum] := M;
// create a new node father of N and M
Tree[Node].fc.Frequency := Tree[N].fc.Frequency + Tree[M].fc.Frequency;
// maximum
if (S.Depth[N] >= S.Depth[M]) then
S.Depth[Node] := Byte(S.Depth[N] + 1)
else
S.Depth[Node] := Byte(S.Depth[M] + 1);
Tree[M].dl.Dad := Word(Node);
Tree[N].dl.Dad := Word(Node);
// and insert the new node in the heap
S.Heap[1] := Node;
Inc(Node);
RestoreHeap(S, Tree^, 1);
until S.HeapLength < 2;
Dec(S.HeapMaximum);
S.Heap[S.HeapMaximum] := S.Heap[1];
// At this point the fields Frequency and dad are set.
// We can now generate the bit lengths.
GenerateBitLengths(S, Descriptor);
// The field Len is now set, we can generate the bit codes
GenerateCodes(Tree, MaxCode, S.BitLengthCounts);
end;
procedure BitsWindup(var S: TDeflateState);
// flushs the bit buffer and aligns the output on a byte boundary
begin
if S.ValidBits > 8 then begin
S.PendingBuffer[S.Pending] := Byte(S.BitsBuffer and $FF);
Inc(S.Pending);
S.PendingBuffer[S.Pending] := Byte(Word(S.BitsBuffer) shr 8);
Inc(S.Pending);
end
else if S.ValidBits > 0 then begin
S.PendingBuffer[S.Pending] := Byte(S.BitsBuffer);
Inc(S.Pending);
end;
S.BitsBuffer := 0;
S.ValidBits := 0;
end;
procedure SendBits(var S: TDeflateState; Value: Word; Length: Integer);
// Value contains what is to be sent
// Length is the number of bits to send
begin
// If there's not enough room in BitsBuffer use (valid) bits from BitsBuffer and
// (16 - ValidBits) bits from Value, leaving (width - (16 - ValidBits)) unused bits in Value.
if (S.ValidBits > Integer(BufferSize) - Length) then begin
S.BitsBuffer := S.BitsBuffer or (Value shl S.ValidBits);
S.PendingBuffer[S.Pending] := S.BitsBuffer and $FF;
Inc(S.Pending);
S.PendingBuffer[S.Pending] := S.BitsBuffer shr 8;
Inc(S.Pending);
S.BitsBuffer := Value shr (BufferSize - S.ValidBits);
Inc(S.ValidBits, Length - BufferSize);
end
else begin
S.BitsBuffer := S.BitsBuffer or (Value shl S.ValidBits);
Inc(S.ValidBits, Length);
end;
end;
procedure SendAllTrees(var S: TDeflateState; lcodes, dcodes, blcodes: Integer);
// Sends the header for a block using dynamic Huffman trees: the counts, the
// lengths of the bit length codes, the literal tree and the distance tree.
// lcodes must be >= 257, dcodes >= 1 and blcodes >= 4
procedure SendTree(var S: TDeflateState; const Tree: array of TTreeEntry;
MaxCode: Integer);
// Sends the given tree in compressed form using the codes in BitLengthTree.
// MaxCode is the tree's largest code of non zero frequency.
var
N: Integer; // iterates over all tree elements
PreviousLen: Integer; // last emitted length
CurrentLen: Integer; // length of current code
NextLen: Integer; // length of next code
Count: Integer; // repeat count of the current code
MaxCount: Integer; // max repeat count
MinCount: Integer; // min repeat count
begin
PreviousLen := -1;
NextLen := Tree[0].dl.Len;
Count := 0;
MaxCount := 7;
MinCount := 4;
// guard is already set
if NextLen = 0 then begin
MaxCount := 138;
MinCount := 3;
end;
for N := 0 to MaxCode do begin
CurrentLen := NextLen;
NextLen := Tree[N + 1].dl.Len;
Inc(Count);
if (Count < MaxCount) and (CurrentLen = NextLen) then
Continue
else if Count < MinCount then begin
repeat
SendBits(S, S.BitLengthTree[CurrentLen].fc.Code, S.BitLengthTree[CurrentLen].dl.Len);
Dec(Count);
until (Count = 0);
end
else if CurrentLen <> 0 then begin
if CurrentLen <> PreviousLen then begin
SendBits(S, S.BitLengthTree[CurrentLen].fc.Code, S.BitLengthTree[CurrentLen].dl.Len);
Dec(Count);
end;
SendBits(S, S.BitLengthTree[REP_3_6].fc.Code, S.BitLengthTree[REP_3_6].dl.Len);
SendBits(S, Count - 3, 2);
end
else if Count <= 10 then begin
SendBits(S, S.BitLengthTree[REPZ_3_10].fc.Code, S.BitLengthTree[REPZ_3_10].dl.Len);
SendBits(S, Count - 3, 3);
end
else begin
SendBits(S, S.BitLengthTree[REPZ_11_138].fc.Code, S.BitLengthTree[REPZ_11_138].dl.Len);
SendBits(S, Count - 11, 7);
end;
Count := 0;
PreviousLen := CurrentLen;
if NextLen = 0 then begin
MaxCount := 138;
MinCount := 3;
end
else if CurrentLen = NextLen then begin
MaxCount := 6;
MinCount := 3;
end
else begin
MaxCount := 7;
MinCount := 4;
end;
end;
end;
var
Rank: Integer;
begin
SendBits(S, lcodes - 257, 5); // not +255 as stated in appnote.txt
SendBits(S, dcodes - 1, 5);
SendBits(S, blcodes - 4, 4); // not -3 as stated in appnote.txt
for Rank := 0 to blcodes - 1 do
SendBits(S, S.BitLengthTree[BitLengthOrder[Rank]].dl.Len, 3);
SendTree(S, S.LiteralTree, lcodes - 1);
SendTree(S, S.DistanceTree, dcodes - 1);
end;
function BuildBitLengthTree(var S: TDeflateState): Integer;
// Constructs the Huffman tree for the bit lengths and returns the Index in BitLengthOrder
// of the last bit length code to send.
procedure ScanTree(var S: TDeflateState; var Tree: array of TTreeEntry;
MaxCode: Integer);
// Scans a given tree to determine the frequencies of the codes in the bit length tree.
// MaxCode is the tree's largest code of non zero frequency.
var
N: Integer; // iterates over all tree elements
PreviousLen: Integer; // last emitted length
CurrentLen: Integer; // Length of current code
NextLen: Integer; // length of next code
Count: Integer; // repeat count of the current xode
MaxCount: Integer; // max repeat count
MinCount: Integer; // min repeat count
begin
PreviousLen := -1;
NextLen := Tree[0].dl.Len;
Count := 0;
MaxCount := 7;
MinCount := 4;
if NextLen = 0 then begin
MaxCount := 138;
MinCount := 3;
end;
Tree[MaxCode + 1].dl.Len := Word($FFFF); // guard
for N := 0 to MaxCode do begin
CurrentLen := NextLen;
NextLen := Tree[N + 1].dl.Len;
Inc(Count);
if (Count < MaxCount) and (CurrentLen = NextLen) then
Continue
else if (Count < MinCount) then
Inc(S.BitLengthTree[CurrentLen].fc.Frequency, Count)
else if CurrentLen <> 0 then begin
if (CurrentLen <> PreviousLen) then
Inc(S.BitLengthTree[CurrentLen].fc.Frequency);
Inc(S.BitLengthTree[REP_3_6].fc.Frequency);
end
else if (Count <= 10) then
Inc(S.BitLengthTree[REPZ_3_10].fc.Frequency)
else
Inc(S.BitLengthTree[REPZ_11_138].fc.Frequency);
Count := 0;
PreviousLen := CurrentLen;
if NextLen = 0 then begin
MaxCount := 138;
MinCount := 3;
end
else if CurrentLen = NextLen then begin
MaxCount := 6;
MinCount := 3;
end
else begin
MaxCount := 7;
MinCount := 4;
end;
end;
end;
begin
// determine the bit length frequencies for literal and distance trees
ScanTree(S, S.LiteralTree, S.LiteralDescriptor.MaxCode);
ScanTree(S, S.DistanceTree, S.DistanceDescriptor.MaxCode);
// build the bit length tree
BuildTree(S, S.BitLengthDescriptor);
// OptimalLength now includes the length of the tree representations, except
// the lengths of the bit lengths codes and the 5 + 5 + 4 (= 14) bits for the counts.
// Determine the number of bit length codes to send. The pkzip format requires that at least 4 bit length codes
// be sent. (appnote.txt says 3 but the actual value used is 4.)
for Result := BL_CODES - 1 downto 3 do
if S.BitLengthTree[BitLengthOrder[Result]].dl.Len <> 0 then
Break;
// update OptimalLength to include the bit length tree and counts
Inc(S.OptimalLength, 3 * (Result + 1) + 14);
end;
procedure TreeStroredBlock(var S: TDeflateState; Buffer: PByte;
StoredLength: Integer; EOF: Boolean);
// sends a stored block
// Buffer contains the input data, Len the buffer length and EOF is True if this is the last block for a file.
procedure CopyBlock(var S: TDeflateState; Buffer: PByte; Len: Cardinal;
Header: Boolean);
// copies a stored block, storing first the length and its one's complement if requested
// Buffer contains the input data, Len the buffer length and Header is True if the block Header must be written too.
begin
BitsWindup(S); // align on byte boundary
S.LastEOBLength := 8; // enough lookahead for Inflate
if Header then begin
S.PendingBuffer[S.Pending] := Byte(Word(Len) and $FF);
Inc(S.Pending);
S.PendingBuffer[S.Pending] := Byte(Word(Len) shr 8);
Inc(S.Pending);
S.PendingBuffer[S.Pending] := Byte(Word(not Len) and $FF);
Inc(S.Pending);
S.PendingBuffer[S.Pending] := Byte(Word(not Len) shr 8);
Inc(S.Pending);
end;
while Len > 0 do begin
Dec(Len);
S.PendingBuffer[S.Pending] := Buffer^;
Inc(Buffer);
Inc(S.Pending);
end;
end;
begin
SendBits(S, (STORED_BLOCK shl 1) + Ord(EOF), 3); // send block type
S.CompressedLength := (S.CompressedLength + 10) and Integer(not 7);
Inc(S.CompressedLength, (StoredLength + 4) shl 3);
// copy with header
CopyBlock(S, Buffer, Cardinal(StoredLength), True);
end;
procedure CompressBlock(var S: TDeflateState; const LiteralTree,
DistanceTree: array of TTreeEntry);
// sends the block data compressed using the given Huffman trees
var
Distance: Cardinal; // distance of matched string
lc: Integer; // match length or unmatched char (if Distance = 0)
I: Cardinal;
Code: Cardinal; // the code to send
Extra: Integer; // number of extra bits to send
begin
I := 0;
if S.LastLiteral <> 0 then
repeat
Distance := S.DistanceBuffer[I];
lc := S.LiteralBuffer[I];
Inc(I);
if Distance = 0 then begin
// send a literal byte
SendBits(S, LiteralTree[lc].fc.Code, LiteralTree[lc].dl.Len);
end
else begin
// Here, lc is the match length - MIN_MATCH
Code := LengthCode[lc];
// send the length code
SendBits(S, LiteralTree[Code + LITERALS + 1].fc.Code,
LiteralTree[Code + LITERALS + 1].dl.Len);
Extra := ExtraLengthBits[Code];
if Extra <> 0 then begin
Dec(lc, BaseLength[Code]);
// send the extra length bits
SendBits(S, lc, Extra);
end;
Dec(Distance); // Distance is now the match distance - 1
if Distance < 256 then
Code := DistanceCode[Distance]
else
Code := DistanceCode[256 + (Distance shr 7)];
// send the distance code
SendBits(S, DistanceTree[Code].fc.Code, DistanceTree[Code].dl.Len);
Extra := ExtraDistanceBits[Code];
if Extra <> 0 then begin
Dec(Distance, BaseDistance[Code]);
SendBits(S, Distance, Extra); // send the extra distance bits
end;
end; // literal or match pair?
// Check that the overlay between PendingBuffer and DistanceBuffer + LiteralBuffer is ok
until I >= S.LastLiteral;
SendBits(S, LiteralTree[END_BLOCK].fc.Code, LiteralTree[END_BLOCK].dl.Len);
S.LastEOBLength := LiteralTree[END_BLOCK].dl.Len;
end;
var
OptimalByteLength, StaticByteLength: Integer; // OptimalLength and StaticLength in bytes
MacBLIndex: Integer; // index of last bit length code of non zero frequency
begin
// construct the literal and distance trees
// After this, OptimalLength and StaticLength are the total bit lengths of
// the compressed block data, excluding the tree representations.
BuildTree(S, S.LiteralDescriptor);
BuildTree(S, S.DistanceDescriptor);
// Build the bit length tree for the above two trees and get the index
// in BitLengthOrder of the last bit length code to send.
MacBLIndex := BuildBitLengthTree(S);
// determine the best encoding, compute first the block length in bytes
OptimalByteLength := (S.OptimalLength + 10) shr 3;
StaticByteLength := (S.StaticLength + 10) shr 3;
if StaticByteLength <= OptimalByteLength then
OptimalByteLength := StaticByteLength;
// if compression failed and this is the first and last block,
// and if the .zip file can be seeked (to rewrite the local header),
// the whole file is transformed into a stored file.
// (4 are the two words for the lengths)
if (StoredLength + 4 <= OptimalByteLength) and Assigned(Buffer) then begin
// The test Buffer <> nil is only necessary if LiteralBufferSize > WSize.
// Otherwise we can't have processed more than WSize input bytes since
// the last block dlush, because compression would have been successful.
// if LiteralBufferSize <= WSize, it is never too late to transform a block into a stored block.
TreeStroredBlock(S, Buffer, StoredLength, EOF);
end
else if StaticByteLength = OptimalByteLength then begin
// force static trees
SendBits(S, (STATIC_TREES shl 1) + Ord(EOF), 3);
CompressBlock(S, StaticLiteralTree, StaticDescriptorTree);
Inc(S.CompressedLength, 3 + S.StaticLength);
end
else begin
SendBits(S, (DYN_TREES shl 1) + Ord(EOF), 3);
SendAllTrees(S, S.LiteralDescriptor.MaxCode + 1,
S.DistanceDescriptor.MaxCode + 1, MacBLIndex + 1);
CompressBlock(S, S.LiteralTree, S.DistanceTree);
Inc(S.CompressedLength, 3 + S.OptimalLength);
end;
InitializeBlock(S);
if EOF then begin
BitsWindup(S);
// align on byte boundary
Inc(S.CompressedLength, 7);
end;
Result := S.CompressedLength shr 3;
end;
begin
if S.BlockStart >= 0 then
TreeFlushBlock(S, @S.Window[Cardinal(S.BlockStart)],
Integer(S.StringStart) - S.BlockStart, EOF)
else
TreeFlushBlock(S, nil, Integer(S.StringStart) - S.BlockStart, EOF);
S.BlockStart := S.StringStart;
FlushPending(S.ZState^);
end;
function TreeTally(var S: TDeflateState; Distance: Cardinal; lc: Cardinal): Boolean;
// Saves the match info and tallies the frequency counts. Returns True if the current block must be flushed.
// Distance is the distance of the matched string and lc either match length minus MIN_MATCH or the unmatch character
// (if Distance = 0).
var
Code: Word;
begin
S.DistanceBuffer[S.LastLiteral] := Word(Distance);
S.LiteralBuffer[S.LastLiteral] := Byte(lc);
Inc(S.LastLiteral);
if (Distance = 0) then begin
// lc is the unmatched char
Inc(S.LiteralTree[lc].fc.Frequency);
end
else begin
Inc(S.Matches);
// here, lc is the match length - MIN_MATCH
Dec(Distance);
if Distance < 256 then
Code := DistanceCode[Distance]
else
Code := DistanceCode[256 + (Distance shr 7)];
Inc(S.LiteralTree[LengthCode[lc] + LITERALS + 1].fc.Frequency);
Inc(S.DistanceTree[Code].fc.Frequency);
end;
Result := (S.LastLiteral = S.LiteralBufferSize - 1);
// We avoid equality with LiteralBufferSize because stored blocks are restricted to 64K - 1 bytes.
end;
procedure InsertString(var S: TDeflateState; Str: Cardinal; var MatchHead: Cardinal);
// Inserts Str into the dictionary and sets MatchHead to the previous head of the hash chain (the most recent string
// with same hash key). All calls to to InsertString are made with consecutive input characters and the first MIN_MATCH
// bytes of Str are valid (except for the last MIN_MATCH - 1 bytes of the input file).
// Returns the previous length of the hash chain.
begin
S.InsertHash := ((S.InsertHash shl S.HashShift) xor (S.Window[(Str) + (MIN_MATCH - 1)]))
and S.HashMask;
MatchHead := S.Head[S.InsertHash];
S.Previous[(Str) and S.WindowMask] := MatchHead;
S.Head[S.InsertHash] := Word(Str);
end;
const
CMaxInsertLen = 5;
var
Z: TZState;
Overlay: TPAWord;
// We overlay PendingBuffer and DistanceBuffer + LiteralBuffer. This works since the average
// output size for (length, distance) codes is <= 24 Bits.
HashHead: Cardinal; // head of the hash chain
BlockFlush: Boolean; // set if current block must be flushed
S: TDeflateState;
begin
result := 0;
FillChar(Z, sizeOf(Z), 0);
Z.NextInput := src;
Z.AvailableInput := srcLen;
Z.NextOutput := dst;
Z.AvailableOutput := dstLen;
Z.TotalInput := Z.TotalOutput;
FillChar(S, SizeOf(TDeflateState), 0);
try
Z.State := @S;
S.ZState := @Z;
S.WindowSize := 1 shl CWindowBits;
S.WindowMask := S.WindowSize - 1;
S.HashBits := CMemLevel + 7;
S.HashSize := 1 shl S.HashBits;
S.HashMask := S.HashSize - 1;
S.HashShift := (S.HashBits + MIN_MATCH - 1) div MIN_MATCH;
GetMem(S.Window, S.WindowSize * (2 * SizeOf(Byte)));
GetMem(S.Previous, S.WindowSize * SizeOf(Word));
GetMem(S.Head, S.HashSize * SizeOf(Word));
S.LiteralBufferSize := 1 shl (CMemLevel + 6); // 16K elements by default
GetMem(Overlay, S.LiteralBufferSize * (SizeOf(Word) + 2));
S.PendingBuffer := TPAByte(Overlay);
S.PendingBufferSize := S.LiteralBufferSize * (SizeOf(Word) + 2);
S.DistanceBuffer := @Overlay[S.LiteralBufferSize div SizeOf(Word)];
S.LiteralBuffer := @S.PendingBuffer[(1 + SizeOf(Word)) * S.LiteralBufferSize];
S.PendingOutput := PByte(S.PendingBuffer);
S.LiteralDescriptor.DynamicTree := @S.LiteralTree;
S.LiteralDescriptor.StaticDescriptor := @StaticLiteralDescriptor;
S.DistanceDescriptor.DynamicTree := @S.DistanceTree;
S.DistanceDescriptor.StaticDescriptor := @StaticDistanceDescriptor;
S.BitLengthDescriptor.DynamicTree := @S.BitLengthTree;
S.BitLengthDescriptor.StaticDescriptor := @StaticBitLengthDescriptor;
S.LastEOBLength := 8; // enough Lookahead for Inflate
InitializeBlock(S);
S.CurrentWindowSize := 2 * S.WindowSize;
S.Head[S.HashSize - 1] := 0;
FillChar(S.Head^, (S.HashSize - 1) * SizeOf(S.Head[0]), 0);
S.PreviousLength := MIN_MATCH - 1;
S.MatchLength := MIN_MATCH - 1;
HashHead := 0;
while true do begin
// Make sure that we always have enough lookahead, except at the end of the input file. We need MAX_MATCH bytes
// for the next match plus MIN_MATCH bytes to insert the string following the next match.
if S.Lookahead < MIN_LOOKAHEAD then begin
FillWindow(S);
// flush the current block
if S.Lookahead = 0 then begin
FlushBlockOnly(S, true);
if Z.AvailableOutput <> 0 then
result := Z.TotalOutput;
break;
end;
end;
// Insert the string Window[StringStart .. StringStart + 2] in the
// dictionary and set HashHead to the head of the hash chain.
if S.Lookahead >= MIN_MATCH then
InsertString(S, S.StringStart, HashHead);
// Find the longest match, discarding those <= PreviousLength.
// At this point we have always MatchLength < MIN_MATCH.
if (HashHead <> 0) and (S.StringStart - HashHead <= (S.WindowSize - MIN_LOOKAHEAD)) then
S.MatchLength := LongestMatch(S, HashHead);
if S.MatchLength >= MIN_MATCH then begin
BlockFlush := TreeTally(S, S.StringStart - S.MatchStart, S.MatchLength - MIN_MATCH);
Dec(S.Lookahead, S.MatchLength);
// Insert new strings in the hash table only if the match length
// is not too large. This saves time but degrades compression.
if (S.MatchLength <= CMaxInsertLen) and (S.Lookahead >= MIN_MATCH) then begin
// string at StringStart already in hash table
Dec(S.MatchLength);
repeat
Inc(S.StringStart);
InsertString(S, S.StringStart, HashHead);
// StringStart never exceeds WSize - MAX_MATCH, so there are always MIN_MATCH bytes ahead.
Dec(S.MatchLength);
until S.MatchLength = 0;
Inc(S.StringStart);
end
else begin
Inc(S.StringStart, S.MatchLength);
S.MatchLength := 0;
S.InsertHash := S.Window[S.StringStart];
S.InsertHash := ((S.InsertHash shl S.HashShift) xor
S.Window[S.StringStart + 1]) and S.HashMask;
// if Lookahead < MIN_MATCH, InsertHash is garbage, but it does not
// matter since it will be recomputed at next Deflate call.
end;
end
else begin
// no match, output a literal byte
BlockFlush := TreeTally(S, 0, S.Window[S.StringStart]);
Dec(S.Lookahead);
Inc(S.StringStart);
end;
if BlockFlush then begin
FlushBlockOnly(S, False);
if S.ZState.AvailableOutput = 0 then
break;
end;
end;
except
result := 0;
end;
FreeMem(S.PendingBuffer);
FreeMem(S.Head);
FreeMem(S.Previous);
FreeMem(S.Window);
end;
function UncompressMem(src, dst: pointer; srcLen, dstLen: integer): integer;
var
Z: TZState;
begin
result := 0;
FillChar(Z, sizeOf(Z), 0);
try
Z.NextInput := src;
Z.AvailableInput := srcLen;
Z.NextOutput := dst;
Z.AvailableOutput := dstLen;
Z.State := InflateBlocksNew(Z, 1 shl CWindowBits);
InflateBlockReset(Z.State^, Z);
if InflateBlocks(Z.State^, Z, Z_BUF_ERROR) in [Z_OK, Z_STREAM_END] then
result := Z.TotalOutput;
InflateBlockReset(Z.State^, Z);
except
result := 0;
end;
FreeMem(Z.State.Window);
FreeMem(Z.State.hufts);
FreeMem(Z.State);
end;
{$ifdef CPUARM} // circumvent FPC issue on ARM
function ToByte(value: cardinal): cardinal; inline;
begin
result := value and $ff;
end;
{$else}
type ToByte = byte;
{$endif}
function UpdateCrc32(aCRC32: cardinal; inBuf: pointer; inLen: integer): cardinal;
var
i: integer;
begin
result := aCRC32;
for i := 0 to (inLen shr 2) - 1 do begin
result := crc32Tab[ToByte(result xor pByte(inBuf)^)] xor (result shr 8);
inc(pByte(inBuf));
result := crc32Tab[ToByte(result xor pByte(inBuf)^)] xor (result shr 8);
inc(pByte(inBuf));
result := crc32Tab[ToByte(result xor pByte(inBuf)^)] xor (result shr 8);
inc(pByte(inBuf));
result := crc32Tab[ToByte(result xor pByte(inBuf)^)] xor (result shr 8);
inc(pByte(inBuf));
end;
for i := 0 to (inLen and 3) - 1 do begin
result := crc32Tab[ToByte(result xor pByte(inBuf)^)] xor (result shr 8);
inc(pByte(inBuf));
end;
end;
function CompressString(const data: RawByteZip; failIfGrow: boolean = false):
RawByteZip;
var
i1: integer;
begin
SetLength(result, 12 + length(data) * 11 div 10 + 12);
pInt64(result)^ := length(data);
TPACardinal(result)^[2] := not UpdateCrc32(dword(-1), pointer(data), length(data));
i1 := CompressMem(pointer(data), PAnsiChar(PtrUInt(result) + 12), length(data),
length(result) - 12);
if (i1 > 0) and ((12 + i1 < length(data)) or (not failIfGrow)) then
SetLength(result, 12 + i1)
else
result := '';
end;
function UncompressString(const data: RawByteZip): RawByteZip;
begin
if Length(data) > 12 then begin
SetLength(result, PCardinal(data)^);
SetLength(result, UncompressMem(PAnsiChar(PtrUInt(data) + 12), pointer(result),
length(data) - 12, length(result)));
if (result <> '') and (TPACardinal(data)^[2] <>
not UpdateCrc32(dword(-1), pointer(result), length(result))) then
result := '';
end
else
result := '';
end;
{$ifdef MSWINDOWS}
type
splitInt64 = record
loCard, hiCard: cardinal
end;
function CompressFile(const srcFile, dstFile: TFileName; failIfGrow: boolean =
false): boolean;
var
sf, df: dword;
sm, dm: dword;
sb, db: pointer;
sl, dl: int64;
err: dword;
begin
result := false;
err := 0;
try
sf := CreateFile(pointer(srcFile), GENERIC_READ, FILE_SHARE_READ or
FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);
if sf <> INVALID_HANDLE_VALUE then begin
df := CreateFile(pointer(dstFile), GENERIC_READ or GENERIC_WRITE, 0, nil,
CREATE_ALWAYS, 0, 0);