Vichingo455-RePacks
/
xtool
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases 1 Wiki Activity
xtool/contrib/mORMot/PasZip.pas

4742 lines
174 KiB
ObjectPascal
Raw Blame History

/// 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) 2022 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
- .zip reading from file, resource or direct memory - Windows only
- .zip write into a file (new .zip creation, not update) - Windows only
}
{$WARNINGS OFF}
{$Q-,R-} // Turn range checking and overflow checking off
{ $D-,L-}
{$I Synopse.inc}
interface
uses
{$ifdef MSWINDOWS}
Windows,
{$else}
Types,
{$endif MSWINDOWS}
SysUtils;
type
{$ifdef HASCODEPAGE}
RawByteZip = RawByteString;
TZipName = type AnsiString(437);
{$else}
RawByteZip = AnsiString;
TZipName = AnsiString;
{$endif HASCODEPAGE}
{$ifdef DELPHI5OROLDER}
PCardinal = ^cardinal;
{$endif DELPHI5OROLDER}
/// 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 with a crc32 checksum
function CompressString(const data: RawByteZip; failIfGrow: boolean = false): RawByteZip;
/// uncompress memory using the ZLib INFLATE algorithm, checking crc32 checksum
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;
/// create a void .zip file
procedure CreateVoidZip(const aFileName: TFileName);
{$endif MSWINDOWS}
/// 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 }
type
TCRC32Tab = array[0..255] of cardinal;
/// the static buffer used for fast CRC32 hashing
{$ifdef DYNAMIC_CRC_TABLE}
var
crc32Tab: TCRC32Tab;
{$else}
const
crc32Tab: TCRC32Tab = ($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 DYNAMIC_CRC_TABLE}
{$ifdef MSWINDOWS}
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;
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;
/// 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);
/// add a file from an already compressed zip entry
procedure AddFromZip(const ZipEntry: TZipEntry);
/// 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;
{$endif MSWINDOWS}
implementation
{$ifndef FPC}
type
PtrUInt = {$ifdef CPU64}NativeUInt{$else}cardinal{$endif};
{$endif FPC}
// special tuned Move() routine, including data overlap bug correction
{$ifdef PUREPASCAL}
procedure MoveWithOverlap(Src: PByte; Dst: PByte; Count: PtrUInt);
{$ifdef HASINLINE}inline;{$endif}
begin // should be fast enough in practice, especially inlined
dec(PtrUInt(Src), PtrUInt(Dst));
inc(Count, PtrUInt(Dst));
repeat
Dst^ := PByteArray(Src)[PtrUInt(Dst)];
inc(Dst);
until PtrUInt(Dst) = Count;
end;
{$else}
procedure MoveWithOverlap(Src: PByte; Dst: PByte; Count: integer);
{$ifdef FPC} nostackframe; assembler; {$endif}
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 PUREPASCAL}
//----------------- 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
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;
PInflateCodesState = ^TInflateCodesState;
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
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;
PInflateBlocksState = ^TInflateBlocksState;
// 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
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;
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 shr 1 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 shr 1];
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 CPUARM}
function UpdateCrc32(aCRC32: cardinal; inBuf: pointer; inLen: integer): cardinal;
var
i: integer;
table: {$ifdef CPUX86}TCRC32Tab absolute crc32Tab{$else}^TCRC32Tab{$endif};
begin
result := aCRC32;
{$ifndef CPUX86}table := @crc32Tab;{$endif}
for i := 0 to (inLen shr 2) - 1 do begin
result := table[ToByte(result xor PByte(inBuf)^)] xor (result shr 8);
inc(PByte(inBuf));
result := table[ToByte(result xor PByte(inBuf)^)] xor (result shr 8);
inc(PByte(inBuf));
result := table[ToByte(result xor PByte(inBuf)^)] xor (result shr 8);
inc(PByte(inBuf));
result := table[ToByte(result xor PByte(inBuf)^)] xor (result shr 8);
inc(PByte(inBuf));
end;
for i := 0 to (inLen and 3) - 1 do begin
result := table[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 = packed record
loCard, hiCard: cardinal
end;
function CompressFile(const srcFile, dstFile: TFileName; failIfGrow: boolean): 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);
if df <> INVALID_HANDLE_VALUE then begin
sm := CreateFileMapping(sf, nil, PAGE_READONLY, 0, 0, nil);
if sm <> 0 then begin
splitInt64(sl).loCard := GetFileSize(sf, @splitInt64(sl).hiCard);
dl := 12 + sl * 11 div 10 + 12;
dm := CreateFileMapping(df, nil, PAGE_READWRITE, splitInt64(dl).hiCard,
splitInt64(dl).loCard, nil);
if dm <> 0 then begin
sb := MapViewOfFile(sm, FILE_MAP_READ, 0, 0, 0);
if sb <> nil then begin
db := MapViewOfFile(dm, FILE_MAP_ALL_ACCESS, 0, 0, 0);
if db <> nil then begin
pint64(db)^ := sl;
dl := CompressMem(sb, pointer(PtrUInt(db) + 12), sl, dl - 12);
result := (dl > 0) and ((dl + 12 < sl) or (not failIfGrow));
if result then
PCardinal(PtrUInt(db) + 8)^ := not UpdateCrc32(dword(-1), sb, sl);
UnmapViewOfFile(db);
end
else
err := GetLastError;
UnmapViewOfFile(sb);
end
else
err := GetLastError;
CloseHandle(dm);
end
else
err := GetLastError;
CloseHandle(sm);
end
else
err := GetLastError;
if result then begin
inc(dl, 12);
SetFilePointer(df, integer(splitInt64(dl).loCard), @splitInt64(dl).hiCard,
FILE_BEGIN);
SetEndOfFile(df);
end;
CloseHandle(df);
if not result then
Windows.DeleteFile(pointer(dstFile));
end
else
err := GetLastError;
CloseHandle(sf);
end
else
err := GetLastError;
except
SetFileAttributes(pointer(dstFile), 0);
Windows.DeleteFile(pointer(dstFile));
err := ERROR_ACCESS_DENIED;
end;
if not result then
SetLastError(err);
end;
function UncompressFile(const srcFile, dstFile: TFileName; lastWriteTime: int64;
attr: dword): 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, FILE_ATTRIBUTE_NORMAL or
FILE_FLAG_SEQUENTIAL_SCAN, 0);
if sf <> INVALID_HANDLE_VALUE then begin
df := CreateFile(pointer(dstFile), GENERIC_READ or GENERIC_WRITE, 0, nil,
CREATE_ALWAYS, attr or FILE_FLAG_SEQUENTIAL_SCAN, 0);
if df <> INVALID_HANDLE_VALUE then begin
sm := CreateFileMapping(sf, nil, PAGE_READONLY, 0, 0, nil);
if sm <> 0 then begin
sb := MapViewOfFile(sm, FILE_MAP_READ, 0, 0, 0);
if sb <> nil then begin
dl := PInt64(sb)^;
dm := CreateFileMapping(df, nil, PAGE_READWRITE, splitInt64(dl).hiCard,
splitInt64(dl).loCard, nil);
if dm <> 0 then begin
db := MapViewOfFile(dm, FILE_MAP_ALL_ACCESS, 0, 0, 0);
if db <> nil then begin
splitInt64(sl).loCard := GetFileSize(sf, @splitInt64(sl).hiCard);
dl := UncompressMem(pointer(PtrUInt(sb) + 12), db, sl - 12, dl);
result := (dl > 0) and (PCardinal(PtrUInt(sb) + 8)^ =
not UpdateCrc32(dword(-1), db, dl));
UnmapViewOfFile(db);
end
else
err := GetLastError;
CloseHandle(dm);
end
else
err := GetLastError;
UnmapViewOfFile(sb);
end
else
err := GetLastError;
CloseHandle(sm);
end
else
err := GetLastError;
if result then begin
SetFilePointer(df, integer(splitInt64(dl).loCard), @splitInt64(dl).hiCard, FILE_BEGIN);
SetEndOfFile(df);
end;
if result and (lastWriteTime <> 0) then
SetFileTime(df, nil, nil, @lastWriteTime);
CloseHandle(df);
if result then begin
if (attr <> 0) and (GetVersion and $80000000 = 0) then
SetFileAttributes(pointer(dstFile), attr)
end
else
Windows.DeleteFile(pointer(dstFile));
end
else
err := GetLastError;
CloseHandle(sf);
end
else
err := GetLastError;
except
SetFileAttributes(pointer(dstFile), 0);
Windows.DeleteFile(pointer(dstFile));
err := ERROR_ACCESS_DENIED;
end;
if not result then
SetLastError(err);
end;
function IsCompressedFileEqual(const uncomprFile, comprFile: TFileName): boolean;
var
size1, size2: int64;
crc1, crc2: dword;
begin
result := GetCompressedFileInfo(comprFile, size1, crc1) and
GetUncompressedFileInfo(uncomprFile, size2, crc2) and (size1 = size2) and
(crc1 = crc2);
end;
function GetCompressedFileInfo(const comprFile: TFileName; var size: int64;
var crc32: dword): boolean;
var
file_: dword;
c1: dword;
begin
result := false;
crc32 := 0;
file_ := CreateFile(pointer(comprFile), GENERIC_READ, FILE_SHARE_READ or
FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);
if file_ <> INVALID_HANDLE_VALUE then begin
result := ReadFile(file_, size, 8, c1, nil) and (c1 = 8) and ReadFile(file_,
crc32, 4, c1, nil) and (c1 = 4);
CloseHandle(file_);
end;
end;
function GetUncompressedFileInfo(const uncomprFile: TFileName; var size: int64;
var crc32: dword): boolean;
var
file_, map: dword;
buf: pointer;
begin
result := false;
file_ := CreateFile(pointer(uncomprFile), GENERIC_READ, FILE_SHARE_READ or
FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);
if file_ <> INVALID_HANDLE_VALUE then begin
splitInt64(size).loCard := GetFileSize(file_, @splitInt64(size).hiCard);
map := CreateFileMapping(file_, nil, PAGE_READONLY, 0, 0, nil);
if map <> 0 then begin
buf := MapViewOfFile(map, FILE_MAP_READ, 0, 0, 0);
if buf <> nil then begin
crc32 := not UpdateCrc32(dword(-1), buf, size);
UnmapViewOfFile(buf);
result := true;
end;
CloseHandle(map);
end;
CloseHandle(file_);
end;
end;
{$endif MSWINDOWS}
function GzCompress(src: pointer; srcLen: integer; const fName: TFileName): cardinal;
const
gzheader: array[0..2] of cardinal = ($88B1F, 0, 0);
var
f: file;
dest: pointer;
destLen: cardinal;
crc: cardinal;
begin
result := 0;
{$I-}
assign(f, fName);
rewrite(f, 1);
if ioresult <> 0 then
exit;
try
blockwrite(f, gzHeader, 10);
destLen := 12 + (SrcLen * 11) div 10; // ensure enough space
getmem(dest, destLen);
try
destLen := CompressMem(src, dest, srcLen, destLen);
blockwrite(f, dest^, destLen);
crc := not UpdateCrc32(dword(-1), src, srcLen);
blockwrite(f, crc, 4);
blockwrite(f, srcLen, 4);
finally
freemem(dest);
end;
finally
close(f);
end;
{$I+}
if ioresult <> 0 then
exit;
result := destLen + 18;
end;
{$ifdef MSWINDOWS}
function Zip(const zip: TFileName; const files, zipAs: array of TFileName;
NoSubDirectories: boolean = false): boolean;
var
i1, i2, i3: integer;
dstFh: dword;
srcFh: dword;
ft: TFileTime;
c1: dword;
lfhr: TLocalFileHeader;
srcBuf: pointer;
dstBuf: pointer;
size: dword;
zipRec: array of record
name: TZipName;
fhr: TFileHeader;
end;
lhr: TLastHeader;
begin
dstFh := CreateFile(pointer(zip), GENERIC_WRITE, 0, nil, CREATE_ALWAYS, 0, 0);
result := dstFh <> INVALID_HANDLE_VALUE;
if result then begin
SetLength(zipRec, Length(files));
i2 := 0;
for i1 := 0 to high(files) do
with zipRec[i2] do begin
if i1 >= length(zipAs) then begin
name := TZipName(files[i1]);
if NoSubDirectories then
for i3 := Length(name) downto 1 do
if name[i3] = '\' then begin
Delete(name, 1, i3);
break;
end;
end
else
name := TZipName(zipAs[i1]);
srcFh := CreateFile(pointer(files[i1]), GENERIC_READ, FILE_SHARE_READ,
nil, OPEN_EXISTING, 0, 0);
if srcFh <> INVALID_HANDLE_VALUE then begin
size := GetFileSize(srcFh, nil);
srcBuf := pointer(LocalAlloc(LPTR, size));
if srcBuf <> nil then begin
dstBuf := pointer(LocalAlloc(LPTR, size * 11 div 10 + 12));
if dstBuf <> nil then begin
if ReadFile(srcFh, srcBuf^, size, c1, nil) and (c1 = size) then begin
with lfhr, fileInfo do begin
signature := $04034b50 + 1;
dec(signature); // +1 to avoid finding it in the exe
neededVersion := $14;
flags := 0;
zzipMethod := 8;
zcrc32 := not UpdateCrc32(dword(-1), srcBuf, size);
zzipSize := CompressMem(srcBuf, dstBuf, size, size * 11 div 10 + 12);
zfullSize := size;
nameLen := length(name);
extraLen := 0;
GetFileTime(srcFh, nil, nil, @ft);
FileTimeToLocalFileTime(ft, ft);
FileTimeToDosDateTime(ft, zlastModDate, zlastModTime);
end;
with fhr do begin
signature := $02014b50 + 1;
dec(signature); // +1 to avoid finding it
madeBy := $14;
fileInfo := lfhr.fileInfo;
commentLen := 0;
firstDiskNo := 0;
intFileAttr := 0;
extFileAttr := GetFileAttributes(pointer(files[i1]));
localHeadOff := SetFilePointer(dstFh, 0, nil, FILE_CURRENT);
end;
result :=
WriteFile(dstFh, lfhr, sizeOf(lfhr), c1, nil) and
(c1 = sizeOf(lfhr)) and
WriteFile(dstFh, pointer(name)^, length(name), c1, nil) and
(c1 = dword(length(name))) and
WriteFile(dstFh, dstBuf^, lfhr.fileInfo.zzipSize, c1, nil) and
(c1 = lfhr.fileInfo.zzipSize);
inc(i2);
end;
LocalFree(PtrUInt(dstBuf));
end;
LocalFree(PtrUInt(srcBuf));
end;
CloseHandle(srcFh);
end;
if not result then
break;
end;
result := result and (i2 > 0);
if result then begin
with lhr do begin
signature := $06054b50 + 1;
dec(signature); // +1 to avoid finding it
thisDisk := 0;
headerDisk := 0;
thisFiles := i2;
totalFiles := i2;
headerSize := 0;
headerOffset := SetFilePointer(dstFh, 0, nil, FILE_CURRENT);
commentLen := 0;
end;
for i1 := 0 to i2 - 1 do
with zipRec[i1] do begin
inc(lhr.headerSize, sizeOf(TFileHeader) + length(name));
if not (WriteFile(dstFh, fhr, sizeOf(fhr), c1, nil) and (c1 = sizeOf(fhr)) and
WriteFile(dstFh, pointer(name)^, length(name), c1, nil) and
(c1 = dword(length(name)))) then begin
result := false;
break;
end;
end;
result := result and WriteFile(dstFh, lhr, sizeOf(lhr), c1, nil) and
(c1 = sizeOf(lhr));
end;
CloseHandle(dstFh);
if not result then
Windows.DeleteFile(pointer(zip));
end;
end;
procedure CreateVoidZip(const aFileName: TFileName);
var
H: THandle;
lhr: TLastHeader;
begin
fillchar(lhr, sizeof(lhr), 0);
lhr.signature := $06054b50 + 1;
dec(lhr.signature); // +1 to avoid finding it in the exe
H := FileCreate(aFileName);
if H < 0 then
exit;
FileWrite(H, lhr, sizeof(lhr));
FileClose(H);
end;
{$endif MSWINDOWS}
{$ifdef DYNAMIC_CRC_TABLE}
{
Generate a table for a byte-wise 32-bit CRC calculation on the polynomial:
x^32+x^26+x^23+x^22+x^16+x^12+x^11+x^10+x^8+x^7+x^5+x^4+x^2+x+1.
Polynomials over GF(2) are represented in binary, one bit per coefficient,
with the lowest powers in the most significant bit. Then adding polynomials
is just exclusive-or, and multiplying a polynomial by x is a right shift by
one. If we call the above polynomial p, and represent a byte as the
polynomial q, also with the lowest power in the most significant bit (so the
byte 0xb1 is the polynomial x^7+x^3+x+1), then the CRC is (q*x^32) mod p,
where a mod b means the remainder after dividing a by b.
This calculation is done using the shift-register method of multiplying and
taking the remainder. The register is initialized to zero, and for each
incoming bit, x^32 is added mod p to the register if the bit is a one (where
x^32 mod p is p+x^32 = x^26+...+1), and the register is multiplied mod p by
x (which is shifting right by one and adding x^32 mod p if the bit shifted
out is a one). We start with the highest power (least significant bit) of
q and repeat for all eight bits of q.
The table is simply the CRC of all possible eight bit values. This is all
the information needed to generate CRC's on data a byte at a time for all
combinations of CRC register values and incoming bytes.
}
procedure InitCrc32Tab;
var
i, n, crc: cardinal;
begin // this code is 49 bytes long, generating a 1KB table
for i := 0 to 255 do begin
crc := i;
for n := 1 to 8 do
if (crc and 1) <> 0 then
// $edb88320 from polynomial p=(0,1,2,4,5,7,8,10,11,12,16,22,23,26)
crc := (crc shr 1) xor $edb88320
else
crc := crc shr 1;
CRC32Tab[i] := crc;
end;
end;
{$endif}
{$ifdef MSWINDOWS}
{ TZipRead }
constructor TZipRead.Create(BufZip: pByteArray; Size: cardinal);
var
lhr: ^TLastHeader;
h: ^TFileHeader;
lfhr: ^TLocalFileHeader;
i, j, L: integer;
p: PAnsiChar;
begin
for i := 0 to 31 do begin // resources size may be rounded up to alignment
lhr := @BufZip[Size - sizeof(lhr^)];
if lhr^.signature + 1 = $06054b51 then // +1 to avoid finding it in the exe
break;
dec(Size);
if Size <= sizeof(lhr^) then
break;
end;
if lhr^.signature + 1 <> $06054b51 then begin // +1 to avoid finding it
UnMap;
MessageBox(0, 'ZIP format', nil, MB_SYSTEMMODAL or MB_ICONERROR);
exit;
end;
if lhr^.headerOffset > Size then
exit;
SetLength(Entry, lhr^.totalFiles); // fill Entry[] with the Zip headers
H := @BufZip[lhr^.headerOffset];
for i := 1 to lhr^.totalFiles do begin
if H^.signature + 1 <> $02014b51 then begin // +1 to avoid finding it
UnMap;
MessageBox(0, 'ZIP format', nil, MB_SYSTEMMODAL or MB_ICONERROR);
exit;
end;
lfhr := @BufZip[H^.localHeadOff];
with Entry[Count] do begin
info := @lfhr^.fileInfo;
p := PAnsiChar(lfhr) + sizeof(lfhr^);
data := p + info^.NameLen + info^.extraLen; // data are still mapped in memory
if info^.NameLen >= High(Name) - 1 then // avoid GPF with huge Name[]
L := High(Name) - 1
else
L := info^.NameLen;
j := 0;
repeat
if p^ = '/' then // normalize path delimiter
Name[j] := '\'
else
Name[j] := p^;
inc(j);
inc(p);
until j = L;
Name[j] := #0; // make ASCIIZ
inc(PByte(H), sizeof(H^) + info^.NameLen + H^.fileInfo.extraLen + H^.commentLen);
if (info^.zZipMethod in [0, 8]) and (Name[j - 1] <> '\') then
inc(Count); // known methods: stored + deflate
end;
end;
end;
constructor TZipRead.Create(Instance: THandle; const ResName: string; ResType: PChar);
// locked resources are memory map of the executable -> direct access is easy
var
HResInfo: THandle;
HGlobal: THandle;
begin
HResInfo := FindResource(Instance, PChar(ResName), ResType);
if HResInfo = 0 then
exit;
HGlobal := LoadResource(HInstance, HResInfo);
if HGlobal <> 0 then
// warning: resources size may be rounded up to alignment
Create(LockResource(HGlobal), SizeofResource(HInstance, HResInfo));
end;
constructor TZipRead.Create(const aFileName: TFileName; ZipStartOffset, Size:
cardinal; ShowMessageBoxOnError: boolean);
var
i, ExeOffset: integer;
begin
fShowMessageBoxOnError := ShowMessageBoxOnError;
file_ := CreateFile(pointer(aFileName), GENERIC_READ, FILE_SHARE_READ, nil,
OPEN_EXISTING, 0, 0);
if file_ = INVALID_HANDLE_VALUE then
exit; // file doesn't exist -> leave no Entry[] (Count=0)
if Size = 0 then
Size := GetFileSize(file_, nil);
map := CreateFileMapping(file_, nil, PAGE_READONLY, 0, 0, nil);
if map = 0 then begin
Unmap;
if ShowMessageBoxOnError then
MessageBox(0, pointer(aFileName), 'No File', MB_SYSTEMMODAL or MB_ICONERROR);
exit;
end;
Buf := MapViewOfFile(map, FILE_MAP_READ, 0, 0, 0);
ExeOffset := -1;
for i := ZipStartOffset to Size - 5 do
if pCardinal(@buf[i])^ + 1 = $04034b51 then begin // +1 to avoid finding it in the exe
ExeOffset := i;
break;
end;
if ExeOffset < 0 then begin
Unmap;
if ShowMessageBoxOnError then
MessageBox(0, 'No ZIP found', nil, MB_SYSTEMMODAL or MB_ICONERROR);
exit;
end;
fZipStartOffset := ExeOffset;
Create(@Buf[ExeOffset], integer(Size) - ExeOffset);
end;
procedure TZipRead.UnMap;
begin
Count := 0;
if file_ <> INVALID_HANDLE_VALUE then begin
if map <> 0 then begin
UnmapViewOfFile(Buf);
CloseHandle(map);
end;
CloseHandle(file_);
file_ := INVALID_HANDLE_VALUE;
end;
Buf := nil;
end;
destructor TZipRead.Destroy;
begin
UnMap;
inherited;
end;
function StrICompAnsi(Str1, Str2: PAnsiChar): integer;
var
C1, C2: AnsiChar;
begin
if Str1 <> Str2 then
if Str1 <> nil then
if Str2 <> nil then begin
repeat
C1 := Str1^;
C2 := Str2^;
if C1 in ['a'..'z'] then
dec(C1, 32);
if C2 in ['a'..'z'] then
dec(C2, 32);
if (C1 <> C2) or (C1 = #0) then
break;
inc(Str1);
inc(Str2);
until false;
result := ord(C1) - ord(C2);
end
else
result := 1 // Str2=''
else
result := -1 // Str1=''
else
result := 0; // Str1=Str2
end;
function TZipRead.NameToIndex(const aZipName: TZipName): integer;
begin
if (self <> nil) and (aZipName <> '') then
for result := 0 to Count - 1 do
if StrICompAnsi(@Entry[result].Name, pointer(aZipName)) = 0 then
exit;
result := -1;
end;
function TZipRead.UnZip(aIndex: integer): RawByteZip;
var
len: cardinal;
begin
result := ''; // somewhat faster if memory is reallocated each time
if cardinal(aIndex) >= cardinal(Count) then
exit;
with Entry[aIndex] do begin
SetLength(result, info^.zfullSize);
if info^.zZipMethod = 0 then begin // stored method
len := info^.zfullsize;
move(data^, pointer(result)^, len);
end
else // deflate method
len := UnCompressMem(data, pointer(result), info^.zzipsize, info^.zfullsize);
if (len <> info^.zfullsize) or
(info^.zcrc32 <> not UpdateCrc32(dword(-1), pointer(result), info^.zfullSize)) then
result := '';
end;
end;
{$ifdef DELPHI5OROLDER}
function DirectoryExists(const Directory: string): boolean;
var
Code: integer;
begin
Code := GetFileAttributes(pointer(Directory));
result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);
end;
{$endif}
function ForceDirectories(const Dir: TFileName): boolean;
begin
if (Length(Dir) < 3) or DirectoryExists(Dir) or (ExtractFileDir(Dir) = Dir)
then // avoid 'x:\' problem.
result := true
else
result := ForceDirectories(ExtractFileDir(Dir)) and CreateDir(Dir);
end;
function TZipRead.CheckFile(aIndex: integer; DestPath: TFileName): boolean;
var
F, map: THandle;
Buf: pointer;
Size: cardinal;
begin
result := false;
if (cardinal(aIndex) >= cardinal(Count)) or (DestPath = '') then
exit;
if DestPath[length(DestPath)] <> '\' then
DestPath := DestPath + '\';
F := CreateFile(pointer(DestPath + Entry[aIndex].Name), GENERIC_READ,
FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0);
if F <> INVALID_HANDLE_VALUE then
with Entry[aIndex] do
try
Size := GetFileSize(F, nil);
if Size <> info^.zFullSize then
exit;
if Size = 0 then
result := true
else begin
map := CreateFileMapping(F, nil, PAGE_READONLY, 0, 0, nil);
if map = 0 then
exit;
Buf := MapViewOfFile(map, FILE_MAP_READ, 0, 0, 0);
if (Buf <> nil) and (info^.zcrc32 =
not UpdateCrc32(dword(-1), Buf, info^.zfullSize)) then
result := true;
UnmapViewOfFile(Buf);
CloseHandle(map);
end;
finally
CloseHandle(F);
end;
end;
function TZipRead.UnZipFile(aIndex: integer; DestPath: TFileName;
ForceWriteFlush: boolean): boolean;
var
n, f: TFileName;
buf: pointer;
{$ifdef TRIMDIRECTORYNAME}
i: integer;
{$endif}
fFileSize, len: cardinal;
H: THandle;
fFileTime, dFileTime: TFileTime;
begin
result := false;
if (cardinal(aIndex) >= cardinal(Count)) or (DestPath = '') then
exit;
if DestPath[Length(DestPath)] = '\' then
SetLength(DestPath, Length(DestPath) - 1);
if not DirectoryExists(DestPath) then
exit;
if DestPath[length(DestPath)] <> '\' then
DestPath := DestPath + '\';
with Entry[aIndex] do begin
DosDateTimeToFileTime(info^.zlastModDate, info^.zlastModTime, dFileTime);
n := TFileName(Name);
{$ifdef TRIMDIRECTORYNAME}
i := pos('\', n);
if i > 0 then
delete(n, 1, i); // trim directory name
{$endif}
f := DestPath + n;
H := FileOpen(f, fmOpenRead);
if H <> INVALID_HANDLE_VALUE then begin
GetFileTime(H, nil, nil, @fFileTime);
FileTimeToLocalFileTime(fFileTime, fFileTime);
fFileSize := GetFileSize(H, nil);
FileClose(H);
if (Int64(dFileTime) = Int64(fFileTime)) and (info^.zfullsize = fFileSize)
then begin
result := true;
exit; // good file is already there: don't overwrite for nothing
end;
while not Windows.DeleteFile(pointer(f)) do // delete wrong version
MessageBox(0, pointer('File ' + UpperCase(n) + ' is still in use.'#13#13
+ 'Please Close it for update.'), nil, mb_iconerror);
end;
ForceDirectories(ExtractFileDir(f));
H := FileCreate(f);
if H <> INVALID_HANDLE_VALUE then
try
if info^.zZipMethod = 0 then begin // stored method
if info^.zcrc32 <> not UpdateCrc32(dword(-1), data, info^.zfullSize) then
exit;
FileWrite(H, data^, info^.zfullsize);
end
else begin // deflate method
GetMem(buf, info^.zfullsize);
try
len := UnCompressMem(data, buf, info^.zzipsize, info^.zfullsize);
if (len <> info^.zfullsize) or
(info^.zcrc32 <> not UpdateCrc32(dword(-1), buf, info^.zfullSize)) then
exit;
FileWrite(H, buf^, info^.zfullsize);
finally
FreeMem(buf);
end;
end;
if LocalFileTimeToFileTime(dFileTime, fFileTime) and
SetFileTime(H, @fFileTime, @fFileTime, @fFileTime) then
result := true;
if ForceWriteFlush then
FlushFileBuffers(H);
finally
FileClose(H);
end;
end;
end;
function TZipRead.GetInitialExeContent: RawByteZip;
begin
if (self = nil) or (Buf = nil) or (Count = 0) or (ZipStartOffset = 0) then
result := ''
else
SetString(result, PAnsiChar(Buf), ZipStartOffset);
end;
{ TZipWrite }
procedure TZipWrite.AddDeflated(const aZipName: TZipName; Buf: pointer; Size,
CompressLevel, FileAge: integer);
var
tmp: pointer;
tmpsize: integer;
begin
if (self = nil) or (Handle = 0) or (Handle < 0) then
exit;
if Count >= length(Entry) then
SetLength(Entry, length(Entry) + 20);
with Entry[Count] do begin
name := aZipName;
with fhr, fileInfo do begin
signature := $02014b50 + 1;
dec(signature); // +1 to avoid finding it in the exe
madeBy := $14;
neededVersion := $14;
nameLen := length(name);
zcrc32 := not UpdateCrc32(dword(-1), Buf, Size);
zfullSize := Size;
zzipMethod := 8; // deflate
PInteger(@zlastModTime)^ := FileAge;
localHeadOff := SetFilePointer(Handle, 0, nil, FILE_CURRENT) - fAppendOffset;
tmpsize := (Size * 11) div 10 + 12;
Getmem(tmp, tmpSize);
zzipSize := CompressMem(Buf, tmp, Size, tmpSize);
FileWrite(Handle, fMagic, 4);
FileWrite(Handle, fileInfo, sizeof(fileInfo));
FileWrite(Handle, pointer(name)^, nameLen);
FileWrite(Handle, tmp^, zzipSize); // write stored data
Freemem(tmp);
end;
end;
inc(Count);
end;
procedure TZipWrite.AddDeflated(const aFileName: TFileName; RemovePath: boolean;
CompressLevel: integer);
var
H: THandle;
buf: pointer;
Size: integer;
Time: TFileTime;
ZipName: TZipName;
FileTime: LongRec;
begin
H := FileOpen(aFileName, fmOpenRead or fmShareDenyNone);
if H = INVALID_HANDLE_VALUE then
exit;
if RemovePath then
ZipName := TZipName(ExtractFileName(aFileName))
else
ZipName := TZipName(aFileName);
GetFileTime(H, nil, nil, @Time);
FileTimeToLocalFileTime(Time, Time);
FileTimeToDosDateTime(Time, FileTime.Hi, FileTime.Lo);
Size := GetFileSize(H, nil);
getmem(buf, Size);
FileRead(H, buf^, Size);
AddDeflated(ZipName, buf, size, CompressLevel, integer(FileTime));
freemem(buf);
FileClose(H);
end;
procedure TZipWrite.AddFromZip(const ZipEntry: TZipEntry);
begin
if (self = nil) or (Handle = 0) or (Handle = integer(INVALID_HANDLE_VALUE)) then
exit;
if Count >= length(Entry) then
SetLength(Entry, length(Entry) + 20);
with Entry[Count] do begin
name := ZipEntry.Name;
with fhr do begin
signature := $02014b50 + 1;
dec(signature); // +1 to avoid finding it in the exe
madeBy := $14;
fileInfo := ZipEntry.info^;
fileInfo.nameLen := length(name);
localHeadOff := SetFilePointer(Handle, 0, nil, FILE_CURRENT) - fAppendOffset;
FileWrite(Handle, fMagic, 4);
FileWrite(Handle, fileInfo, sizeof(fileInfo));
FileWrite(Handle, pointer(name)^, fileInfo.nameLen);
FileWrite(Handle, ZipEntry.data^, fileInfo.zzipSize);
end;
end;
inc(Count);
end;
procedure TZipWrite.AddStored(const aZipName: TZipName; Buf: pointer; Size,
FileAge: integer);
begin
if (self = nil) or (Handle = 0) or (Handle = integer(INVALID_HANDLE_VALUE)) then
exit;
if Count >= length(Entry) then
SetLength(Entry, length(Entry) + 20);
with Entry[Count] do begin
name := aZipName;
with fhr, fileInfo do begin
signature := $02014b50 + 1;
dec(signature); // +1 to avoid finding it in the exe
madeBy := $14;
neededVersion := $14;
nameLen := length(name);
zcrc32 := not UpdateCrc32(dword(-1), Buf, Size);
zfullSize := Size;
zzipSize := Size;
PInteger(@zlastModTime)^ := FileAge;
localHeadOff := SetFilePointer(Handle, 0, nil, FILE_CURRENT) - fAppendOffset;
FileWrite(Handle, fMagic, 4);
FileWrite(Handle, fileInfo, sizeof(fileInfo));
FileWrite(Handle, pointer(name)^, nameLen);
FileWrite(Handle, Buf^, Size); // write stored data
end;
end;
inc(Count);
end;
procedure TZipWrite.Append(const Content: RawByteZip);
begin
if (self = nil) or (Handle = 0) or (Handle = integer(INVALID_HANDLE_VALUE)) or
(fAppendOffset <> 0) then
exit;
fAppendOffset := length(Content);
FileWrite(Handle, pointer(Content)^, fAppendOffset);
end;
constructor TZipWrite.Create(const aFileName: TFileName);
begin
Handle := FileCreate(aFileName);
fFileName := aFileName;
fMagic := $04034b50 + 1; // +1 to avoid finding it in the exe
dec(fMagic);
end;
destructor TZipWrite.Destroy;
var
lhr: TLastHeader;
i: integer;
begin
fillchar(lhr, sizeof(lhr), 0);
lhr.signature := $06054b50 + 1;
dec(lhr.signature); // +1 to avoid finding it in the exe
lhr.thisFiles := Count;
lhr.totalFiles := Count;
lhr.headerOffset := SetFilePointer(Handle, 0, nil, FILE_CURRENT) - fAppendOffset;
for i := 0 to Count - 1 do
with Entry[i] do begin
//assert(fhr.fileInfo.nameLen=length(name));
inc(lhr.headerSize, sizeof(TFileHeader) + fhr.fileInfo.nameLen);
FileWrite(Handle, fhr, sizeof(fhr));
FileWrite(Handle, pointer(Name)^, fhr.fileInfo.nameLen);
end;
FileWrite(Handle, lhr, sizeof(lhr));
SetEndOfFile(Handle);
FileClose(Handle);
{ with TZipRead.Create(fFileName) do
try
assert(Count=self.Count);
for i := 0 to Count-1 do
assert(Entry[i].Name=self.Entry[i].Name);
finally
Free;
end;}
inherited;
end;
{$endif MSWINDOWS}
initialization
{$ifdef DYNAMIC_CRC_TABLE}
InitCrc32Tab;
{$endif DYNAMIC_CRC_TABLE}
end.
Reference in New Issue View Git Blame Copy Permalink