--- /dev/null
+[Compiler]\r
+A=1\r
+B=0\r
+C=1\r
+D=1\r
+E=0\r
+F=0\r
+G=1\r
+H=1\r
+I=1\r
+J=1\r
+K=0\r
+L=1\r
+M=0\r
+N=1\r
+O=1\r
+P=1\r
+Q=0\r
+R=0\r
+S=0\r
+T=0\r
+U=0\r
+V=1\r
+W=0\r
+X=1\r
+Y=0\r
+Z=1\r
+ShowHints=1\r
+ShowWarnings=1\r
+UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;\r
+[Linker]\r
+MapFile=0\r
+OutputObjs=0\r
+ConsoleApp=1\r
+DebugInfo=0\r
+MinStackSize=16384\r
+MaxStackSize=1048576\r
+ImageBase=4194304\r
+ExeDescription=\r
+[Directories]\r
+OutputDir=\r
+UnitOutputDir=\r
+SearchPath=\r
+Packages=\r
+Conditionals=\r
+DebugSourceDirs=\r
+UsePackages=0\r
+[Parameters]\r
+RunParams=\r
+HostApplication=\r
+[Version Info]\r
+IncludeVerInfo=0\r
+AutoIncBuild=0\r
+MajorVer=1\r
+MinorVer=0\r
+Release=0\r
+Build=0\r
+Debug=0\r
+PreRelease=0\r
+Special=0\r
+Private=0\r
+DLL=0\r
+Locale=2057\r
+CodePage=1252\r
+[Version Info Keys]\r
+CompanyName=\r
+FileDescription=\r
+FileVersion=1.0.0.0\r
+InternalName=\r
+LegalCopyright=\r
+LegalTrademarks=\r
+OriginalFilename=\r
+ProductName=\r
+ProductVersion=1.0.0.0\r
+Comments=\r
--- /dev/null
+program Project1;\r
+\r
+uses\r
+ Forms,\r
+ Unit1 in 'Unit1.pas' {Form1},\r
+ pngwrite in 'pngwrite.pas';\r
+\r
+{$R *.RES}\r
+\r
+begin\r
+ Application.Initialize;\r
+ Application.CreateForm(TForm1, Form1);\r
+ Application.Run;\r
+end.\r
--- /dev/null
+//demo code that lets the user draw an image and then save it to a png file\r
+\r
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+ For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+ which is included in the package\r
+ ----------------------------------------------------------------------------- }\r
+\r
+unit Unit1;\r
+\r
+interface\r
+\r
+uses\r
+ Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,\r
+ ExtCtrls, ColorGrd, StdCtrls;\r
+\r
+type\r
+ TForm1 = class(TForm)\r
+ Shape1: TShape;\r
+ ColorGrid1: TColorGrid;\r
+ Image1: TImage;\r
+ Button1: TButton;\r
+ procedure FormCreate(Sender: TObject);\r
+ procedure Shape1MouseDown(Sender: TObject; Button: TMouseButton;\r
+ Shift: TShiftState; X, Y: Integer);\r
+ procedure Button1Click(Sender: TObject);\r
+ private\r
+ { Private declarations }\r
+ public\r
+ { Public declarations }\r
+ end;\r
+\r
+var\r
+ Form1: TForm1;\r
+\r
+implementation\r
+uses\r
+ pngwrite;\r
+{$R *.DFM}\r
+type\r
+ tshapesline = array [0..0] of tshape;\r
+ pshapesline = ^tshapesline;\r
+ tshapes = array [0..0] of pshapesline;\r
+ pshapes = ^tshapes;\r
+var\r
+ shapes : pshapes;\r
+ maxline,maxcol : integer;\r
+ procedure TForm1.FormCreate(Sender: TObject);\r
+var\r
+ line,col : integer;\r
+\r
+begin\r
+ maxline := 31;\r
+ maxcol := 63;\r
+ image1.Height := maxline+1;\r
+ image1.Width := maxcol+1;\r
+ Image1.Picture.Bitmap.PixelFormat := pf24bit;\r
+ image1.Picture.Bitmap.Height := maxline+1;\r
+ image1.Picture.Bitmap.Width := maxcol+1;\r
+\r
+\r
+ shapes := allocmem((maxline+1)*sizeof(tshape));\r
+ for line := 0 to maxline do begin\r
+ shapes[line] := allocmem((maxcol+1)*sizeof(pshapesline));\r
+ for col := 0 to maxcol do begin\r
+ if (line=0) and (col=0) then begin\r
+ shapes[0][0] := shape1;\r
+ end else begin\r
+ shapes[line][col] := tshape.create(self);\r
+ shapes[line][col].parent := self;\r
+ shapes[line][col].width := shape1.Width;\r
+ shapes[line][col].height := shape1.Width;\r
+ shapes[line][col].left := shape1.left+(shape1.width-1)*col;\r
+ shapes[line][col].top := shape1.top+(shape1.height-1)*line;\r
+ shapes[line][col].OnMouseDown := shape1.OnMouseDown;\r
+ shapes[line][col].tag := line + (col shl 16);\r
+ end;\r
+ end;\r
+ end;\r
+end;\r
+type\r
+ tlinedata = array[0..0] of byte;\r
+ plinedata = ^tlinedata;\r
+procedure TForm1.Shape1MouseDown(Sender: TObject; Button: TMouseButton;\r
+ Shift: TShiftState; X, Y: Integer);\r
+var\r
+ line : integer;\r
+ col : integer;\r
+ linedata : plinedata;\r
+begin\r
+ tshape(sender).Brush.Color := ColorGrid1.ForegroundColor;\r
+ line := tshape(sender).tag and $FFFF;\r
+ col := tshape(sender).tag shr 16;\r
+ linedata := image1.Picture.Bitmap.scanline[line];\r
+ linedata[(col*3)+2] := tshape(sender).brush.color;\r
+ linedata[(col*3)+1] := tshape(sender).brush.color shr 8;\r
+ linedata[(col*3) ] := tshape(sender).brush.color shr 16;\r
+ //showmessage(inttostr(linedata[(col*3) ])); \r
+ image1.invalidate;\r
+end;\r
+\r
+procedure TForm1.Button1Click(Sender: TObject);\r
+var\r
+ stream : tfilestream;\r
+ f : tpngwrite;\r
+ counter : integer;\r
+begin\r
+ stream := tfilestream.Create('test243.png',fmCreate{fmOpenWrite} or fmShareDenyNone );\r
+ try\r
+ pngstart(f,stream,24,ctbgr,image1.picture.Bitmap.Height,image1.Picture.Bitmap.Width);\r
+ pngstartdata(f);\r
+ for counter := 0 to image1.picture.Bitmap.Height-1 do begin\r
+ pngwritescanline(f,image1.picture.Bitmap.scanline[counter]);\r
+ end;\r
+ pngfinishdata(f);\r
+ pngfinish(f);\r
+ finally\r
+ stream.Free;\r
+ end;\r
+end;\r
+\r
+end.\r
--- /dev/null
+Unit Adler;\r
+\r
+{\r
+ adler32.c -- compute the Adler-32 checksum of a data stream\r
+ Copyright (C) 1995-1998 Mark Adler\r
+\r
+ Pascal tranlastion\r
+ Copyright (C) 1998 by Jacques Nomssi Nzali\r
+ For conditions of distribution and use, see copyright notice in readme.paszlib\r
+}\r
+\r
+interface\r
+\r
+{$I zconf.inc}\r
+\r
+uses\r
+ zutil;\r
+\r
+function adler32(adler : uLong; buf : pBytef; len : uInt) : uLong;\r
+\r
+{ Update a running Adler-32 checksum with the bytes buf[0..len-1] and\r
+ return the updated checksum. If buf is NIL, this function returns\r
+ the required initial value for the checksum.\r
+ An Adler-32 checksum is almost as reliable as a CRC32 but can be computed\r
+ much faster. Usage example:\r
+\r
+ var\r
+ adler : uLong;\r
+ begin\r
+ adler := adler32(0, Z_NULL, 0);\r
+\r
+ while (read_buffer(buffer, length) <> EOF) do\r
+ adler := adler32(adler, buffer, length);\r
+\r
+ if (adler <> original_adler) then\r
+ error();\r
+ end;\r
+}\r
+\r
+implementation\r
+\r
+const\r
+ BASE = uLong(65521); { largest prime smaller than 65536 }\r
+ {NMAX = 5552; original code with unsigned 32 bit integer }\r
+ { NMAX is the largest n such that 255n(n+1)/2 + (n+1)(BASE-1) <= 2^32-1 }\r
+ NMAX = 3854; { code with signed 32 bit integer }\r
+ { NMAX is the largest n such that 255n(n+1)/2 + (n+1)(BASE-1) <= 2^31-1 }\r
+ { The penalty is the time loss in the extra MOD-calls. }\r
+\r
+\r
+{ ========================================================================= }\r
+\r
+function adler32(adler : uLong; buf : pBytef; len : uInt) : uLong;\r
+var\r
+ s1, s2 : uLong;\r
+ k : int;\r
+begin\r
+ s1 := adler and $ffff;\r
+ s2 := (adler shr 16) and $ffff;\r
+\r
+ if not Assigned(buf) then\r
+ begin\r
+ adler32 := uLong(1);\r
+ exit;\r
+ end;\r
+\r
+ while (len > 0) do\r
+ begin\r
+ if len < NMAX then\r
+ k := len\r
+ else\r
+ k := NMAX;\r
+ Dec(len, k);\r
+ {\r
+ while (k >= 16) do\r
+ begin\r
+ DO16(buf);\r
+ Inc(buf, 16);\r
+ Dec(k, 16);\r
+ end;\r
+ if (k <> 0) then\r
+ repeat\r
+ Inc(s1, buf^);\r
+ Inc(puf);\r
+ Inc(s2, s1);\r
+ Dec(k);\r
+ until (k = 0);\r
+ }\r
+ while (k > 0) do\r
+ begin\r
+ Inc(s1, buf^);\r
+ Inc(s2, s1);\r
+ Inc(buf);\r
+ Dec(k);\r
+ end;\r
+ s1 := s1 mod BASE;\r
+ s2 := s2 mod BASE;\r
+ end;\r
+ adler32 := (s2 shl 16) or s1;\r
+end;\r
+\r
+{\r
+#define DO1(buf,i)\r
+ begin\r
+ Inc(s1, buf[i]);\r
+ Inc(s2, s1);\r
+ end;\r
+#define DO2(buf,i) DO1(buf,i); DO1(buf,i+1);\r
+#define DO4(buf,i) DO2(buf,i); DO2(buf,i+2);\r
+#define DO8(buf,i) DO4(buf,i); DO4(buf,i+4);\r
+#define DO16(buf) DO8(buf,0); DO8(buf,8);\r
+}\r
+end.\r
+\r
--- /dev/null
+[Compiler]\r
+A=1\r
+B=0\r
+C=1\r
+D=1\r
+E=0\r
+F=0\r
+G=1\r
+H=1\r
+I=1\r
+J=1\r
+K=0\r
+L=1\r
+M=0\r
+N=1\r
+O=1\r
+P=1\r
+Q=0\r
+R=0\r
+S=0\r
+T=0\r
+U=0\r
+V=1\r
+W=0\r
+X=1\r
+Y=0\r
+Z=1\r
+ShowHints=1\r
+ShowWarnings=1\r
+UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;\r
+[Linker]\r
+MapFile=0\r
+OutputObjs=0\r
+ConsoleApp=1\r
+DebugInfo=0\r
+MinStackSize=16384\r
+MaxStackSize=1048576\r
+ImageBase=4194304\r
+ExeDescription=\r
+[Directories]\r
+OutputDir=\r
+UnitOutputDir=\r
+SearchPath=\r
+Packages=\r
+Conditionals=\r
+DebugSourceDirs=\r
+UsePackages=0\r
+[Parameters]\r
+RunParams=\r
+HostApplication=\r
+[Version Info]\r
+IncludeVerInfo=0\r
+AutoIncBuild=0\r
+MajorVer=1\r
+MinorVer=0\r
+Release=0\r
+Build=0\r
+Debug=0\r
+PreRelease=0\r
+Special=0\r
+Private=0\r
+DLL=0\r
+Locale=2057\r
+CodePage=1252\r
+[Version Info Keys]\r
+CompanyName=\r
+FileDescription=\r
+FileVersion=1.0.0.0\r
+InternalName=\r
+LegalCopyright=\r
+LegalTrademarks=\r
+OriginalFilename=\r
+ProductName=\r
+ProductVersion=1.0.0.0\r
+Comments=\r
--- /dev/null
+//test program for png code, uses ct8bp mode to draw a red and white heart\r
+//in 1 2 4 and 8 bit per pixel modes.\r
+\r
+program drawheart;\r
+\r
+uses\r
+ pngwrite,classes,sysutils;\r
+\r
+{ $R *.RES}\r
+const\r
+ imagedata : array[0..10] of array [0..10] of byte=(\r
+ (0,0,0,0,0,0,0,0,0,0,0),\r
+ (0,0,1,1,1,0,1,1,1,0,0),\r
+ (0,1,1,1,1,0,1,1,1,1,0),\r
+ (0,1,1,1,1,1,1,1,1,1,0),\r
+ (0,1,1,1,1,1,1,1,1,1,0),\r
+ (0,1,1,1,1,1,1,1,1,1,0),\r
+ (0,0,1,1,1,1,1,1,1,0,0),\r
+ (0,0,0,1,1,1,1,1,0,0,0),\r
+ (0,0,0,0,1,1,1,0,0,0,0),\r
+ (0,0,0,0,0,1,0,0,0,0,0),\r
+ (0,0,0,0,0,0,0,0,0,0,0)\r
+ );\r
+ paldata : array[0..5] of byte=(255,255,255,255,0,0);\r
+var\r
+ outer,counter : integer;\r
+ stream : tfilestream;\r
+ f : tpngwrite;\r
+begin\r
+ for outer := 0 to 3 do begin\r
+\r
+ stream := tfilestream.Create('heart'+inttostr(1 shl outer)+'.png',fmCreate{fmOpenWrite} or fmShareDenyNone );\r
+ try\r
+ pngstart(f,stream,1 shl outer,ct8bp,11,11);\r
+ pngwritepal(f,@paldata,2);\r
+ pngstartdata(f);\r
+\r
+ for counter := 0 to 10 do begin\r
+ pngwritescanline(f,@imagedata[counter]);\r
+ end;\r
+ pngfinishdata(f);\r
+ pngfinish(f);\r
+ finally\r
+ stream.Free;\r
+ end;\r
+ end;\r
+end.\r
--- /dev/null
+//graph draw test/demo app\r
+program graphdraw;\r
+\r
+uses\r
+ Forms,\r
+ graphdrawu in 'graphdrawu.pas' {Form1};\r
+\r
+{$R *.RES}\r
+\r
+begin\r
+ Application.Initialize;\r
+ Application.CreateForm(TForm1, Form1);\r
+ Application.Run;\r
+end.\r
--- /dev/null
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+ For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+ which is included in the package\r
+ ----------------------------------------------------------------------------- }\r
+\r
+//main unit for graph drawing demo\r
+\r
+//draws a sine and cosine graph into a 2 bit per pixel\r
+//array.\r
+//Copies it into a truecolor tbitmap (that is visible on the main form).\r
+//saves the graph from the original buffer to a 2 bit palleted png\r
+//saves the graph from the original buffer to a 2 bit greyscale png\r
+//saves the graph from the tbitmap into a 24 bit truecolor bitmap\r
+\r
+unit graphdrawu;\r
+\r
+interface\r
+\r
+uses\r
+ Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,\r
+ ExtCtrls,pngwrite,pngwritetbitmap;\r
+\r
+type\r
+ TForm1 = class(TForm)\r
+ Image1: TImage;\r
+ procedure FormCreate(Sender: TObject);\r
+ private\r
+ { Private declarations }\r
+ public\r
+ { Public declarations }\r
+ end;\r
+\r
+var\r
+ Form1: TForm1;\r
+ pal : array[0..11] of byte;\r
+implementation\r
+\r
+{$R *.DFM}\r
+\r
+type\r
+ tlinedata = array[word] of byte;\r
+ plinedata = ^tlinedata;\r
+ timagedata = array[word] of plinedata;\r
+ pimagedata = ^timagedata;\r
+var\r
+ imagedata : pimagedata;\r
+procedure TForm1.FormCreate(Sender: TObject);\r
+var\r
+ counter : integer;\r
+ inner : integer;\r
+ y : integer;\r
+ bitmapscanline : plinedata;\r
+ tempfloat : extended;\r
+ currentindex : integer;\r
+ fracpart : integer;\r
+ f : tpngwrite;\r
+ stream : tfilestream;\r
+begin\r
+ //black\r
+ pal[ 0] := 0;\r
+ pal[ 1] := 0;\r
+ pal[ 2] := 0;\r
+\r
+ //blue\r
+ pal[ 3] := 0;\r
+ pal[ 4] := 0;\r
+ pal[ 5] := $FF;\r
+\r
+ //red\r
+ pal[ 6] := $FF;\r
+ pal[ 7] := 0;\r
+ pal[ 8] := 0;\r
+\r
+ //white\r
+ pal[ 9] := $ff;\r
+ pal[10] := $ff;\r
+ pal[11] := $FF;\r
+\r
+ imagedata := allocmem(image1.height*sizeof(plinedata));\r
+ image1.width := (image1.width div 4)*4;\r
+ image1.width := image1.width;\r
+ for counter := 0 to image1.height-1 do begin\r
+\r
+ imagedata[counter] := allocmem(image1.width div 4);\r
+ imagedata[counter][image1.width div 8] := imagedata[counter][image1.width div 8] or $C0;\r
+\r
+ end;\r
+ fillchar(imagedata[image1.height div 2]^,image1.width div 4,#$FF);\r
+ for counter := 0 to image1.width-1 do begin\r
+// tempfloat := ;\r
+ for fracpart := 0 to 15 do begin\r
+ y := round( -sin((( (counter+(fracpart/15)) / image1.width){+0.5}) *2*pi ) *((image1.height-20)div 2) )+((image1.height)div 2);\r
+ //writeln(y);\r
+ imagedata[y][counter div 4] := (imagedata[y][counter div 4]) or (1 shl (((counter and $3)xor$3)*2) );\r
+\r
+ y := round( -cos((( (counter+(fracpart/15)) / image1.width){+0.5}) *2*pi ) *((image1.height-20)div 2) )+((image1.height)div 2);\r
+ //writeln(y);\r
+ imagedata[y][counter div 4] := (imagedata[y][counter div 4]) or (2 shl (((counter and $3)xor$3)*2) );\r
+ end ;\r
+ end;\r
+ image1.Picture.Bitmap.PixelFormat :=pf24bit;\r
+ image1.picture.bitmap.width := image1.width;\r
+ image1.picture.bitmap.height := image1.height;\r
+\r
+\r
+ for counter := 0 to image1.height-1 do begin\r
+ bitmapscanline := image1.picture.bitmap.ScanLine[counter];\r
+ for inner := 0 to image1.width-1 do begin\r
+\r
+ currentindex := (imagedata[counter][inner div 4] shr (((inner and $3)xor$3)*2) ) and $3;\r
+ //if (counter=0) and (imagedata[counter][inner div 4] <> 0) then begin\r
+ // writeln(imagedata[counter][inner div 4]);\r
+ // writeln(currentindex);\r
+ // writeln;\r
+ //end;\r
+ bitmapscanline[(inner*3) ] := pal[(currentindex*3)+2];\r
+ bitmapscanline[(inner*3)+1] := pal[(currentindex*3)+1];\r
+ bitmapscanline[(inner*3)+2] := pal[(currentindex*3) ];\r
+\r
+ end;\r
+ end;\r
+ image1.invalidate;\r
+\r
+ stream := tfilestream.Create('truecolor.png',fmCreate{fmOpenWrite} or fmShareDenyNone );\r
+ try\r
+ savetbitmaptopng(image1.picture.Bitmap,stream);\r
+ finally\r
+ stream.Free;\r
+ end;\r
+\r
+ stream := tfilestream.Create('4grey.png',fmCreate{fmOpenWrite} or fmShareDenyNone );\r
+ try\r
+ pngstart(f,stream,2,ctgreyscale ,image1.picture.Bitmap.Height,image1.Picture.Bitmap.Width);\r
+ pngstartdata(f);\r
+\r
+ for counter := 0 to image1.picture.Bitmap.Height-1 do begin\r
+ pngwritescanline(f,imagedata[counter]);\r
+ end;\r
+ pngfinishdata(f);\r
+ pngfinish(f);\r
+ finally\r
+ stream.Free;\r
+ end;\r
+\r
+ stream := tfilestream.Create('4color.png',fmCreate{fmOpenWrite} or fmShareDenyNone );\r
+ try\r
+ pngstart(f,stream,2,ctpallette ,image1.picture.Bitmap.Height,image1.Picture.Bitmap.Width);\r
+ pngwritepal(f,@pal,4);\r
+ pngstartdata(f);\r
+\r
+ for counter := 0 to image1.picture.Bitmap.Height-1 do begin\r
+ pngwritescanline(f,imagedata[counter]);\r
+ end;\r
+ pngfinishdata(f);\r
+ pngfinish(f);\r
+ finally\r
+ stream.Free;\r
+ end;\r
+\r
+\r
+\r
+end;\r
+\r
+end.\r
--- /dev/null
+{io core originally for linux bworld}\r
+\r
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+ For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+ which is included in the package\r
+ ----------------------------------------------------------------------------- }\r
+\r
+unit pgtypes;\r
+interface\r
+ type\r
+ {$ifdef cpu386}{$define i386}{$endif}\r
+ {$ifdef i386}\r
+ taddrint=longint;\r
+ {$else}\r
+ taddrint=sizeint;\r
+ {$endif}\r
+ paddrint=^taddrint;\r
+\r
+implementation\r
+end.\r
--- /dev/null
+{pngwrite.pas}\r
+{plugwashes png write code}\r
+\r
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+ For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+ which is included in the package\r
+ ----------------------------------------------------------------------------- }\r
+\r
+unit pngwrite;\r
+\r
+interface\r
+uses\r
+ zlib,zdeflate,zutil,classes,sysutils,pgtypes,\r
+ {$ifdef win32}\r
+ winsock;\r
+ {$else}\r
+ sockets;\r
+ {$endif}\r
+{$i uint32.inc}\r
+\r
+type\r
+\r
+ tcolortype=(ctgreyscale,ctpallette,ctbgr,ctrgb,ct8bp);\r
+\r
+// There are two types of color types\r
+//\r
+// native types result in direct output of the apps data to the png file\r
+// theese are\r
+// ctgreyscale : grey scale data all png supported depths should work\r
+// ctpallette : palletted data all png supported depths should work\r
+// ctrgb : currently 24 bit only\r
+//\r
+// Processed types are processed before data is output to the png file\r
+// ctbgr : truecolor data in bgr order usefull with tbitmap.\r
+// ct8bp : data from app is 8 bits per sample palletted but data is saved as\r
+// a lower depth palletted format (the app MUST only use the first\r
+// 2^bitdepth pallette entries\r
+\r
+ tpngwrite=record\r
+ destination : tstream;\r
+ lines : integer;\r
+ cols : integer;\r
+ deflatestream : z_stream;\r
+ chunkstart : integer; //used to fill in chunk length later\r
+ chunkbytes : integer;\r
+ chunkcrc : uint32;\r
+ crc_table : array[byte] of uint32;\r
+ colortype:tcolortype;\r
+ colordepth : byte;\r
+ bufferingchunkdata : boolean;\r
+ bufferedchunkdata : tstringlist;\r
+ end;\r
+\r
+procedure pngstart(var f : tpngwrite;destination : tstream;colordepth : integer;colortype:tcolortype;lines : integer;cols : integer);\r
+procedure pngwritescanline(var f : tpngwrite;scanline: pointer);\r
+\r
+\r
+procedure pngwritepal(var f : tpngwrite;p:pointer;entrys : integer);\r
+procedure pngstartdata(var f : tpngwrite);\r
+procedure pngfinishdata(var f : tpngwrite);\r
+procedure pngfinish(var f : tpngwrite);\r
+\r
+\r
+\r
+implementation\r
+\r
+\r
+procedure make_crc_table(var f:tpngwrite);\r
+var\r
+ c: uint32;\r
+ n,k : integer;\r
+begin\r
+ with f do begin\r
+\r
+// unsigned long c;\r
+// int n, k;\r
+// for (n = 0; n < 256; n++)\r
+ for n := 0 to 255 do begin\r
+// c = (unsigned long) n;\r
+ c := n;\r
+// for (k = 0; k < 8; k++)\r
+ for k := 0 to 7 do begin\r
+// if (c & 1)\r
+ if (c and 1) <> 0 then begin\r
+// c = 0xedb88320L ^ (c >> 1);\r
+ c := $edb88320 xor (c shr 1);\r
+// else\r
+ end else begin\r
+// c = c >> 1;\r
+ c := c shr 1;\r
+//\r
+ end;\r
+ end;\r
+// crc_table[n] = c;\r
+ crc_table[n] := c;\r
+//\r
+ end;\r
+// crc_table_computed = 1;\r
+ end;\r
+end;\r
+(*\r
+ unsigned long update_crc(unsigned long crc, unsigned char *buf,\r
+ int len)\r
+ {\r
+ unsigned long c = crc;\r
+ int n;\r
+\r
+ if (!crc_table_computed)\r
+ make_crc_table();\r
+ for (n = 0; n < len; n++) {\r
+ c = crc_table[(c ^ buf[n]) & 0xff] ^ (c >> 8);\r
+ }\r
+ return c;\r
+ }\r
+*)\r
+procedure update_crc(var f : tpngwrite;buf : string);\r
+\r
+var\r
+ n : integer;\r
+begin\r
+ with f do begin\r
+ for n := 1 to length(buf) do begin\r
+ chunkcrc := crc_table[(chunkcrc xor byte(buf[n])) and $ff] xor (chunkcrc shr 8);\r
+ end;\r
+ end;\r
+end;\r
+\r
+procedure writetochunk(var f : tpngwrite;buf : string);\r
+begin\r
+ if length(buf)=0 then raise exception.create('attempt to write zero length block to chunk');\r
+ \r
+ with f do begin\r
+ if bufferingchunkdata then begin\r
+ bufferedchunkdata.Add(buf);\r
+ end else begin\r
+ destination.Write(buf[1],length(buf));\r
+ end;\r
+ update_crc(f,buf);\r
+ inc(chunkbytes,length(buf));\r
+ end;\r
+end;\r
+\r
+\r
+procedure startchunk(var f : tpngwrite;chunktype : string);\r
+var\r
+ outputdata : string;\r
+begin\r
+ with f do begin\r
+ try\r
+ chunkstart := destination.Position;\r
+ // 4 btye dummy for length we will insert this later.\r
+ outputdata := ' ';\r
+ destination.WriteBuffer(pchar(outputdata)^,4);\r
+ except\r
+ bufferingchunkdata := true;\r
+ bufferedchunkdata := tstringlist.create;\r
+ end;\r
+ chunkbytes := -4;\r
+ chunkcrc := $FFFFFFFF;\r
+\r
+ writetochunk(f,chunktype);\r
+\r
+\r
+ end;\r
+end;\r
+\r
+\r
+\r
+\r
+procedure stopchunk(var f:tpngwrite);\r
+var\r
+ currentpos : integer;\r
+ i : integer;\r
+begin\r
+ with f do begin\r
+ if not bufferingchunkdata then begin\r
+\r
+ currentpos := destination.Position;\r
+ destination.position := chunkstart;\r
+ end;\r
+ chunkbytes := htonl(chunkbytes);\r
+ destination.WriteBuffer(chunkbytes,4);\r
+ if bufferingchunkdata then begin\r
+// writeln('begin write of buffered chunk data');\r
+ for i := 0 to bufferedchunkdata.Count-1 do begin\r
+ destination.Write(bufferedchunkdata[i][1],length(bufferedchunkdata[i]));\r
+ end;\r
+ bufferedchunkdata.Free;\r
+// writeln('end write of buffered chunk data');\r
+ end else begin\r
+ destination.position := currentpos;\r
+ end;\r
+ chunkcrc := htonl(chunkcrc) ;\r
+ chunkcrc := chunkcrc xor $FFFFFFFF;\r
+ destination.WriteBuffer(chunkcrc,4);\r
+\r
+ end;\r
+end;\r
+\r
+type\r
+ tihdr=packed record\r
+ width : uint32;\r
+ height : uint32;\r
+ Bitdepth : byte;\r
+ Colortype : byte;\r
+ Compressionmethod : byte;\r
+ Filtermethod : byte;\r
+ Interlacemethod : byte;\r
+ end;\r
+ pihdr=^tihdr;\r
+procedure pngstart(var f : tpngwrite;destination : tstream;colordepth : integer;colortype:tcolortype;lines : integer;cols : integer);\r
+var\r
+ tempstring : string;\r
+ ihdr : pihdr;\r
+begin\r
+ fillchar(f,sizeof(f),#0);\r
+ f.destination := destination;\r
+ f.lines := lines;\r
+ f.cols := cols;\r
+ f.colortype := colortype;\r
+ f.colordepth := colordepth;\r
+ make_crc_table(f);\r
+ with f do begin\r
+ //file header\r
+ destination.Write(pchar(#137'PNG'#13#10#26#10)^,8);\r
+\r
+ startchunk(f,'IHDR');\r
+ setlength(tempstring,sizeof(tihdr));\r
+ ihdr := pihdr(tempstring);\r
+ ihdr.width := htonl(cols);\r
+ ihdr.height := htonl(lines);\r
+ case colortype of\r
+ ctgreyscale : begin\r
+ ihdr.Bitdepth := colordepth;\r
+ ihdr.Colortype := 0;\r
+ end;\r
+ ctpallette,ct8bp : begin\r
+ ihdr.Bitdepth := colordepth;\r
+ ihdr.Colortype := 3;\r
+ end;\r
+\r
+ ctrgb,ctbgr : begin\r
+ ihdr.Bitdepth := 8;\r
+ ihdr.Colortype := 2;\r
+ end;\r
+ end;\r
+\r
+ ihdr.Compressionmethod := 0;\r
+ ihdr.Filtermethod := 0;\r
+ ihdr.Interlacemethod := 0;\r
+ writetochunk(f,tempstring);\r
+ stopchunk(f);\r
+\r
+ end;\r
+end;\r
+\r
+procedure pngwritepal(var f : tpngwrite;p:pointer;entrys : integer);\r
+var\r
+ tempstring : string;\r
+begin\r
+ with f do begin\r
+ startchunk(f,'PLTE');\r
+ setlength(tempstring,entrys*3);\r
+ move(p^,tempstring[1],entrys*3);\r
+ writetochunk(f,tempstring);\r
+ stopchunk(f);\r
+ end;\r
+end;\r
+\r
+procedure pngstartdata(var f : tpngwrite);\r
+begin\r
+ with f do begin\r
+ startchunk(f,'IDAT');\r
+ deflateInit(deflatestream,9);\r
+ //writeln('test');\r
+\r
+ end;\r
+end;\r
+\r
+\r
+\r
+type\r
+ tlinedata = array[0..0] of byte;\r
+ plinedata = ^tlinedata;\r
+function divup(a,b:integer):integer;\r
+begin\r
+ result := (a div b)+ord((a mod b)<>0);\r
+end;\r
+\r
+\r
+procedure pngwritescanline(var f : tpngwrite;scanline: pointer);\r
+var\r
+ outputstr : string;\r
+ nullchar : char;\r
+ scanlineb : plinedata absolute scanline;\r
+ rearrangebuf : plinedata;\r
+ counter : integer;\r
+ pixelsperbyte : integer;\r
+ samplevalue : byte;\r
+begin\r
+ with f do begin\r
+ //writeln('about to write starter byte');\r
+ if cols > 127 then begin\r
+ setlength(outputstr,cols*6);\r
+ end else begin\r
+ setlength(outputstr,768);\r
+ end;\r
+ deflatestream.next_out := pbytef(outputstr);\r
+ deflatestream.avail_out := length(outputstr);\r
+// writeln(deflatestream.avail_out,' ',deflatestream.avail_in);\r
+ nullchar := #0;\r
+ deflatestream.next_in := @nullchar;\r
+ deflatestream.avail_in :=1;\r
+ //writeln('about to start deflation');\r
+ deflate(deflatestream,0);\r
+ //writeln('deflation complete deflatestream.avail_out=',deflatestream.avail_out);\r
+// writeln(deflatestream.avail_out,' ',deflatestream.avail_in);\r
+ while deflatestream.avail_out = 0 do begin\r
+ deflatestream.next_out := pbytef(taddrint(deflatestream.next_out) - taddrint(outputstr));\r
+ deflatestream.avail_out := length(outputstr);\r
+ setlength(outputstr,length(outputstr)*2);\r
+ deflatestream.next_out := pbytef(taddrint(deflatestream.next_out) + taddrint(outputstr));\r
+ deflate(deflatestream,0);\r
+ end;\r
+ //writeln('extra deflation done');\r
+ if deflatestream.avail_in <> 0 then raise exception.create('compression problem');\r
+ //writeln('about to write main data');\r
+ case colortype of\r
+\r
+ ctbgr : begin\r
+ getmem(rearrangebuf,cols*3);\r
+\r
+ for counter := 0 to cols-1 do begin\r
+ rearrangebuf[(counter*3) ] := scanlineb[(counter*3)+2];\r
+ rearrangebuf[(counter*3)+1] := scanlineb[(counter*3)+1];\r
+ rearrangebuf[(counter*3)+2] := scanlineb[(counter*3) ];\r
+ end;\r
+ deflatestream.next_in := pointer(rearrangebuf);\r
+ deflatestream.avail_in := cols*3;\r
+ deflate(deflatestream,0);\r
+ if deflatestream.avail_in <> 0 then raise exception.create('compression problem');\r
+ freemem(rearrangebuf);\r
+\r
+ end;\r
+ ct8bp : begin\r
+ rearrangebuf := allocmem(divup(cols* colordepth, 8));\r
+ pixelsperbyte := 8 div colordepth;\r
+ for counter := 0 to cols-1 do begin\r
+ //shift sample value into most significant bits (which has the nice side effect of removing any garbage bits)\r
+ samplevalue := scanlineb[counter] shl (8-colordepth);\r
+ //shift sample value into correct place for pixel in question.\r
+ samplevalue := samplevalue shr ((counter mod pixelsperbyte)*colordepth);\r
+ rearrangebuf[counter div pixelsperbyte] := rearrangebuf[counter div pixelsperbyte] or samplevalue;\r
+ end;\r
+ deflatestream.next_in := pointer(rearrangebuf);\r
+ deflatestream.avail_in := divup(cols* colordepth, 8);\r
+ deflate(deflatestream,0);\r
+ if deflatestream.avail_in <> 0 then raise exception.create('compression problem');\r
+ freemem(rearrangebuf);\r
+ end;\r
+\r
+ else begin\r
+ deflatestream.next_in := scanline;\r
+\r
+ deflatestream.avail_in := divup(cols* colordepth, 8);\r
+\r
+ deflate(deflatestream,0);\r
+ while deflatestream.avail_out = 0 do begin\r
+ deflatestream.next_out := pbytef(taddrint(deflatestream.next_out) - taddrint(outputstr));\r
+ deflatestream.avail_out := length(outputstr);\r
+ setlength(outputstr,length(outputstr)*2);\r
+ deflatestream.next_out := pbytef(taddrint(deflatestream.next_out) + taddrint(outputstr));\r
+ deflate(deflatestream,0);\r
+ end;\r
+ if deflatestream.avail_in <> 0 then raise exception.create('compression problem');\r
+ end;\r
+ end;\r
+\r
+ setlength(outputstr,length(outputstr)-deflatestream.avail_out);\r
+ //deflate doesn't always produce output when its given input, if this is the case no point pushing it any further\r
+ if length(outputstr) > 0 then writetochunk(f,outputstr);\r
+// writeln;\r
+ end;\r
+end;\r
+\r
+procedure pngfinishdata(var f : tpngwrite);\r
+var\r
+ outputstr : string;\r
+ deflateresult : integer;\r
+begin\r
+ with f do begin\r
+ repeat\r
+ setlength(outputstr,512);\r
+ deflatestream.next_out := pbytef(outputstr);\r
+ deflatestream.avail_out := length(outputstr);\r
+ deflateresult := deflate(deflatestream,Z_FINISH);\r
+ setlength(outputstr,length(outputstr)-deflatestream.avail_out);\r
+ writetochunk(f,outputstr);\r
+\r
+ until deflateresult=Z_STREAM_END;\r
+ deflateEnd(deflatestream);\r
+ stopchunk(f);\r
+\r
+ end;\r
+end;\r
+\r
+\r
+procedure pngfinish(var f : tpngwrite);\r
+\r
+begin\r
+ with f do begin\r
+ //setlength(outputstr,512);\r
+ startchunk(f,'IEND');\r
+\r
+ stopchunk(f);\r
+ end;\r
+\r
+end;\r
+\r
+\r
+\r
+\r
+end.\r
--- /dev/null
+{unit to write tbitmaps to a png using plugwashes png code}\r
+\r
+unit pngwritetbitmap;\r
+\r
+interface\r
+uses\r
+ pngwrite,\r
+ sysutils,\r
+ classes,\r
+ {$ifdef win32}\r
+ windows,\r
+ {$endif}\r
+ {$ifndef fpc}\r
+\r
+ Graphics;\r
+\r
+ {$else}\r
+ pgtbitmap;\r
+ {$endif}\r
+ \r
+procedure savetbitmaptopng(image:tbitmap;destination : tstream);\r
+implementation\r
+procedure savetbitmaptopng(image:tbitmap;destination : tstream);\r
+var\r
+ paletteentrieswin : array[0..255] of TPaletteEntry;\r
+ paletteentriespng : array[0..768] of byte;\r
+ f:tpngwrite;\r
+ i : integer;\r
+ colortype : tcolortype;\r
+begin\r
+ if (image.PixelFormat <> pf8bit) and (image.pixelformat <> pf24bit) then raise exception.create('unsupported image format, only 8 bit and 24 bit per pixel are currently supported.');\r
+ if image.PixelFormat = pf24bit then begin\r
+ colortype := ctbgr;\r
+ end else begin\r
+ colortype := ctpallette;\r
+ end;\r
+ pngstart(f,destination,8,colortype,image.Height,image.Width);\r
+\r
+ if image.pixelformat = pf8bit then begin\r
+ GetPaletteEntries(image.Palette,0,256,paletteEntrieswin);\r
+\r
+ //writeln('about to start png write');\r
+ //writeln('about to prepare pallette');\r
+ for i := 0 to 255 do begin\r
+ paletteentriespng[(i*3) ] := paletteEntrieswin[i].pered;\r
+ paletteentriespng[(i*3)+1] := paletteEntrieswin[i].pegreen;\r
+ paletteentriespng[(i*3)+2] := paletteEntrieswin[i].peblue;\r
+ end;\r
+ //writeln('about to write pallette');\r
+ pngwritepal(f,@paletteentriespng,256 );\r
+ end;\r
+\r
+ pngstartdata(f);\r
+ {$O-}\r
+ for i := 0 to Image.Height -1 do begin;\r
+ //writeln('about to write scanline ',i,'image.height=',image.height,'image.ScanLine[i]',longint(image.ScanLine[i]));\r
+ pngwritescanline(f,image.ScanLine[i]);\r
+ end;\r
+ //writeln('about to close main data block');\r
+ pngfinishdata(f);\r
+ //writeln('about to close png');\r
+ pngfinish(f);\r
+\r
+end;\r
+end.\r
--- /dev/null
+_____________________________________________________________________________\r
+\r
+PASZLIB 1.0 May 11th, 1998\r
+\r
+Based on the zlib 1.1.2, a general purpose data compression library.\r
+\r
+Copyright (C) 1998,1999,2000 by NOMSSI NZALI Jacques H. C. \r
+[kn&n DES] See "Legal issues" for conditions of distribution and use.\r
+_____________________________________________________________________________\r
+\r
+\r
+Introduction\r
+============\r
+\r
+The 'zlib' compression library provides in-memory compression and\r
+decompression functions, including integrity checks of the uncompressed\r
+data. This version of the library supports only one compression method\r
+(deflation) but other algorithms will be added later and will have the same\r
+stream interface.\r
+\r
+Compression can be done in a single step if the buffers are large\r
+enough (for example if an input file is mmap'ed), or can be done by\r
+repeated calls of the compression function. In the latter case, the\r
+application must provide more input and/or consume the output\r
+(providing more output space) before each call.\r
+\r
+The default memory requirements for deflate are 256K plus a few kilobytes\r
+for small objects. The default memory requirements for inflate are 32K\r
+plus a few kilobytes for small objects.\r
+\r
+Change Log\r
+==========\r
+\r
+March 24th 2000 - minizip code by Gilles Vollant ported to Pascal. \r
+ z_stream.msg defined as string[255] to avoid problems\r
+ with Delphi 2+ dynamic string handling.\r
+ changes to silence Delphi 5 compiler warning. If you\r
+ have Delphi 5, defines Delphi5 in zconf.inc\r
+ \r
+May 7th 1999 - Some changes for FPC\r
+ deflateCopy() has new parameters\r
+ trees.pas - record constant definition\r
+June 17th 1998 - Applied official 1.1.2 patch. \r
+ Memcheck turned off by default.\r
+ zutil.pas patch for Delphi 1 memory allocation corrected.\r
+ dzlib.txt file added.\r
+ compress2() is now exported\r
+\r
+June 25th 1998 - fixed a conversion bug: in inftrees.pas, ZFREE(z, v) was\r
+ missing in line 574;\r
+\r
+File list\r
+=========\r
+\r
+Here is a road map to the files in the Paszlib distribution.\r
+\r
+readme.txt Introduction, Documentation\r
+dzlib.txt Changes to Delphi sources for Paszlib stream classes \r
+\r
+include file\r
+\r
+zconf.inc Configuration declarations.\r
+\r
+Pascal source code files:\r
+\r
+adler.pas compute the Adler-32 checksum of a data stream\r
+crc.pas compute the CRC-32 of a data stream\r
+gzio.pas IO on .gz files\r
+infblock.pas interpret and process block types to last block\r
+infcodes.pas process literals and length/distance pairs\r
+inffast.pas process literals and length/distance pairs fast\r
+inftrees.pas generate Huffman trees for efficient decoding\r
+infutil.pas types and macros common to blocks and codes\r
+strutils.pas string utilities\r
+trees.pas output deflated data using Huffman coding\r
+zcompres.pas compress a memory buffer\r
+zdeflate.pas compress data using the deflation algorithm\r
+zinflate.pas zlib interface to inflate modules\r
+zlib.pas zlib data structures. read the comments there!\r
+zuncompr.pas decompress a memory buffer\r
+zutil.pas\r
+\r
+minizip/ziputils.pas data structure and IO on .zip file \r
+minizip/unzip.pas \r
+minizip/zip.pas\r
+ \r
+Test applications\r
+\r
+example.pas usage example of the zlib compression library\r
+minigzip.pas simulate gzip using the zlib compression library\r
+minizip/miniunz.pas simulates unzip using the zlib compression library\r
+minizip/minizip.pas simulates zip using the zlib compression library\r
+\r
+Legal issues\r
+============\r
+\r
+Copyright (C) 1998,1999,2000 by Jacques Nomssi Nzali\r
+\r
+ This software is provided 'as-is', without any express or implied\r
+ warranty. In no event will the author be held liable for any damages\r
+ arising from the use of this software.\r
+\r
+ Permission is granted to anyone to use this software for any purpose,\r
+ including commercial applications, and to alter it and redistribute it\r
+ freely, subject to the following restrictions:\r
+\r
+ 1. The origin of this software must not be misrepresented; you must not\r
+ claim that you wrote the original software. If you use this software\r
+ in a product, an acknowledgment in the product documentation would be\r
+ appreciated but is not required.\r
+ 2. Altered source versions must be plainly marked as such, and must not be\r
+ misrepresented as being the original software.\r
+ 3. This notice may not be removed or altered from any source distribution.\r
+\r
+\r
+Archive Locations:\r
+==================\r
+\r
+Check the Paszlib home page with links\r
+\r
+ http://www.tu-chemnitz.de/~nomssi/paszlib.html\r
+\r
+The data format used by the zlib library is described by RFCs (Request for\r
+Comments) 1950 to 1952 in the files ftp://ds.internic.net/rfc/rfc1950.txt\r
+(zlib format), rfc1951.txt (deflate format) and rfc1952.txt (gzip format).\r
+These documents are also available in other formats from\r
+ftp://ftp.uu.net/graphics/png/documents/zlib/zdoc-index.html.\r
+____________________________________________________________________________\r
+Jacques Nomssi Nzali <mailto:nomssi@physik.tu-chemnitz.de> March 24th, 2000
\ No newline at end of file
--- /dev/null
+[Compiler]\r
+A=1\r
+B=0\r
+C=1\r
+D=1\r
+E=0\r
+F=0\r
+G=1\r
+H=1\r
+I=1\r
+J=1\r
+K=0\r
+L=1\r
+M=0\r
+N=1\r
+O=1\r
+P=1\r
+Q=0\r
+R=0\r
+S=0\r
+T=0\r
+U=0\r
+V=1\r
+W=0\r
+X=1\r
+Y=0\r
+Z=1\r
+ShowHints=1\r
+ShowWarnings=1\r
+UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;\r
+[Linker]\r
+MapFile=0\r
+OutputObjs=0\r
+ConsoleApp=1\r
+DebugInfo=0\r
+MinStackSize=16384\r
+MaxStackSize=1048576\r
+ImageBase=4194304\r
+ExeDescription=\r
+[Directories]\r
+OutputDir=\r
+UnitOutputDir=\r
+SearchPath=\r
+Packages=\r
+Conditionals=\r
+DebugSourceDirs=\r
+UsePackages=0\r
+[Parameters]\r
+RunParams=1\r
+HostApplication=\r
+[Version Info]\r
+IncludeVerInfo=0\r
+AutoIncBuild=0\r
+MajorVer=1\r
+MinorVer=0\r
+Release=0\r
+Build=0\r
+Debug=0\r
+PreRelease=0\r
+Special=0\r
+Private=0\r
+DLL=0\r
+Locale=2057\r
+CodePage=1252\r
+[Version Info Keys]\r
+CompanyName=\r
+FileDescription=\r
+FileVersion=1.0.0.0\r
+InternalName=\r
+LegalCopyright=\r
+LegalTrademarks=\r
+OriginalFilename=\r
+ProductName=\r
+ProductVersion=1.0.0.0\r
+Comments=\r
--- /dev/null
+initial import
+--This line, and those below, will be ignored--
+
+A .
--- /dev/null
+Unit trees;\r
+\r
+{$T-}\r
+{$define ORG_DEBUG}\r
+{\r
+ trees.c -- output deflated data using Huffman coding\r
+ Copyright (C) 1995-1998 Jean-loup Gailly\r
+\r
+ Pascal tranlastion\r
+ Copyright (C) 1998 by Jacques Nomssi Nzali\r
+ For conditions of distribution and use, see copyright notice in readme.paszlib\r
+}\r
+\r
+{\r
+ * ALGORITHM\r
+ *\r
+ * The "deflation" process uses several Huffman trees. The more\r
+ * common source values are represented by shorter bit sequences.\r
+ *\r
+ * Each code tree is stored in a compressed form which is itself\r
+ * a Huffman encoding of the lengths of all the code strings (in\r
+ * ascending order by source values). The actual code strings are\r
+ * reconstructed from the lengths in the inflate process, as described\r
+ * in the deflate specification.\r
+ *\r
+ * REFERENCES\r
+ *\r
+ * Deutsch, L.P.,"'Deflate' Compressed Data Format Specification".\r
+ * Available in ftp.uu.net:/pub/archiving/zip/doc/deflate-1.1.doc\r
+ *\r
+ * Storer, James A.\r
+ * Data Compression: Methods and Theory, pp. 49-50.\r
+ * Computer Science Press, 1988. ISBN 0-7167-8156-5.\r
+ *\r
+ * Sedgewick, R.\r
+ * Algorithms, p290.\r
+ * Addison-Wesley, 1983. ISBN 0-201-06672-6.\r
+ }\r
+\r
+interface\r
+\r
+{$I zconf.inc}\r
+\r
+uses\r
+ {$ifdef DEBUG}\r
+ strutils,\r
+ {$ENDIF}\r
+ zutil, zlib;\r
+\r
+{ ===========================================================================\r
+ Internal compression state. }\r
+\r
+const\r
+ LENGTH_CODES = 29;\r
+{ number of length codes, not counting the special END_BLOCK code }\r
+\r
+ LITERALS = 256;\r
+{ number of literal bytes 0..255 }\r
+\r
+ L_CODES = (LITERALS+1+LENGTH_CODES);\r
+{ number of Literal or Length codes, including the END_BLOCK code }\r
+\r
+ D_CODES = 30;\r
+{ number of distance codes }\r
+\r
+ BL_CODES = 19;\r
+{ number of codes used to transfer the bit lengths }\r
+\r
+ HEAP_SIZE = (2*L_CODES+1);\r
+{ maximum heap size }\r
+\r
+ MAX_BITS = 15;\r
+{ All codes must not exceed MAX_BITS bits }\r
+\r
+const\r
+ INIT_STATE = 42;\r
+ BUSY_STATE = 113;\r
+ FINISH_STATE = 666;\r
+{ Stream status }\r
+\r
+\r
+{ Data structure describing a single value and its code string. }\r
+type\r
+ ct_data_ptr = ^ct_data;\r
+ ct_data = record\r
+ fc : record\r
+ case byte of\r
+ 0:(freq : ush); { frequency count }\r
+ 1:(code : ush); { bit string }\r
+ end;\r
+ dl : record\r
+ case byte of\r
+ 0:(dad : ush); { father node in Huffman tree }\r
+ 1:(len : ush); { length of bit string }\r
+ end;\r
+ end;\r
+\r
+{ Freq = fc.freq\r
+ Code = fc.code\r
+ Dad = dl.dad\r
+ Len = dl.len }\r
+\r
+type\r
+ ltree_type = array[0..HEAP_SIZE-1] of ct_data; { literal and length tree }\r
+ dtree_type = array[0..2*D_CODES+1-1] of ct_data; { distance tree }\r
+ htree_type = array[0..2*BL_CODES+1-1] of ct_data; { Huffman tree for bit lengths }\r
+ { generic tree type }\r
+ tree_type = array[0..(MaxMemBlock div SizeOf(ct_data))-1] of ct_data;\r
+\r
+ tree_ptr = ^tree_type;\r
+ ltree_ptr = ^ltree_type;\r
+ dtree_ptr = ^dtree_type;\r
+ htree_ptr = ^htree_type;\r
+\r
+\r
+type\r
+ static_tree_desc_ptr = ^static_tree_desc;\r
+ static_tree_desc =\r
+ record\r
+ {const} static_tree : tree_ptr; { static tree or NIL }\r
+ {const} extra_bits : pzIntfArray; { extra bits for each code or NIL }\r
+ extra_base : int; { base index for extra_bits }\r
+ elems : int; { max number of elements in the tree }\r
+ max_length : int; { max bit length for the codes }\r
+ end;\r
+\r
+ tree_desc_ptr = ^tree_desc;\r
+ tree_desc = record\r
+ dyn_tree : tree_ptr; { the dynamic tree }\r
+ max_code : int; { largest code with non zero frequency }\r
+ stat_desc : static_tree_desc_ptr; { the corresponding static tree }\r
+ end;\r
+\r
+type\r
+ Pos = ush;\r
+ Posf = Pos; {FAR}\r
+ IPos = uInt;\r
+\r
+ pPosf = ^Posf;\r
+\r
+ zPosfArray = array[0..(MaxMemBlock div SizeOf(Posf))-1] of Posf;\r
+ pzPosfArray = ^zPosfArray;\r
+\r
+{ A Pos is an index in the character window. We use short instead of int to\r
+ save space in the various tables. IPos is used only for parameter passing.}\r
+\r
+type\r
+ deflate_state_ptr = ^deflate_state;\r
+ deflate_state = record\r
+ strm : z_streamp; { pointer back to this zlib stream }\r
+ status : int; { as the name implies }\r
+ pending_buf : pzByteArray; { output still pending }\r
+ pending_buf_size : ulg; { size of pending_buf }\r
+ pending_out : pBytef; { next pending byte to output to the stream }\r
+ pending : int; { nb of bytes in the pending buffer }\r
+ noheader : int; { suppress zlib header and adler32 }\r
+ data_type : Byte; { UNKNOWN, BINARY or ASCII }\r
+ method : Byte; { STORED (for zip only) or DEFLATED }\r
+ last_flush : int; { value of flush param for previous deflate call }\r
+\r
+ { used by deflate.pas: }\r
+\r
+ w_size : uInt; { LZ77 window size (32K by default) }\r
+ w_bits : uInt; { log2(w_size) (8..16) }\r
+ w_mask : uInt; { w_size - 1 }\r
+\r
+ window : pzByteArray;\r
+ { Sliding window. Input bytes are read into the second half of the window,\r
+ and move to the first half later to keep a dictionary of at least wSize\r
+ bytes. With this organization, matches are limited to a distance of\r
+ wSize-MAX_MATCH bytes, but this ensures that IO is always\r
+ performed with a length multiple of the block size. Also, it limits\r
+ the window size to 64K, which is quite useful on MSDOS.\r
+ To do: use the user input buffer as sliding window. }\r
+\r
+ window_size : ulg;\r
+ { Actual size of window: 2*wSize, except when the user input buffer\r
+ is directly used as sliding window. }\r
+\r
+ prev : pzPosfArray;\r
+ { Link to older string with same hash index. To limit the size of this\r
+ array to 64K, this link is maintained only for the last 32K strings.\r
+ An index in this array is thus a window index modulo 32K. }\r
+\r
+ head : pzPosfArray; { Heads of the hash chains or NIL. }\r
+\r
+ ins_h : uInt; { hash index of string to be inserted }\r
+ hash_size : uInt; { number of elements in hash table }\r
+ hash_bits : uInt; { log2(hash_size) }\r
+ hash_mask : uInt; { hash_size-1 }\r
+\r
+ hash_shift : uInt;\r
+ { Number of bits by which ins_h must be shifted at each input\r
+ step. It must be such that after MIN_MATCH steps, the oldest\r
+ byte no longer takes part in the hash key, that is:\r
+ hash_shift * MIN_MATCH >= hash_bits }\r
+\r
+ block_start : long;\r
+ { Window position at the beginning of the current output block. Gets\r
+ negative when the window is moved backwards. }\r
+\r
+ match_length : uInt; { length of best match }\r
+ prev_match : IPos; { previous match }\r
+ match_available : boolean; { set if previous match exists }\r
+ strstart : uInt; { start of string to insert }\r
+ match_start : uInt; { start of matching string }\r
+ lookahead : uInt; { number of valid bytes ahead in window }\r
+\r
+ prev_length : uInt;\r
+ { Length of the best match at previous step. Matches not greater than this\r
+ are discarded. This is used in the lazy match evaluation. }\r
+\r
+ max_chain_length : uInt;\r
+ { To speed up deflation, hash chains are never searched beyond this\r
+ length. A higher limit improves compression ratio but degrades the\r
+ speed. }\r
+\r
+ { moved to the end because Borland Pascal won't accept the following:\r
+ max_lazy_match : uInt;\r
+ max_insert_length : uInt absolute max_lazy_match;\r
+ }\r
+\r
+ level : int; { compression level (1..9) }\r
+ strategy : int; { favor or force Huffman coding}\r
+\r
+ good_match : uInt;\r
+ { Use a faster search when the previous match is longer than this }\r
+\r
+ nice_match : int; { Stop searching when current match exceeds this }\r
+\r
+ { used by trees.pas: }\r
+ { Didn't use ct_data typedef below to supress compiler warning }\r
+ dyn_ltree : ltree_type; { literal and length tree }\r
+ dyn_dtree : dtree_type; { distance tree }\r
+ bl_tree : htree_type; { Huffman tree for bit lengths }\r
+\r
+ l_desc : tree_desc; { desc. for literal tree }\r
+ d_desc : tree_desc; { desc. for distance tree }\r
+ bl_desc : tree_desc; { desc. for bit length tree }\r
+\r
+ bl_count : array[0..MAX_BITS+1-1] of ush;\r
+ { number of codes at each bit length for an optimal tree }\r
+\r
+ heap : array[0..2*L_CODES+1-1] of int; { heap used to build the Huffman trees }\r
+ heap_len : int; { number of elements in the heap }\r
+ heap_max : int; { element of largest frequency }\r
+ { The sons of heap[n] are heap[2*n] and heap[2*n+1]. heap[0] is not used.\r
+ The same heap array is used to build all trees. }\r
+\r
+ depth : array[0..2*L_CODES+1-1] of uch;\r
+ { Depth of each subtree used as tie breaker for trees of equal frequency }\r
+\r
+\r
+ l_buf : puchfArray; { buffer for literals or lengths }\r
+\r
+ lit_bufsize : uInt;\r
+ { Size of match buffer for literals/lengths. There are 4 reasons for\r
+ limiting lit_bufsize to 64K:\r
+ - frequencies can be kept in 16 bit counters\r
+ - if compression is not successful for the first block, all input\r
+ data is still in the window so we can still emit a stored block even\r
+ when input comes from standard input. (This can also be done for\r
+ all blocks if lit_bufsize is not greater than 32K.)\r
+ - if compression is not successful for a file smaller than 64K, we can\r
+ even emit a stored file instead of a stored block (saving 5 bytes).\r
+ This is applicable only for zip (not gzip or zlib).\r
+ - creating new Huffman trees less frequently may not provide fast\r
+ adaptation to changes in the input data statistics. (Take for\r
+ example a binary file with poorly compressible code followed by\r
+ a highly compressible string table.) Smaller buffer sizes give\r
+ fast adaptation but have of course the overhead of transmitting\r
+ trees more frequently.\r
+ - I can't count above 4 }\r
+\r
+\r
+ last_lit : uInt; { running index in l_buf }\r
+\r
+ d_buf : pushfArray;\r
+ { Buffer for distances. To simplify the code, d_buf and l_buf have\r
+ the same number of elements. To use different lengths, an extra flag\r
+ array would be necessary. }\r
+\r
+ opt_len : ulg; { bit length of current block with optimal trees }\r
+ static_len : ulg; { bit length of current block with static trees }\r
+ compressed_len : ulg; { total bit length of compressed file }\r
+ matches : uInt; { number of string matches in current block }\r
+ last_eob_len : int; { bit length of EOB code for last block }\r
+\r
+{$ifdef DEBUG}\r
+ bits_sent : ulg; { bit length of the compressed data }\r
+{$endif}\r
+\r
+ bi_buf : ush;\r
+ { Output buffer. bits are inserted starting at the bottom (least\r
+ significant bits). }\r
+\r
+ bi_valid : int;\r
+ { Number of valid bits in bi_buf. All bits above the last valid bit\r
+ are always zero. }\r
+\r
+ case byte of\r
+ 0:(max_lazy_match : uInt);\r
+ { Attempt to find a better match only when the current match is strictly\r
+ smaller than this value. This mechanism is used only for compression\r
+ levels >= 4. }\r
+\r
+ 1:(max_insert_length : uInt);\r
+ { Insert new strings in the hash table only if the match length is not\r
+ greater than this length. This saves time but degrades compression.\r
+ max_insert_length is used only for compression levels <= 3. }\r
+ end;\r
+\r
+procedure _tr_init (var s : deflate_state);\r
+\r
+function _tr_tally (var s : deflate_state;\r
+ dist : unsigned;\r
+ lc : unsigned) : boolean;\r
+\r
+function _tr_flush_block (var s : deflate_state;\r
+ buf : pcharf;\r
+ stored_len : ulg;\r
+ eof : boolean) : ulg;\r
+\r
+procedure _tr_align(var s : deflate_state);\r
+\r
+procedure _tr_stored_block(var s : deflate_state;\r
+ buf : pcharf;\r
+ stored_len : ulg;\r
+ eof : boolean);\r
+\r
+implementation\r
+\r
+{ #define GEN_TREES_H }\r
+\r
+{$ifndef GEN_TREES_H}\r
+{ header created automatically with -DGEN_TREES_H }\r
+\r
+const\r
+ DIST_CODE_LEN = 512; { see definition of array dist_code below }\r
+\r
+{ The static literal tree. Since the bit lengths are imposed, there is no\r
+ need for the L_CODES extra codes used during heap construction. However\r
+ The codes 286 and 287 are needed to build a canonical tree (see _tr_init\r
+ below). }\r
+const\r
+ static_ltree : array[0..L_CODES+2-1] of ct_data = (\r
+{ fc:(freq, code) dl:(dad,len) }\r
+(fc:(freq: 12);dl:(len: 8)), (fc:(freq:140);dl:(len: 8)), (fc:(freq: 76);dl:(len: 8)),\r
+(fc:(freq:204);dl:(len: 8)), (fc:(freq: 44);dl:(len: 8)), (fc:(freq:172);dl:(len: 8)),\r
+(fc:(freq:108);dl:(len: 8)), (fc:(freq:236);dl:(len: 8)), (fc:(freq: 28);dl:(len: 8)),\r
+(fc:(freq:156);dl:(len: 8)), (fc:(freq: 92);dl:(len: 8)), (fc:(freq:220);dl:(len: 8)),\r
+(fc:(freq: 60);dl:(len: 8)), (fc:(freq:188);dl:(len: 8)), (fc:(freq:124);dl:(len: 8)),\r
+(fc:(freq:252);dl:(len: 8)), (fc:(freq: 2);dl:(len: 8)), (fc:(freq:130);dl:(len: 8)),\r
+(fc:(freq: 66);dl:(len: 8)), (fc:(freq:194);dl:(len: 8)), (fc:(freq: 34);dl:(len: 8)),\r
+(fc:(freq:162);dl:(len: 8)), (fc:(freq: 98);dl:(len: 8)), (fc:(freq:226);dl:(len: 8)),\r
+(fc:(freq: 18);dl:(len: 8)), (fc:(freq:146);dl:(len: 8)), (fc:(freq: 82);dl:(len: 8)),\r
+(fc:(freq:210);dl:(len: 8)), (fc:(freq: 50);dl:(len: 8)), (fc:(freq:178);dl:(len: 8)),\r
+(fc:(freq:114);dl:(len: 8)), (fc:(freq:242);dl:(len: 8)), (fc:(freq: 10);dl:(len: 8)),\r
+(fc:(freq:138);dl:(len: 8)), (fc:(freq: 74);dl:(len: 8)), (fc:(freq:202);dl:(len: 8)),\r
+(fc:(freq: 42);dl:(len: 8)), (fc:(freq:170);dl:(len: 8)), (fc:(freq:106);dl:(len: 8)),\r
+(fc:(freq:234);dl:(len: 8)), (fc:(freq: 26);dl:(len: 8)), (fc:(freq:154);dl:(len: 8)),\r
+(fc:(freq: 90);dl:(len: 8)), (fc:(freq:218);dl:(len: 8)), (fc:(freq: 58);dl:(len: 8)),\r
+(fc:(freq:186);dl:(len: 8)), (fc:(freq:122);dl:(len: 8)), (fc:(freq:250);dl:(len: 8)),\r
+(fc:(freq: 6);dl:(len: 8)), (fc:(freq:134);dl:(len: 8)), (fc:(freq: 70);dl:(len: 8)),\r
+(fc:(freq:198);dl:(len: 8)), (fc:(freq: 38);dl:(len: 8)), (fc:(freq:166);dl:(len: 8)),\r
+(fc:(freq:102);dl:(len: 8)), (fc:(freq:230);dl:(len: 8)), (fc:(freq: 22);dl:(len: 8)),\r
+(fc:(freq:150);dl:(len: 8)), (fc:(freq: 86);dl:(len: 8)), (fc:(freq:214);dl:(len: 8)),\r
+(fc:(freq: 54);dl:(len: 8)), (fc:(freq:182);dl:(len: 8)), (fc:(freq:118);dl:(len: 8)),\r
+(fc:(freq:246);dl:(len: 8)), (fc:(freq: 14);dl:(len: 8)), (fc:(freq:142);dl:(len: 8)),\r
+(fc:(freq: 78);dl:(len: 8)), (fc:(freq:206);dl:(len: 8)), (fc:(freq: 46);dl:(len: 8)),\r
+(fc:(freq:174);dl:(len: 8)), (fc:(freq:110);dl:(len: 8)), (fc:(freq:238);dl:(len: 8)),\r
+(fc:(freq: 30);dl:(len: 8)), (fc:(freq:158);dl:(len: 8)), (fc:(freq: 94);dl:(len: 8)),\r
+(fc:(freq:222);dl:(len: 8)), (fc:(freq: 62);dl:(len: 8)), (fc:(freq:190);dl:(len: 8)),\r
+(fc:(freq:126);dl:(len: 8)), (fc:(freq:254);dl:(len: 8)), (fc:(freq: 1);dl:(len: 8)),\r
+(fc:(freq:129);dl:(len: 8)), (fc:(freq: 65);dl:(len: 8)), (fc:(freq:193);dl:(len: 8)),\r
+(fc:(freq: 33);dl:(len: 8)), (fc:(freq:161);dl:(len: 8)), (fc:(freq: 97);dl:(len: 8)),\r
+(fc:(freq:225);dl:(len: 8)), (fc:(freq: 17);dl:(len: 8)), (fc:(freq:145);dl:(len: 8)),\r
+(fc:(freq: 81);dl:(len: 8)), (fc:(freq:209);dl:(len: 8)), (fc:(freq: 49);dl:(len: 8)),\r
+(fc:(freq:177);dl:(len: 8)), (fc:(freq:113);dl:(len: 8)), (fc:(freq:241);dl:(len: 8)),\r
+(fc:(freq: 9);dl:(len: 8)), (fc:(freq:137);dl:(len: 8)), (fc:(freq: 73);dl:(len: 8)),\r
+(fc:(freq:201);dl:(len: 8)), (fc:(freq: 41);dl:(len: 8)), (fc:(freq:169);dl:(len: 8)),\r
+(fc:(freq:105);dl:(len: 8)), (fc:(freq:233);dl:(len: 8)), (fc:(freq: 25);dl:(len: 8)),\r
+(fc:(freq:153);dl:(len: 8)), (fc:(freq: 89);dl:(len: 8)), (fc:(freq:217);dl:(len: 8)),\r
+(fc:(freq: 57);dl:(len: 8)), (fc:(freq:185);dl:(len: 8)), (fc:(freq:121);dl:(len: 8)),\r
+(fc:(freq:249);dl:(len: 8)), (fc:(freq: 5);dl:(len: 8)), (fc:(freq:133);dl:(len: 8)),\r
+(fc:(freq: 69);dl:(len: 8)), (fc:(freq:197);dl:(len: 8)), (fc:(freq: 37);dl:(len: 8)),\r
+(fc:(freq:165);dl:(len: 8)), (fc:(freq:101);dl:(len: 8)), (fc:(freq:229);dl:(len: 8)),\r
+(fc:(freq: 21);dl:(len: 8)), (fc:(freq:149);dl:(len: 8)), (fc:(freq: 85);dl:(len: 8)),\r
+(fc:(freq:213);dl:(len: 8)), (fc:(freq: 53);dl:(len: 8)), (fc:(freq:181);dl:(len: 8)),\r
+(fc:(freq:117);dl:(len: 8)), (fc:(freq:245);dl:(len: 8)), (fc:(freq: 13);dl:(len: 8)),\r
+(fc:(freq:141);dl:(len: 8)), (fc:(freq: 77);dl:(len: 8)), (fc:(freq:205);dl:(len: 8)),\r
+(fc:(freq: 45);dl:(len: 8)), (fc:(freq:173);dl:(len: 8)), (fc:(freq:109);dl:(len: 8)),\r
+(fc:(freq:237);dl:(len: 8)), (fc:(freq: 29);dl:(len: 8)), (fc:(freq:157);dl:(len: 8)),\r
+(fc:(freq: 93);dl:(len: 8)), (fc:(freq:221);dl:(len: 8)), (fc:(freq: 61);dl:(len: 8)),\r
+(fc:(freq:189);dl:(len: 8)), (fc:(freq:125);dl:(len: 8)), (fc:(freq:253);dl:(len: 8)),\r
+(fc:(freq: 19);dl:(len: 9)), (fc:(freq:275);dl:(len: 9)), (fc:(freq:147);dl:(len: 9)),\r
+(fc:(freq:403);dl:(len: 9)), (fc:(freq: 83);dl:(len: 9)), (fc:(freq:339);dl:(len: 9)),\r
+(fc:(freq:211);dl:(len: 9)), (fc:(freq:467);dl:(len: 9)), (fc:(freq: 51);dl:(len: 9)),\r
+(fc:(freq:307);dl:(len: 9)), (fc:(freq:179);dl:(len: 9)), (fc:(freq:435);dl:(len: 9)),\r
+(fc:(freq:115);dl:(len: 9)), (fc:(freq:371);dl:(len: 9)), (fc:(freq:243);dl:(len: 9)),\r
+(fc:(freq:499);dl:(len: 9)), (fc:(freq: 11);dl:(len: 9)), (fc:(freq:267);dl:(len: 9)),\r
+(fc:(freq:139);dl:(len: 9)), (fc:(freq:395);dl:(len: 9)), (fc:(freq: 75);dl:(len: 9)),\r
+(fc:(freq:331);dl:(len: 9)), (fc:(freq:203);dl:(len: 9)), (fc:(freq:459);dl:(len: 9)),\r
+(fc:(freq: 43);dl:(len: 9)), (fc:(freq:299);dl:(len: 9)), (fc:(freq:171);dl:(len: 9)),\r
+(fc:(freq:427);dl:(len: 9)), (fc:(freq:107);dl:(len: 9)), (fc:(freq:363);dl:(len: 9)),\r
+(fc:(freq:235);dl:(len: 9)), (fc:(freq:491);dl:(len: 9)), (fc:(freq: 27);dl:(len: 9)),\r
+(fc:(freq:283);dl:(len: 9)), (fc:(freq:155);dl:(len: 9)), (fc:(freq:411);dl:(len: 9)),\r
+(fc:(freq: 91);dl:(len: 9)), (fc:(freq:347);dl:(len: 9)), (fc:(freq:219);dl:(len: 9)),\r
+(fc:(freq:475);dl:(len: 9)), (fc:(freq: 59);dl:(len: 9)), (fc:(freq:315);dl:(len: 9)),\r
+(fc:(freq:187);dl:(len: 9)), (fc:(freq:443);dl:(len: 9)), (fc:(freq:123);dl:(len: 9)),\r
+(fc:(freq:379);dl:(len: 9)), (fc:(freq:251);dl:(len: 9)), (fc:(freq:507);dl:(len: 9)),\r
+(fc:(freq: 7);dl:(len: 9)), (fc:(freq:263);dl:(len: 9)), (fc:(freq:135);dl:(len: 9)),\r
+(fc:(freq:391);dl:(len: 9)), (fc:(freq: 71);dl:(len: 9)), (fc:(freq:327);dl:(len: 9)),\r
+(fc:(freq:199);dl:(len: 9)), (fc:(freq:455);dl:(len: 9)), (fc:(freq: 39);dl:(len: 9)),\r
+(fc:(freq:295);dl:(len: 9)), (fc:(freq:167);dl:(len: 9)), (fc:(freq:423);dl:(len: 9)),\r
+(fc:(freq:103);dl:(len: 9)), (fc:(freq:359);dl:(len: 9)), (fc:(freq:231);dl:(len: 9)),\r
+(fc:(freq:487);dl:(len: 9)), (fc:(freq: 23);dl:(len: 9)), (fc:(freq:279);dl:(len: 9)),\r
+(fc:(freq:151);dl:(len: 9)), (fc:(freq:407);dl:(len: 9)), (fc:(freq: 87);dl:(len: 9)),\r
+(fc:(freq:343);dl:(len: 9)), (fc:(freq:215);dl:(len: 9)), (fc:(freq:471);dl:(len: 9)),\r
+(fc:(freq: 55);dl:(len: 9)), (fc:(freq:311);dl:(len: 9)), (fc:(freq:183);dl:(len: 9)),\r
+(fc:(freq:439);dl:(len: 9)), (fc:(freq:119);dl:(len: 9)), (fc:(freq:375);dl:(len: 9)),\r
+(fc:(freq:247);dl:(len: 9)), (fc:(freq:503);dl:(len: 9)), (fc:(freq: 15);dl:(len: 9)),\r
+(fc:(freq:271);dl:(len: 9)), (fc:(freq:143);dl:(len: 9)), (fc:(freq:399);dl:(len: 9)),\r
+(fc:(freq: 79);dl:(len: 9)), (fc:(freq:335);dl:(len: 9)), (fc:(freq:207);dl:(len: 9)),\r
+(fc:(freq:463);dl:(len: 9)), (fc:(freq: 47);dl:(len: 9)), (fc:(freq:303);dl:(len: 9)),\r
+(fc:(freq:175);dl:(len: 9)), (fc:(freq:431);dl:(len: 9)), (fc:(freq:111);dl:(len: 9)),\r
+(fc:(freq:367);dl:(len: 9)), (fc:(freq:239);dl:(len: 9)), (fc:(freq:495);dl:(len: 9)),\r
+(fc:(freq: 31);dl:(len: 9)), (fc:(freq:287);dl:(len: 9)), (fc:(freq:159);dl:(len: 9)),\r
+(fc:(freq:415);dl:(len: 9)), (fc:(freq: 95);dl:(len: 9)), (fc:(freq:351);dl:(len: 9)),\r
+(fc:(freq:223);dl:(len: 9)), (fc:(freq:479);dl:(len: 9)), (fc:(freq: 63);dl:(len: 9)),\r
+(fc:(freq:319);dl:(len: 9)), (fc:(freq:191);dl:(len: 9)), (fc:(freq:447);dl:(len: 9)),\r
+(fc:(freq:127);dl:(len: 9)), (fc:(freq:383);dl:(len: 9)), (fc:(freq:255);dl:(len: 9)),\r
+(fc:(freq:511);dl:(len: 9)), (fc:(freq: 0);dl:(len: 7)), (fc:(freq: 64);dl:(len: 7)),\r
+(fc:(freq: 32);dl:(len: 7)), (fc:(freq: 96);dl:(len: 7)), (fc:(freq: 16);dl:(len: 7)),\r
+(fc:(freq: 80);dl:(len: 7)), (fc:(freq: 48);dl:(len: 7)), (fc:(freq:112);dl:(len: 7)),\r
+(fc:(freq: 8);dl:(len: 7)), (fc:(freq: 72);dl:(len: 7)), (fc:(freq: 40);dl:(len: 7)),\r
+(fc:(freq:104);dl:(len: 7)), (fc:(freq: 24);dl:(len: 7)), (fc:(freq: 88);dl:(len: 7)),\r
+(fc:(freq: 56);dl:(len: 7)), (fc:(freq:120);dl:(len: 7)), (fc:(freq: 4);dl:(len: 7)),\r
+(fc:(freq: 68);dl:(len: 7)), (fc:(freq: 36);dl:(len: 7)), (fc:(freq:100);dl:(len: 7)),\r
+(fc:(freq: 20);dl:(len: 7)), (fc:(freq: 84);dl:(len: 7)), (fc:(freq: 52);dl:(len: 7)),\r
+(fc:(freq:116);dl:(len: 7)), (fc:(freq: 3);dl:(len: 8)), (fc:(freq:131);dl:(len: 8)),\r
+(fc:(freq: 67);dl:(len: 8)), (fc:(freq:195);dl:(len: 8)), (fc:(freq: 35);dl:(len: 8)),\r
+(fc:(freq:163);dl:(len: 8)), (fc:(freq: 99);dl:(len: 8)), (fc:(freq:227);dl:(len: 8))\r
+);\r
+\r
+\r
+{ The static distance tree. (Actually a trivial tree since all lens use\r
+ 5 bits.) }\r
+ static_dtree : array[0..D_CODES-1] of ct_data = (\r
+(fc:(freq: 0); dl:(len:5)), (fc:(freq:16); dl:(len:5)), (fc:(freq: 8); dl:(len:5)),\r
+(fc:(freq:24); dl:(len:5)), (fc:(freq: 4); dl:(len:5)), (fc:(freq:20); dl:(len:5)),\r
+(fc:(freq:12); dl:(len:5)), (fc:(freq:28); dl:(len:5)), (fc:(freq: 2); dl:(len:5)),\r
+(fc:(freq:18); dl:(len:5)), (fc:(freq:10); dl:(len:5)), (fc:(freq:26); dl:(len:5)),\r
+(fc:(freq: 6); dl:(len:5)), (fc:(freq:22); dl:(len:5)), (fc:(freq:14); dl:(len:5)),\r
+(fc:(freq:30); dl:(len:5)), (fc:(freq: 1); dl:(len:5)), (fc:(freq:17); dl:(len:5)),\r
+(fc:(freq: 9); dl:(len:5)), (fc:(freq:25); dl:(len:5)), (fc:(freq: 5); dl:(len:5)),\r
+(fc:(freq:21); dl:(len:5)), (fc:(freq:13); dl:(len:5)), (fc:(freq:29); dl:(len:5)),\r
+(fc:(freq: 3); dl:(len:5)), (fc:(freq:19); dl:(len:5)), (fc:(freq:11); dl:(len:5)),\r
+(fc:(freq:27); dl:(len:5)), (fc:(freq: 7); dl:(len:5)), (fc:(freq:23); dl:(len:5))\r
+);\r
+\r
+{ Distance codes. The first 256 values correspond to the distances\r
+ 3 .. 258, the last 256 values correspond to the top 8 bits of\r
+ the 15 bit distances. }\r
+ _dist_code : array[0..DIST_CODE_LEN-1] of uch = (\r
+ 0, 1, 2, 3, 4, 4, 5, 5, 6, 6, 6, 6, 7, 7, 7, 7, 8, 8, 8, 8,\r
+ 8, 8, 8, 8, 9, 9, 9, 9, 9, 9, 9, 9, 10, 10, 10, 10, 10, 10, 10, 10,\r
+10, 10, 10, 10, 10, 10, 10, 10, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11,\r
+11, 11, 11, 11, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12,\r
+12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 13, 13, 13, 13,\r
+13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,\r
+13, 13, 13, 13, 13, 13, 13, 13, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,\r
+14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,\r
+14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,\r
+14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15,\r
+15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,\r
+15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,\r
+15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 16, 17,\r
+18, 18, 19, 19, 20, 20, 20, 20, 21, 21, 21, 21, 22, 22, 22, 22, 22, 22, 22, 22,\r
+23, 23, 23, 23, 23, 23, 23, 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,\r
+24, 24, 24, 24, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,\r
+26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26,\r
+26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 27, 27,\r
+27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27,\r
+27, 27, 27, 27, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,\r
+28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,\r
+28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,\r
+28, 28, 28, 28, 28, 28, 28, 28, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29,\r
+29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29,\r
+29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29,\r
+29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29\r
+);\r
+\r
+{ length code for each normalized match length (0 == MIN_MATCH) }\r
+ _length_code : array[0..MAX_MATCH-MIN_MATCH+1-1] of uch = (\r
+ 0, 1, 2, 3, 4, 5, 6, 7, 8, 8, 9, 9, 10, 10, 11, 11, 12, 12, 12, 12,\r
+13, 13, 13, 13, 14, 14, 14, 14, 15, 15, 15, 15, 16, 16, 16, 16, 16, 16, 16, 16,\r
+17, 17, 17, 17, 17, 17, 17, 17, 18, 18, 18, 18, 18, 18, 18, 18, 19, 19, 19, 19,\r
+19, 19, 19, 19, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,\r
+21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 22, 22, 22, 22,\r
+22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 23, 23, 23, 23, 23, 23, 23, 23,\r
+23, 23, 23, 23, 23, 23, 23, 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,\r
+24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,\r
+25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,\r
+25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 26, 26, 26, 26, 26, 26, 26, 26,\r
+26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26,\r
+26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27,\r
+27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 28\r
+);\r
+\r
+ \r
+{ First normalized length for each code (0 = MIN_MATCH) }\r
+ base_length : array[0..LENGTH_CODES-1] of int = (\r
+0, 1, 2, 3, 4, 5, 6, 7, 8, 10, 12, 14, 16, 20, 24, 28, 32, 40, 48, 56,\r
+64, 80, 96, 112, 128, 160, 192, 224, 0\r
+);\r
+\r
+\r
+{ First normalized distance for each code (0 = distance of 1) }\r
+ base_dist : array[0..D_CODES-1] of int = (\r
+ 0, 1, 2, 3, 4, 6, 8, 12, 16, 24,\r
+ 32, 48, 64, 96, 128, 192, 256, 384, 512, 768,\r
+ 1024, 1536, 2048, 3072, 4096, 6144, 8192, 12288, 16384, 24576\r
+);\r
+{$endif}\r
+\r
+{ Output a byte on the stream.\r
+ IN assertion: there is enough room in pending_buf.\r
+macro put_byte(s, c)\r
+begin\r
+ s^.pending_buf^[s^.pending] := (c);\r
+ Inc(s^.pending);\r
+end\r
+}\r
+\r
+const\r
+ MIN_LOOKAHEAD = (MAX_MATCH+MIN_MATCH+1);\r
+{ Minimum amount of lookahead, except at the end of the input file.\r
+ See deflate.c for comments about the MIN_MATCH+1. }\r
+\r
+{macro d_code(dist)\r
+ if (dist) < 256 then\r
+ := _dist_code[dist]\r
+ else\r
+ := _dist_code[256+((dist) shr 7)]);\r
+ Mapping from a distance to a distance code. dist is the distance - 1 and\r
+ must not have side effects. _dist_code[256] and _dist_code[257] are never\r
+ used. }\r
+\r
+{$ifndef ORG_DEBUG}\r
+{ Inline versions of _tr_tally for speed: }\r
+\r
+#if defined(GEN_TREES_H) || !defined(STDC)\r
+ extern uch _length_code[];\r
+ extern uch _dist_code[];\r
+#else\r
+ extern const uch _length_code[];\r
+ extern const uch _dist_code[];\r
+#endif\r
+\r
+macro _tr_tally_lit(s, c, flush)\r
+var\r
+ cc : uch;\r
+begin\r
+ cc := (c);\r
+ s^.d_buf[s^.last_lit] := 0;\r
+ s^.l_buf[s^.last_lit] := cc;\r
+ Inc(s^.last_lit);\r
+ Inc(s^.dyn_ltree[cc].fc.Freq);\r
+ flush := (s^.last_lit = s^.lit_bufsize-1);\r
+end;\r
+\r
+macro _tr_tally_dist(s, distance, length, flush) \\r
+var\r
+ len : uch;\r
+ dist : ush;\r
+begin\r
+ len := (length);\r
+ dist := (distance);\r
+ s^.d_buf[s^.last_lit] := dist;\r
+ s^.l_buf[s^.last_lit] = len;\r
+ Inc(s^.last_lit);\r
+ Dec(dist);\r
+ Inc(s^.dyn_ltree[_length_code[len]+LITERALS+1].fc.Freq);\r
+ Inc(s^.dyn_dtree[d_code(dist)].Freq);\r
+ flush := (s^.last_lit = s^.lit_bufsize-1);\r
+end;\r
+\r
+{$endif}\r
+\r
+{ ===========================================================================\r
+ Constants }\r
+\r
+const\r
+ MAX_BL_BITS = 7;\r
+{ Bit length codes must not exceed MAX_BL_BITS bits }\r
+\r
+const\r
+ END_BLOCK = 256;\r
+{ end of block literal code }\r
+\r
+const\r
+ REP_3_6 = 16;\r
+{ repeat previous bit length 3-6 times (2 bits of repeat count) }\r
+\r
+const\r
+ REPZ_3_10 = 17;\r
+{ repeat a zero length 3-10 times (3 bits of repeat count) }\r
+\r
+const\r
+ REPZ_11_138 = 18;\r
+{ repeat a zero length 11-138 times (7 bits of repeat count) }\r
+\r
+{local}\r
+const\r
+ extra_lbits : array[0..LENGTH_CODES-1] of int\r
+ { extra bits for each length code }\r
+ = (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);\r
+\r
+{local}\r
+const\r
+ extra_dbits : array[0..D_CODES-1] of int\r
+ { extra bits for each distance code }\r
+ = (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);\r
+\r
+{local}\r
+const\r
+ extra_blbits : array[0..BL_CODES-1] of int { extra bits for each bit length code }\r
+ = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,2,3,7);\r
+\r
+{local}\r
+const\r
+ bl_order : array[0..BL_CODES-1] of uch\r
+ = (16,17,18,0,8,7,9,6,10,5,11,4,12,3,13,2,14,1,15);\r
+{ The lengths of the bit length codes are sent in order of decreasing\r
+ probability, to avoid transmitting the lengths for unused bit length codes.\r
+ }\r
+\r
+const\r
+ Buf_size = (8 * 2*sizeof(char));\r
+{ Number of bits used within bi_buf. (bi_buf might be implemented on\r
+ more than 16 bits on some systems.) }\r
+\r
+{ ===========================================================================\r
+ Local data. These are initialized only once. }\r
+\r
+\r
+{$ifdef GEN_TREES_H)}\r
+{ non ANSI compilers may not accept trees.h }\r
+\r
+const\r
+ DIST_CODE_LEN = 512; { see definition of array dist_code below }\r
+\r
+{local}\r
+var\r
+ static_ltree : array[0..L_CODES+2-1] of ct_data;\r
+{ The static literal tree. Since the bit lengths are imposed, there is no\r
+ need for the L_CODES extra codes used during heap construction. However\r
+ The codes 286 and 287 are needed to build a canonical tree (see _tr_init\r
+ below). }\r
+\r
+{local}\r
+ static_dtree : array[0..D_CODES-1] of ct_data;\r
+{ The static distance tree. (Actually a trivial tree since all codes use\r
+ 5 bits.) }\r
+\r
+ _dist_code : array[0..DIST_CODE_LEN-1] of uch;\r
+{ Distance codes. The first 256 values correspond to the distances\r
+ 3 .. 258, the last 256 values correspond to the top 8 bits of\r
+ the 15 bit distances. }\r
+\r
+ _length_code : array[0..MAX_MATCH-MIN_MATCH+1-1] of uch;\r
+{ length code for each normalized match length (0 == MIN_MATCH) }\r
+\r
+{local}\r
+ base_length : array[0..LENGTH_CODES-1] of int;\r
+{ First normalized length for each code (0 = MIN_MATCH) }\r
+\r
+{local}\r
+ base_dist : array[0..D_CODES-1] of int;\r
+{ First normalized distance for each code (0 = distance of 1) }\r
+\r
+{$endif} { GEN_TREES_H }\r
+\r
+{local}\r
+const\r
+ static_l_desc : static_tree_desc =\r
+ (static_tree: {tree_ptr}(@(static_ltree)); { pointer to array of ct_data }\r
+ extra_bits: {pzIntfArray}(@(extra_lbits)); { pointer to array of int }\r
+ extra_base: LITERALS+1;\r
+ elems: L_CODES;\r
+ max_length: MAX_BITS);\r
+\r
+{local}\r
+const\r
+ static_d_desc : static_tree_desc =\r
+ (static_tree: {tree_ptr}(@(static_dtree));\r
+ extra_bits: {pzIntfArray}(@(extra_dbits));\r
+ extra_base : 0;\r
+ elems: D_CODES;\r
+ max_length: MAX_BITS);\r
+\r
+{local}\r
+const\r
+ static_bl_desc : static_tree_desc =\r
+ (static_tree: {tree_ptr}(NIL);\r
+ extra_bits: {pzIntfArray}@(extra_blbits);\r
+ extra_base : 0;\r
+ elems: BL_CODES;\r
+ max_length: MAX_BL_BITS);\r
+\r
+(* ===========================================================================\r
+ Local (static) routines in this file. }\r
+\r
+procedure tr_static_init;\r
+procedure init_block(var deflate_state);\r
+procedure pqdownheap(var s : deflate_state;\r
+ var tree : ct_data;\r
+ k : int);\r
+procedure gen_bitlen(var s : deflate_state;\r
+ var desc : tree_desc);\r
+procedure gen_codes(var tree : ct_data;\r
+ max_code : int;\r
+ bl_count : pushf);\r
+procedure build_tree(var s : deflate_state;\r
+ var desc : tree_desc);\r
+procedure scan_tree(var s : deflate_state;\r
+ var tree : ct_data;\r
+ max_code : int);\r
+procedure send_tree(var s : deflate_state;\r
+ var tree : ct_data;\r
+ max_code : int);\r
+function build_bl_tree(var deflate_state) : int;\r
+procedure send_all_trees(var deflate_state;\r
+ lcodes : int;\r
+ dcodes : int;\r
+ blcodes : int);\r
+procedure compress_block(var s : deflate_state;\r
+ var ltree : ct_data;\r
+ var dtree : ct_data);\r
+procedure set_data_type(var s : deflate_state);\r
+function bi_reverse(value : unsigned;\r
+ length : int) : unsigned;\r
+procedure bi_windup(var deflate_state);\r
+procedure bi_flush(var deflate_state);\r
+procedure copy_block(var deflate_state;\r
+ buf : pcharf;\r
+ len : unsigned;\r
+ header : int);\r
+*)\r
+\r
+{$ifdef GEN_TREES_H}\r
+{local}\r
+procedure gen_trees_header;\r
+{$endif}\r
+\r
+(*\r
+{ ===========================================================================\r
+ Output a short LSB first on the stream.\r
+ IN assertion: there is enough room in pendingBuf. }\r
+\r
+macro put_short(s, w)\r
+begin\r
+ {put_byte(s, (uch)((w) & 0xff));}\r
+ s.pending_buf^[s.pending] := uch((w) and $ff);\r
+ Inc(s.pending);\r
+\r
+ {put_byte(s, (uch)((ush)(w) >> 8));}\r
+ s.pending_buf^[s.pending] := uch(ush(w) shr 8);;\r
+ Inc(s.pending);\r
+end\r
+*)\r
+\r
+{ ===========================================================================\r
+ Send a value on a given number of bits.\r
+ IN assertion: length <= 16 and value fits in length bits. }\r
+\r
+{$ifdef ORG_DEBUG}\r
+\r
+{local}\r
+procedure send_bits(var s : deflate_state;\r
+ value : int; { value to send }\r
+ length : int); { number of bits }\r
+begin\r
+ {$ifdef DEBUG}\r
+ Tracevv(' l '+IntToStr(length)+ ' v '+IntToStr(value));\r
+ Assert((length > 0) and (length <= 15), 'invalid length');\r
+ Inc(s.bits_sent, ulg(length));\r
+ {$ENDIF}\r
+\r
+ { If not enough room in bi_buf, use (valid) bits from bi_buf and\r
+ (16 - bi_valid) bits from value, leaving (width - (16-bi_valid))\r
+ unused bits in value. }\r
+ {$IFOPT Q+} {$Q-} {$DEFINE NoOverflowCheck} {$ENDIF}\r
+ {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF}\r
+ if (s.bi_valid > int(Buf_size) - length) then\r
+ begin\r
+ s.bi_buf := s.bi_buf or int(value shl s.bi_valid);\r
+ {put_short(s, s.bi_buf);}\r
+ s.pending_buf^[s.pending] := uch(s.bi_buf and $ff);\r
+ Inc(s.pending);\r
+ s.pending_buf^[s.pending] := uch(ush(s.bi_buf) shr 8);;\r
+ Inc(s.pending);\r
+\r
+ s.bi_buf := ush(value) shr (Buf_size - s.bi_valid);\r
+ Inc(s.bi_valid, length - Buf_size);\r
+ end\r
+ else\r
+ begin\r
+ s.bi_buf := s.bi_buf or int(value shl s.bi_valid);\r
+ Inc(s.bi_valid, length);\r
+ end;\r
+ {$IFDEF NoOverflowCheck} {$Q+} {$UNDEF NoOverflowCheck} {$ENDIF}\r
+ {$IFDEF NoRangeCheck} {$Q+} {$UNDEF NoRangeCheck} {$ENDIF}\r
+end;\r
+\r
+{$else} { !DEBUG }\r
+\r
+\r
+macro send_code(s, c, tree)\r
+begin\r
+ send_bits(s, tree[c].Code, tree[c].Len);\r
+ { Send a code of the given tree. c and tree must not have side effects }\r
+end\r
+\r
+macro send_bits(s, value, length) \\r
+begin int len := length;\\r
+ if (s^.bi_valid > (int)Buf_size - len) begin\\r
+ int val := value;\\r
+ s^.bi_buf |= (val << s^.bi_valid);\\r
+ {put_short(s, s.bi_buf);}\r
+ s.pending_buf^[s.pending] := uch(s.bi_buf and $ff);\r
+ Inc(s.pending);\r
+ s.pending_buf^[s.pending] := uch(ush(s.bi_buf) shr 8);;\r
+ Inc(s.pending);\r
+\r
+ s^.bi_buf := (ush)val >> (Buf_size - s^.bi_valid);\\r
+ s^.bi_valid += len - Buf_size;\\r
+ end else begin\\r
+ s^.bi_buf |= (value) << s^.bi_valid;\\r
+ s^.bi_valid += len;\\r
+ end\\r
+end;\r
+{$endif} { DEBUG }\r
+\r
+{ ===========================================================================\r
+ Reverse the first len bits of a code, using straightforward code (a faster\r
+ method would use a table)\r
+ IN assertion: 1 <= len <= 15 }\r
+\r
+{local}\r
+function bi_reverse(code : unsigned; { the value to invert }\r
+ len : int) : unsigned; { its bit length }\r
+\r
+var\r
+ res : unsigned; {register}\r
+begin\r
+ res := 0;\r
+ repeat\r
+ res := res or (code and 1);\r
+ code := code shr 1;\r
+ res := res shl 1;\r
+ Dec(len);\r
+ until (len <= 0);\r
+ bi_reverse := res shr 1;\r
+end;\r
+\r
+{ ===========================================================================\r
+ Generate the codes for a given tree and bit counts (which need not be\r
+ optimal).\r
+ IN assertion: the array bl_count contains the bit length statistics for\r
+ the given tree and the field len is set for all tree elements.\r
+ OUT assertion: the field code is set for all tree elements of non\r
+ zero code length. }\r
+\r
+{local}\r
+procedure gen_codes(tree : tree_ptr; { the tree to decorate }\r
+ max_code : int; { largest code with non zero frequency }\r
+ var bl_count : array of ushf); { number of codes at each bit length }\r
+\r
+var\r
+ next_code : array[0..MAX_BITS+1-1] of ush; { next code value for each bit length }\r
+ code : ush; { running code value }\r
+ bits : int; { bit index }\r
+ n : int; { code index }\r
+var\r
+ len : int;\r
+begin\r
+ code := 0;\r
+\r
+ { The distribution counts are first used to generate the code values\r
+ without bit reversal. }\r
+\r
+ for bits := 1 to MAX_BITS do\r
+ begin\r
+ code := ((code + bl_count[bits-1]) shl 1);\r
+ next_code[bits] := code;\r
+ end;\r
+ { Check that the bit counts in bl_count are consistent. The last code\r
+ must be all ones. }\r
+\r
+ {$IFDEF DEBUG}\r
+ Assert (code + bl_count[MAX_BITS]-1 = (1 shl MAX_BITS)-1,\r
+ 'inconsistent bit counts');\r
+ Tracev(#13'gen_codes: max_code '+IntToStr(max_code));\r
+ {$ENDIF}\r
+\r
+ for n := 0 to max_code do\r
+ begin\r
+ len := tree^[n].dl.Len;\r
+ if (len = 0) then\r
+ continue;\r
+ { Now reverse the bits }\r
+ tree^[n].fc.Code := bi_reverse(next_code[len], len);\r
+ Inc(next_code[len]);\r
+ {$ifdef DEBUG}\r
+ if (n>31) and (n<128) then\r
+ Tracecv(tree <> tree_ptr(@static_ltree),\r
+ (^M'n #'+IntToStr(n)+' '+char(n)+' l '+IntToStr(len)+' c '+\r
+ IntToStr(tree^[n].fc.Code)+' ('+IntToStr(next_code[len]-1)+')'))\r
+ else\r
+ Tracecv(tree <> tree_ptr(@static_ltree),\r
+ (^M'n #'+IntToStr(n)+' l '+IntToStr(len)+' c '+\r
+ IntToStr(tree^[n].fc.Code)+' ('+IntToStr(next_code[len]-1)+')'));\r
+ {$ENDIF}\r
+ end;\r
+end;\r
+\r
+{ ===========================================================================\r
+ Genererate the file trees.h describing the static trees. }\r
+{$ifdef GEN_TREES_H}\r
+\r
+macro SEPARATOR(i, last, width)\r
+ if (i) = (last) then\r
+ ( ^M');'^M^M\r
+ else \\r
+ if (i) mod (width) = (width)-1 then\r
+ ','^M\r
+ else\r
+ ', '\r
+\r
+procedure gen_trees_header;\r
+var\r
+ header : system.text;\r
+ i : int;\r
+begin\r
+ system.assign(header, 'trees.inc');\r
+ {$I-}\r
+ ReWrite(header);\r
+ {$I+}\r
+ Assert (IOresult <> 0, 'Can''t open trees.h');\r
+ WriteLn(header,\r
+ '{ header created automatically with -DGEN_TREES_H }'^M);\r
+\r
+ WriteLn(header, 'local const ct_data static_ltree[L_CODES+2] := (');\r
+ for i := 0 to L_CODES+2-1 do\r
+ begin\r
+ WriteLn(header, '((%3u),(%3u))%s', static_ltree[i].Code,\r
+ static_ltree[i].Len, SEPARATOR(i, L_CODES+1, 5));\r
+ end;\r
+\r
+ WriteLn(header, 'local const ct_data static_dtree[D_CODES] := (');\r
+ for i := 0 to D_CODES-1 do\r
+ begin\r
+ WriteLn(header, '((%2u),(%2u))%s', static_dtree[i].Code,\r
+ static_dtree[i].Len, SEPARATOR(i, D_CODES-1, 5));\r
+ end;\r
+\r
+ WriteLn(header, 'const uch _dist_code[DIST_CODE_LEN] := (');\r
+ for i := 0 to DIST_CODE_LEN-1 do\r
+ begin\r
+ WriteLn(header, '%2u%s', _dist_code[i],\r
+ SEPARATOR(i, DIST_CODE_LEN-1, 20));\r
+ end;\r
+\r
+ WriteLn(header, 'const uch _length_code[MAX_MATCH-MIN_MATCH+1]= (');\r
+ for i := 0 to MAX_MATCH-MIN_MATCH+1-1 do\r
+ begin\r
+ WriteLn(header, '%2u%s', _length_code[i],\r
+ SEPARATOR(i, MAX_MATCH-MIN_MATCH, 20));\r
+ end;\r
+\r
+ WriteLn(header, 'local const int base_length[LENGTH_CODES] := (');\r
+ for i := 0 to LENGTH_CODES-1 do\r
+ begin\r
+ WriteLn(header, '%1u%s', base_length[i],\r
+ SEPARATOR(i, LENGTH_CODES-1, 20));\r
+ end;\r
+\r
+ WriteLn(header, 'local const int base_dist[D_CODES] := (');\r
+ for i := 0 to D_CODES-1 do\r
+ begin\r
+ WriteLn(header, '%5u%s', base_dist[i],\r
+ SEPARATOR(i, D_CODES-1, 10));\r
+ end;\r
+\r
+ close(header);\r
+end;\r
+{$endif} { GEN_TREES_H }\r
+\r
+\r
+{ ===========================================================================\r
+ Initialize the various 'constant' tables. }\r
+\r
+{local}\r
+procedure tr_static_init;\r
+\r
+{$ifdef GEN_TREES_H}\r
+const\r
+ static_init_done : boolean = FALSE;\r
+var\r
+ n : int; { iterates over tree elements }\r
+ bits : int; { bit counter }\r
+ length : int; { length value }\r
+ code : int; { code value }\r
+ dist : int; { distance index }\r
+ bl_count : array[0..MAX_BITS+1-1] of ush;\r
+ { number of codes at each bit length for an optimal tree }\r
+begin\r
+ if (static_init_done) then\r
+ exit;\r
+\r
+ { Initialize the mapping length (0..255) -> length code (0..28) }\r
+ length := 0;\r
+ for code := 0 to LENGTH_CODES-1-1 do\r
+ begin\r
+ base_length[code] := length;\r
+ for n := 0 to (1 shl extra_lbits[code])-1 do\r
+ begin\r
+ _length_code[length] := uch(code);\r
+ Inc(length);\r
+ end;\r
+ end;\r
+ Assert (length = 256, 'tr_static_init: length <> 256');\r
+ { Note that the length 255 (match length 258) can be represented\r
+ in two different ways: code 284 + 5 bits or code 285, so we\r
+ overwrite length_code[255] to use the best encoding: }\r
+\r
+ _length_code[length-1] := uch(code);\r
+\r
+ { Initialize the mapping dist (0..32K) -> dist code (0..29) }\r
+ dist := 0;\r
+ for code := 0 to 16-1 do\r
+ begin\r
+ base_dist[code] := dist;\r
+ for n := 0 to (1 shl extra_dbits[code])-1 do\r
+ begin\r
+ _dist_code[dist] := uch(code);\r
+ Inc(dist);\r
+ end;\r
+ end;\r
+ Assert (dist = 256, 'tr_static_init: dist <> 256');\r
+ dist := dist shr 7; { from now on, all distances are divided by 128 }\r
+ for code := 16 to D_CODES-1 do\r
+ begin\r
+ base_dist[code] := dist shl 7;\r
+ for n := 0 to (1 shl (extra_dbits[code]-7))-1 do\r
+ begin\r
+ _dist_code[256 + dist] := uch(code);\r
+ Inc(dist);\r
+ end;\r
+ end;\r
+ Assert (dist = 256, 'tr_static_init: 256+dist <> 512');\r
+\r
+ { Construct the codes of the static literal tree }\r
+ for bits := 0 to MAX_BITS do\r
+ bl_count[bits] := 0;\r
+ n := 0;\r
+ while (n <= 143) do\r
+ begin\r
+ static_ltree[n].dl.Len := 8;\r
+ Inc(n);\r
+ Inc(bl_count[8]);\r
+ end;\r
+ while (n <= 255) do\r
+ begin\r
+ static_ltree[n].dl.Len := 9;\r
+ Inc(n);\r
+ Inc(bl_count[9]);\r
+ end;\r
+ while (n <= 279) do\r
+ begin\r
+ static_ltree[n].dl.Len := 7;\r
+ Inc(n);\r
+ Inc(bl_count[7]);\r
+ end;\r
+ while (n <= 287) do\r
+ begin\r
+ static_ltree[n].dl.Len := 8;\r
+ Inc(n);\r
+ Inc(bl_count[8]);\r
+ end;\r
+\r
+ { Codes 286 and 287 do not exist, but we must include them in the\r
+ tree construction to get a canonical Huffman tree (longest code\r
+ all ones) }\r
+\r
+ gen_codes(tree_ptr(@static_ltree), L_CODES+1, bl_count);\r
+\r
+ { The static distance tree is trivial: }\r
+ for n := 0 to D_CODES-1 do\r
+ begin\r
+ static_dtree[n].dl.Len := 5;\r
+ static_dtree[n].fc.Code := bi_reverse(unsigned(n), 5);\r
+ end;\r
+ static_init_done := TRUE;\r
+\r
+ gen_trees_header; { save to include file }\r
+{$else}\r
+begin\r
+{$endif} { GEN_TREES_H) }\r
+end;\r
+\r
+{ ===========================================================================\r
+ Initialize a new block. }\r
+{local}\r
+\r
+procedure init_block(var s : deflate_state);\r
+var\r
+ n : int; { iterates over tree elements }\r
+begin\r
+ { Initialize the trees. }\r
+ for n := 0 to L_CODES-1 do\r
+ s.dyn_ltree[n].fc.Freq := 0;\r
+ for n := 0 to D_CODES-1 do\r
+ s.dyn_dtree[n].fc.Freq := 0;\r
+ for n := 0 to BL_CODES-1 do\r
+ s.bl_tree[n].fc.Freq := 0;\r
+\r
+ s.dyn_ltree[END_BLOCK].fc.Freq := 1;\r
+ s.static_len := Long(0);\r
+ s.opt_len := Long(0);\r
+ s.matches := 0;\r
+ s.last_lit := 0;\r
+end;\r
+\r
+const\r
+ SMALLEST = 1;\r
+{ Index within the heap array of least frequent node in the Huffman tree }\r
+\r
+{ ===========================================================================\r
+ Initialize the tree data structures for a new zlib stream. }\r
+procedure _tr_init(var s : deflate_state);\r
+begin\r
+ tr_static_init;\r
+\r
+ s.compressed_len := Long(0);\r
+\r
+ s.l_desc.dyn_tree := tree_ptr(@s.dyn_ltree);\r
+ s.l_desc.stat_desc := @static_l_desc;\r
+\r
+ s.d_desc.dyn_tree := tree_ptr(@s.dyn_dtree);\r
+ s.d_desc.stat_desc := @static_d_desc;\r
+\r
+ s.bl_desc.dyn_tree := tree_ptr(@s.bl_tree);\r
+ s.bl_desc.stat_desc := @static_bl_desc;\r
+\r
+ s.bi_buf := 0;\r
+ s.bi_valid := 0;\r
+ s.last_eob_len := 8; { enough lookahead for inflate }\r
+{$ifdef DEBUG}\r
+ s.bits_sent := Long(0);\r
+{$endif}\r
+\r
+ { Initialize the first block of the first file: }\r
+ init_block(s);\r
+end;\r
+\r
+{ ===========================================================================\r
+ Remove the smallest element from the heap and recreate the heap with\r
+ one less element. Updates heap and heap_len.\r
+\r
+macro pqremove(s, tree, top)\r
+begin\r
+ top := s.heap[SMALLEST];\r
+ s.heap[SMALLEST] := s.heap[s.heap_len];\r
+ Dec(s.heap_len);\r
+ pqdownheap(s, tree, SMALLEST);\r
+end\r
+}\r
+\r
+{ ===========================================================================\r
+ Compares to subtrees, using the tree depth as tie breaker when\r
+ the subtrees have equal frequency. This minimizes the worst case length.\r
+\r
+macro smaller(tree, n, m, depth)\r
+ ( (tree[n].Freq < tree[m].Freq) or\r
+ ((tree[n].Freq = tree[m].Freq) and (depth[n] <= depth[m])) )\r
+}\r
+\r
+{ ===========================================================================\r
+ Restore the heap property by moving down the tree starting at node k,\r
+ exchanging a node with the smallest of its two sons if necessary, stopping\r
+ when the heap property is re-established (each father smaller than its\r
+ two sons). }\r
+{local}\r
+\r
+procedure pqdownheap(var s : deflate_state;\r
+ var tree : tree_type; { the tree to restore }\r
+ k : int); { node to move down }\r
+var\r
+ v : int;\r
+ j : int;\r
+begin\r
+ v := s.heap[k];\r
+ j := k shl 1; { left son of k }\r
+ while (j <= s.heap_len) do\r
+ begin\r
+ { Set j to the smallest of the two sons: }\r
+ if (j < s.heap_len) and\r
+ {smaller(tree, s.heap[j+1], s.heap[j], s.depth)}\r
+ ( (tree[s.heap[j+1]].fc.Freq < tree[s.heap[j]].fc.Freq) or\r
+ ((tree[s.heap[j+1]].fc.Freq = tree[s.heap[j]].fc.Freq) and\r
+ (s.depth[s.heap[j+1]] <= s.depth[s.heap[j]])) ) then\r
+ begin\r
+ Inc(j);\r
+ end;\r
+ { Exit if v is smaller than both sons }\r
+ if {(smaller(tree, v, s.heap[j], s.depth))}\r
+ ( (tree[v].fc.Freq < tree[s.heap[j]].fc.Freq) or\r
+ ((tree[v].fc.Freq = tree[s.heap[j]].fc.Freq) and\r
+ (s.depth[v] <= s.depth[s.heap[j]])) ) then\r
+ break;\r
+ { Exchange v with the smallest son }\r
+ s.heap[k] := s.heap[j];\r
+ k := j;\r
+\r
+ { And continue down the tree, setting j to the left son of k }\r
+ j := j shl 1;\r
+ end;\r
+ s.heap[k] := v;\r
+end;\r
+\r
+{ ===========================================================================\r
+ Compute the optimal bit lengths for a tree and update the total bit length\r
+ for the current block.\r
+ IN assertion: the fields freq and dad are set, heap[heap_max] and\r
+ above are the tree nodes sorted by increasing frequency.\r
+ OUT assertions: the field len is set to the optimal bit length, the\r
+ array bl_count contains the frequencies for each bit length.\r
+ The length opt_len is updated; static_len is also updated if stree is\r
+ not null. }\r
+\r
+{local}\r
+procedure gen_bitlen(var s : deflate_state;\r
+ var desc : tree_desc); { the tree descriptor }\r
+var\r
+ tree : tree_ptr;\r
+ max_code : int;\r
+ stree : tree_ptr; {const}\r
+ extra : pzIntfArray; {const}\r
+ base : int;\r
+ max_length : int;\r
+ h : int; { heap index }\r
+ n, m : int; { iterate over the tree elements }\r
+ bits : int; { bit length }\r
+ xbits : int; { extra bits }\r
+ f : ush; { frequency }\r
+ overflow : int; { number of elements with bit length too large }\r
+begin\r
+ tree := desc.dyn_tree;\r
+ max_code := desc.max_code;\r
+ stree := desc.stat_desc^.static_tree;\r
+ extra := desc.stat_desc^.extra_bits;\r
+ base := desc.stat_desc^.extra_base;\r
+ max_length := desc.stat_desc^.max_length;\r
+ overflow := 0;\r
+\r
+ for bits := 0 to MAX_BITS do\r
+ s.bl_count[bits] := 0;\r
+\r
+ { In a first pass, compute the optimal bit lengths (which may\r
+ overflow in the case of the bit length tree). }\r
+\r
+ tree^[s.heap[s.heap_max]].dl.Len := 0; { root of the heap }\r
+\r
+ for h := s.heap_max+1 to HEAP_SIZE-1 do\r
+ begin\r
+ n := s.heap[h];\r
+ bits := tree^[tree^[n].dl.Dad].dl.Len + 1;\r
+ if (bits > max_length) then\r
+ begin\r
+ bits := max_length;\r
+ Inc(overflow);\r
+ end;\r
+ tree^[n].dl.Len := ush(bits);\r
+ { We overwrite tree[n].dl.Dad which is no longer needed }\r
+\r
+ if (n > max_code) then\r
+ continue; { not a leaf node }\r
+\r
+ Inc(s.bl_count[bits]);\r
+ xbits := 0;\r
+ if (n >= base) then\r
+ xbits := extra^[n-base];\r
+ f := tree^[n].fc.Freq;\r
+ Inc(s.opt_len, ulg(f) * (bits + xbits));\r
+ if (stree <> NIL) then\r
+ Inc(s.static_len, ulg(f) * (stree^[n].dl.Len + xbits));\r
+ end;\r
+ if (overflow = 0) then\r
+ exit;\r
+ {$ifdef DEBUG}\r
+ Tracev(^M'bit length overflow');\r
+ {$endif}\r
+ { This happens for example on obj2 and pic of the Calgary corpus }\r
+\r
+ { Find the first bit length which could increase: }\r
+ repeat\r
+ bits := max_length-1;\r
+ while (s.bl_count[bits] = 0) do\r
+ Dec(bits);\r
+ Dec(s.bl_count[bits]); { move one leaf down the tree }\r
+ Inc(s.bl_count[bits+1], 2); { move one overflow item as its brother }\r
+ Dec(s.bl_count[max_length]);\r
+ { The brother of the overflow item also moves one step up,\r
+ but this does not affect bl_count[max_length] }\r
+\r
+ Dec(overflow, 2);\r
+ until (overflow <= 0);\r
+\r
+ { Now recompute all bit lengths, scanning in increasing frequency.\r
+ h is still equal to HEAP_SIZE. (It is simpler to reconstruct all\r
+ lengths instead of fixing only the wrong ones. This idea is taken\r
+ from 'ar' written by Haruhiko Okumura.) }\r
+ h := HEAP_SIZE; { Delphi3: compiler warning w/o this }\r
+ for bits := max_length downto 1 do\r
+ begin\r
+ n := s.bl_count[bits];\r
+ while (n <> 0) do\r
+ begin\r
+ Dec(h);\r
+ m := s.heap[h];\r
+ if (m > max_code) then\r
+ continue;\r
+ if (tree^[m].dl.Len <> unsigned(bits)) then\r
+ begin\r
+ {$ifdef DEBUG}\r
+ Trace('code '+IntToStr(m)+' bits '+IntToStr(tree^[m].dl.Len)\r
+ +'.'+IntToStr(bits));\r
+ {$ENDIF}\r
+ Inc(s.opt_len, (long(bits) - long(tree^[m].dl.Len))\r
+ * long(tree^[m].fc.Freq) );\r
+ tree^[m].dl.Len := ush(bits);\r
+ end;\r
+ Dec(n);\r
+ end;\r
+ end;\r
+end;\r
+\r
+{ ===========================================================================\r
+ Construct one Huffman tree and assigns the code bit strings and lengths.\r
+ Update the total bit length for the current block.\r
+ IN assertion: the field freq is set for all tree elements.\r
+ OUT assertions: the fields len and code are set to the optimal bit length\r
+ and corresponding code. The length opt_len is updated; static_len is\r
+ also updated if stree is not null. The field max_code is set. }\r
+\r
+{local}\r
+procedure build_tree(var s : deflate_state;\r
+ var desc : tree_desc); { the tree descriptor }\r
+\r
+var\r
+ tree : tree_ptr;\r
+ stree : tree_ptr; {const}\r
+ elems : int;\r
+ n, m : int; { iterate over heap elements }\r
+ max_code : int; { largest code with non zero frequency }\r
+ node : int; { new node being created }\r
+begin\r
+ tree := desc.dyn_tree;\r
+ stree := desc.stat_desc^.static_tree;\r
+ elems := desc.stat_desc^.elems;\r
+ max_code := -1;\r
+\r
+ { Construct the initial heap, with least frequent element in\r
+ heap[SMALLEST]. The sons of heap[n] are heap[2*n] and heap[2*n+1].\r
+ heap[0] is not used. }\r
+ s.heap_len := 0;\r
+ s.heap_max := HEAP_SIZE;\r
+\r
+ for n := 0 to elems-1 do\r
+ begin\r
+ if (tree^[n].fc.Freq <> 0) then\r
+ begin\r
+ max_code := n;\r
+ Inc(s.heap_len);\r
+ s.heap[s.heap_len] := n;\r
+ s.depth[n] := 0;\r
+ end\r
+ else\r
+ begin\r
+ tree^[n].dl.Len := 0;\r
+ end;\r
+ end;\r
+\r
+ { The pkzip format requires that at least one distance code exists,\r
+ and that at least one bit should be sent even if there is only one\r
+ possible code. So to avoid special checks later on we force at least\r
+ two codes of non zero frequency. }\r
+\r
+ while (s.heap_len < 2) do\r
+ begin\r
+ Inc(s.heap_len);\r
+ if (max_code < 2) then\r
+ begin\r
+ Inc(max_code);\r
+ s.heap[s.heap_len] := max_code;\r
+ node := max_code;\r
+ end\r
+ else\r
+ begin\r
+ s.heap[s.heap_len] := 0;\r
+ node := 0;\r
+ end;\r
+ tree^[node].fc.Freq := 1;\r
+ s.depth[node] := 0;\r
+ Dec(s.opt_len);\r
+ if (stree <> NIL) then\r
+ Dec(s.static_len, stree^[node].dl.Len);\r
+ { node is 0 or 1 so it does not have extra bits }\r
+ end;\r
+ desc.max_code := max_code;\r
+\r
+ { The elements heap[heap_len/2+1 .. heap_len] are leaves of the tree,\r
+ establish sub-heaps of increasing lengths: }\r
+\r
+ for n := s.heap_len div 2 downto 1 do\r
+ pqdownheap(s, tree^, n);\r
+\r
+ { Construct the Huffman tree by repeatedly combining the least two\r
+ frequent nodes. }\r
+\r
+ node := elems; { next internal node of the tree }\r
+ repeat\r
+ {pqremove(s, tree, n);} { n := node of least frequency }\r
+ n := s.heap[SMALLEST];\r
+ s.heap[SMALLEST] := s.heap[s.heap_len];\r
+ Dec(s.heap_len);\r
+ pqdownheap(s, tree^, SMALLEST);\r
+\r
+ m := s.heap[SMALLEST]; { m := node of next least frequency }\r
+\r
+ Dec(s.heap_max);\r
+ s.heap[s.heap_max] := n; { keep the nodes sorted by frequency }\r
+ Dec(s.heap_max);\r
+ s.heap[s.heap_max] := m;\r
+\r
+ { Create a new node father of n and m }\r
+ tree^[node].fc.Freq := tree^[n].fc.Freq + tree^[m].fc.Freq;\r
+ { maximum }\r
+ if (s.depth[n] >= s.depth[m]) then\r
+ s.depth[node] := uch (s.depth[n] + 1)\r
+ else\r
+ s.depth[node] := uch (s.depth[m] + 1);\r
+\r
+ tree^[m].dl.Dad := ush(node);\r
+ tree^[n].dl.Dad := ush(node);\r
+{$ifdef DUMP_BL_TREE}\r
+ if (tree = tree_ptr(@s.bl_tree)) then\r
+ begin\r
+ WriteLn(#13'node ',node,'(',tree^[node].fc.Freq,') sons ',n,\r
+ '(',tree^[n].fc.Freq,') ', m, '(',tree^[m].fc.Freq,')');\r
+ end;\r
+{$endif}\r
+ { and insert the new node in the heap }\r
+ s.heap[SMALLEST] := node;\r
+ Inc(node);\r
+ pqdownheap(s, tree^, SMALLEST);\r
+\r
+ until (s.heap_len < 2);\r
+\r
+ Dec(s.heap_max);\r
+ s.heap[s.heap_max] := s.heap[SMALLEST];\r
+\r
+ { At this point, the fields freq and dad are set. We can now\r
+ generate the bit lengths. }\r
+\r
+ gen_bitlen(s, desc);\r
+\r
+ { The field len is now set, we can generate the bit codes }\r
+ gen_codes (tree, max_code, s.bl_count);\r
+end;\r
+\r
+{ ===========================================================================\r
+ Scan a literal or distance tree to determine the frequencies of the codes\r
+ in the bit length tree. }\r
+\r
+{local}\r
+procedure scan_tree(var s : deflate_state;\r
+ var tree : array of ct_data; { the tree to be scanned }\r
+ max_code : int); { and its largest code of non zero frequency }\r
+var\r
+ n : int; { iterates over all tree elements }\r
+ prevlen : int; { last emitted length }\r
+ curlen : int; { length of current code }\r
+ nextlen : int; { length of next code }\r
+ count : int; { repeat count of the current code }\r
+ max_count : int; { max repeat count }\r
+ min_count : int; { min repeat count }\r
+begin\r
+ prevlen := -1;\r
+ nextlen := tree[0].dl.Len;\r
+ count := 0;\r
+ max_count := 7;\r
+ min_count := 4;\r
+\r
+ if (nextlen = 0) then\r
+ begin\r
+ max_count := 138;\r
+ min_count := 3;\r
+ end;\r
+ tree[max_code+1].dl.Len := ush($ffff); { guard }\r
+\r
+ for n := 0 to max_code do\r
+ begin\r
+ curlen := nextlen;\r
+ nextlen := tree[n+1].dl.Len;\r
+ Inc(count);\r
+ if (count < max_count) and (curlen = nextlen) then\r
+ continue\r
+ else\r
+ if (count < min_count) then\r
+ Inc(s.bl_tree[curlen].fc.Freq, count)\r
+ else\r
+ if (curlen <> 0) then\r
+ begin\r
+ if (curlen <> prevlen) then\r
+ Inc(s.bl_tree[curlen].fc.Freq);\r
+ Inc(s.bl_tree[REP_3_6].fc.Freq);\r
+ end\r
+ else\r
+ if (count <= 10) then\r
+ Inc(s.bl_tree[REPZ_3_10].fc.Freq)\r
+ else\r
+ Inc(s.bl_tree[REPZ_11_138].fc.Freq);\r
+\r
+ count := 0;\r
+ prevlen := curlen;\r
+ if (nextlen = 0) then\r
+ begin\r
+ max_count := 138;\r
+ min_count := 3;\r
+ end\r
+ else\r
+ if (curlen = nextlen) then\r
+ begin\r
+ max_count := 6;\r
+ min_count := 3;\r
+ end\r
+ else\r
+ begin\r
+ max_count := 7;\r
+ min_count := 4;\r
+ end;\r
+ end;\r
+end;\r
+\r
+{ ===========================================================================\r
+ Send a literal or distance tree in compressed form, using the codes in\r
+ bl_tree. }\r
+\r
+{local}\r
+procedure send_tree(var s : deflate_state;\r
+ var tree : array of ct_data; { the tree to be scanned }\r
+ max_code : int); { and its largest code of non zero frequency }\r
+\r
+var\r
+ n : int; { iterates over all tree elements }\r
+ prevlen : int; { last emitted length }\r
+ curlen : int; { length of current code }\r
+ nextlen : int; { length of next code }\r
+ count : int; { repeat count of the current code }\r
+ max_count : int; { max repeat count }\r
+ min_count : int; { min repeat count }\r
+begin\r
+ prevlen := -1;\r
+ nextlen := tree[0].dl.Len;\r
+ count := 0;\r
+ max_count := 7;\r
+ min_count := 4;\r
+\r
+ { tree[max_code+1].dl.Len := -1; } { guard already set }\r
+ if (nextlen = 0) then\r
+ begin\r
+ max_count := 138;\r
+ min_count := 3;\r
+ end;\r
+\r
+ for n := 0 to max_code do\r
+ begin\r
+ curlen := nextlen;\r
+ nextlen := tree[n+1].dl.Len;\r
+ Inc(count);\r
+ if (count < max_count) and (curlen = nextlen) then\r
+ continue\r
+ else\r
+ if (count < min_count) then\r
+ begin\r
+ repeat\r
+ {$ifdef DEBUG}\r
+ Tracevvv(#13'cd '+IntToStr(curlen));\r
+ {$ENDIF}\r
+ send_bits(s, s.bl_tree[curlen].fc.Code, s.bl_tree[curlen].dl.Len);\r
+ Dec(count);\r
+ until (count = 0);\r
+ end\r
+ else\r
+ if (curlen <> 0) then\r
+ begin\r
+ if (curlen <> prevlen) then\r
+ begin\r
+ {$ifdef DEBUG}\r
+ Tracevvv(#13'cd '+IntToStr(curlen));\r
+ {$ENDIF}\r
+ send_bits(s, s.bl_tree[curlen].fc.Code, s.bl_tree[curlen].dl.Len);\r
+ Dec(count);\r
+ end;\r
+ {$IFDEF DEBUG}\r
+ Assert((count >= 3) and (count <= 6), ' 3_6?');\r
+ {$ENDIF}\r
+ {$ifdef DEBUG}\r
+ Tracevvv(#13'cd '+IntToStr(REP_3_6));\r
+ {$ENDIF}\r
+ send_bits(s, s.bl_tree[REP_3_6].fc.Code, s.bl_tree[REP_3_6].dl.Len);\r
+ send_bits(s, count-3, 2);\r
+ end\r
+ else\r
+ if (count <= 10) then\r
+ begin\r
+ {$ifdef DEBUG}\r
+ Tracevvv(#13'cd '+IntToStr(REPZ_3_10));\r
+ {$ENDIF}\r
+ send_bits(s, s.bl_tree[REPZ_3_10].fc.Code, s.bl_tree[REPZ_3_10].dl.Len);\r
+ send_bits(s, count-3, 3);\r
+ end\r
+ else\r
+ begin\r
+ {$ifdef DEBUG}\r
+ Tracevvv(#13'cd '+IntToStr(REPZ_11_138));\r
+ {$ENDIF}\r
+ send_bits(s, s.bl_tree[REPZ_11_138].fc.Code, s.bl_tree[REPZ_11_138].dl.Len);\r
+ send_bits(s, count-11, 7);\r
+ end;\r
+ count := 0;\r
+ prevlen := curlen;\r
+ if (nextlen = 0) then\r
+ begin\r
+ max_count := 138;\r
+ min_count := 3;\r
+ end\r
+ else\r
+ if (curlen = nextlen) then\r
+ begin\r
+ max_count := 6;\r
+ min_count := 3;\r
+ end\r
+ else\r
+ begin\r
+ max_count := 7;\r
+ min_count := 4;\r
+ end;\r
+ end;\r
+end;\r
+\r
+{ ===========================================================================\r
+ Construct the Huffman tree for the bit lengths and return the index in\r
+ bl_order of the last bit length code to send. }\r
+\r
+{local}\r
+function build_bl_tree(var s : deflate_state) : int;\r
+var\r
+ max_blindex : int; { index of last bit length code of non zero freq }\r
+begin\r
+ { Determine the bit length frequencies for literal and distance trees }\r
+ scan_tree(s, s.dyn_ltree, s.l_desc.max_code);\r
+ scan_tree(s, s.dyn_dtree, s.d_desc.max_code);\r
+\r
+ { Build the bit length tree: }\r
+ build_tree(s, s.bl_desc);\r
+ { opt_len now includes the length of the tree representations, except\r
+ the lengths of the bit lengths codes and the 5+5+4 bits for the counts. }\r
+\r
+ { Determine the number of bit length codes to send. The pkzip format\r
+ requires that at least 4 bit length codes be sent. (appnote.txt says\r
+ 3 but the actual value used is 4.) }\r
+\r
+ for max_blindex := BL_CODES-1 downto 3 do\r
+ begin\r
+ if (s.bl_tree[bl_order[max_blindex]].dl.Len <> 0) then\r
+ break;\r
+ end;\r
+ { Update opt_len to include the bit length tree and counts }\r
+ Inc(s.opt_len, 3*(max_blindex+1) + 5+5+4);\r
+ {$ifdef DEBUG}\r
+ Tracev(^M'dyn trees: dyn %ld, stat %ld {s.opt_len, s.static_len}');\r
+ {$ENDIF}\r
+\r
+ build_bl_tree := max_blindex;\r
+end;\r
+\r
+{ ===========================================================================\r
+ Send the header for a block using dynamic Huffman trees: the counts, the\r
+ lengths of the bit length codes, the literal tree and the distance tree.\r
+ IN assertion: lcodes >= 257, dcodes >= 1, blcodes >= 4. }\r
+\r
+{local}\r
+procedure send_all_trees(var s : deflate_state;\r
+ lcodes : int;\r
+ dcodes : int;\r
+ blcodes : int); { number of codes for each tree }\r
+var\r
+ rank : int; { index in bl_order }\r
+begin\r
+ {$IFDEF DEBUG}\r
+ Assert ((lcodes >= 257) and (dcodes >= 1) and (blcodes >= 4),\r
+ 'not enough codes');\r
+ Assert ((lcodes <= L_CODES) and (dcodes <= D_CODES)\r
+ and (blcodes <= BL_CODES), 'too many codes');\r
+ Tracev(^M'bl counts: ');\r
+ {$ENDIF}\r
+ send_bits(s, lcodes-257, 5); { not +255 as stated in appnote.txt }\r
+ send_bits(s, dcodes-1, 5);\r
+ send_bits(s, blcodes-4, 4); { not -3 as stated in appnote.txt }\r
+ for rank := 0 to blcodes-1 do\r
+ begin\r
+ {$ifdef DEBUG}\r
+ Tracev(^M'bl code '+IntToStr(bl_order[rank]));\r
+ {$ENDIF}\r
+ send_bits(s, s.bl_tree[bl_order[rank]].dl.Len, 3);\r
+ end;\r
+ {$ifdef DEBUG}\r
+ Tracev(^M'bl tree: sent '+IntToStr(s.bits_sent));\r
+ {$ENDIF}\r
+\r
+ send_tree(s, s.dyn_ltree, lcodes-1); { literal tree }\r
+ {$ifdef DEBUG}\r
+ Tracev(^M'lit tree: sent '+IntToStr(s.bits_sent));\r
+ {$ENDIF}\r
+\r
+ send_tree(s, s.dyn_dtree, dcodes-1); { distance tree }\r
+ {$ifdef DEBUG}\r
+ Tracev(^M'dist tree: sent '+IntToStr(s.bits_sent));\r
+ {$ENDIF}\r
+end;\r
+\r
+{ ===========================================================================\r
+ Flush the bit buffer and align the output on a byte boundary }\r
+\r
+{local}\r
+procedure bi_windup(var s : deflate_state);\r
+begin\r
+ if (s.bi_valid > 8) then\r
+ begin\r
+ {put_short(s, s.bi_buf);}\r
+ s.pending_buf^[s.pending] := uch(s.bi_buf and $ff);\r
+ Inc(s.pending);\r
+ s.pending_buf^[s.pending] := uch(ush(s.bi_buf) shr 8);;\r
+ Inc(s.pending);\r
+ end\r
+ else\r
+ if (s.bi_valid > 0) then\r
+ begin\r
+ {put_byte(s, (Byte)s^.bi_buf);}\r
+ s.pending_buf^[s.pending] := Byte(s.bi_buf);\r
+ Inc(s.pending);\r
+ end;\r
+ s.bi_buf := 0;\r
+ s.bi_valid := 0;\r
+{$ifdef DEBUG}\r
+ s.bits_sent := (s.bits_sent+7) and (not 7);\r
+{$endif}\r
+end;\r
+\r
+{ ===========================================================================\r
+ Copy a stored block, storing first the length and its\r
+ one's complement if requested. }\r
+\r
+{local}\r
+procedure copy_block(var s : deflate_state;\r
+ buf : pcharf; { the input data }\r
+ len : unsigned; { its length }\r
+ header : boolean); { true if block header must be written }\r
+begin\r
+ bi_windup(s); { align on byte boundary }\r
+ s.last_eob_len := 8; { enough lookahead for inflate }\r
+\r
+ if (header) then\r
+ begin\r
+ {put_short(s, (ush)len);}\r
+ s.pending_buf^[s.pending] := uch(ush(len) and $ff);\r
+ Inc(s.pending);\r
+ s.pending_buf^[s.pending] := uch(ush(len) shr 8);;\r
+ Inc(s.pending);\r
+ {put_short(s, (ush)~len);}\r
+ s.pending_buf^[s.pending] := uch(ush(not len) and $ff);\r
+ Inc(s.pending);\r
+ s.pending_buf^[s.pending] := uch(ush(not len) shr 8);;\r
+ Inc(s.pending);\r
+\r
+{$ifdef DEBUG}\r
+ Inc(s.bits_sent, 2*16);\r
+{$endif}\r
+ end;\r
+{$ifdef DEBUG}\r
+ Inc(s.bits_sent, ulg(len shl 3));\r
+{$endif}\r
+ while (len <> 0) do\r
+ begin\r
+ Dec(len);\r
+ {put_byte(s, *buf++);}\r
+ s.pending_buf^[s.pending] := buf^;\r
+ Inc(buf);\r
+ Inc(s.pending);\r
+ end;\r
+end;\r
+\r
+\r
+{ ===========================================================================\r
+ Send a stored block }\r
+\r
+procedure _tr_stored_block(var s : deflate_state;\r
+ buf : pcharf; { input block }\r
+ stored_len : ulg; { length of input block }\r
+ eof : boolean); { true if this is the last block for a file }\r
+\r
+begin\r
+ send_bits(s, (STORED_BLOCK shl 1)+ord(eof), 3); { send block type }\r
+ s.compressed_len := (s.compressed_len + 3 + 7) and ulg(not Long(7));\r
+ Inc(s.compressed_len, (stored_len + 4) shl 3);\r
+\r
+ copy_block(s, buf, unsigned(stored_len), TRUE); { with header }\r
+end;\r
+\r
+{ ===========================================================================\r
+ Flush the bit buffer, keeping at most 7 bits in it. }\r
+\r
+{local}\r
+procedure bi_flush(var s : deflate_state);\r
+begin\r
+ if (s.bi_valid = 16) then\r
+ begin\r
+ {put_short(s, s.bi_buf);}\r
+ s.pending_buf^[s.pending] := uch(s.bi_buf and $ff);\r
+ Inc(s.pending);\r
+ s.pending_buf^[s.pending] := uch(ush(s.bi_buf) shr 8);;\r
+ Inc(s.pending);\r
+\r
+ s.bi_buf := 0;\r
+ s.bi_valid := 0;\r
+ end\r
+ else\r
+ if (s.bi_valid >= 8) then\r
+ begin\r
+ {put_byte(s, (Byte)s^.bi_buf);}\r
+ s.pending_buf^[s.pending] := Byte(s.bi_buf);\r
+ Inc(s.pending);\r
+\r
+ s.bi_buf := s.bi_buf shr 8;\r
+ Dec(s.bi_valid, 8);\r
+ end;\r
+end;\r
+\r
+\r
+{ ===========================================================================\r
+ Send one empty static block to give enough lookahead for inflate.\r
+ This takes 10 bits, of which 7 may remain in the bit buffer.\r
+ The current inflate code requires 9 bits of lookahead. If the\r
+ last two codes for the previous block (real code plus EOB) were coded\r
+ on 5 bits or less, inflate may have only 5+3 bits of lookahead to decode\r
+ the last real code. In this case we send two empty static blocks instead\r
+ of one. (There are no problems if the previous block is stored or fixed.)\r
+ To simplify the code, we assume the worst case of last real code encoded\r
+ on one bit only. }\r
+\r
+procedure _tr_align(var s : deflate_state);\r
+begin\r
+ send_bits(s, STATIC_TREES shl 1, 3);\r
+ {$ifdef DEBUG}\r
+ Tracevvv(#13'cd '+IntToStr(END_BLOCK));\r
+ {$ENDIF}\r
+ send_bits(s, static_ltree[END_BLOCK].fc.Code, static_ltree[END_BLOCK].dl.Len);\r
+ Inc(s.compressed_len, Long(10)); { 3 for block type, 7 for EOB }\r
+ bi_flush(s);\r
+ { Of the 10 bits for the empty block, we have already sent\r
+ (10 - bi_valid) bits. The lookahead for the last real code (before\r
+ the EOB of the previous block) was thus at least one plus the length\r
+ of the EOB plus what we have just sent of the empty static block. }\r
+ if (1 + s.last_eob_len + 10 - s.bi_valid < 9) then\r
+ begin\r
+ send_bits(s, STATIC_TREES shl 1, 3);\r
+ {$ifdef DEBUG}\r
+ Tracevvv(#13'cd '+IntToStr(END_BLOCK));\r
+ {$ENDIF}\r
+ send_bits(s, static_ltree[END_BLOCK].fc.Code, static_ltree[END_BLOCK].dl.Len);\r
+ Inc(s.compressed_len, Long(10));\r
+ bi_flush(s);\r
+ end;\r
+ s.last_eob_len := 7;\r
+end;\r
+\r
+{ ===========================================================================\r
+ Set the data type to ASCII or BINARY, using a crude approximation:\r
+ binary if more than 20% of the bytes are <= 6 or >= 128, ascii otherwise.\r
+ IN assertion: the fields freq of dyn_ltree are set and the total of all\r
+ frequencies does not exceed 64K (to fit in an int on 16 bit machines). }\r
+\r
+{local}\r
+procedure set_data_type(var s : deflate_state);\r
+var\r
+ n : int;\r
+ ascii_freq : unsigned;\r
+ bin_freq : unsigned;\r
+begin\r
+ n := 0;\r
+ ascii_freq := 0;\r
+ bin_freq := 0;\r
+\r
+ while (n < 7) do\r
+ begin\r
+ Inc(bin_freq, s.dyn_ltree[n].fc.Freq);\r
+ Inc(n);\r
+ end;\r
+ while (n < 128) do\r
+ begin\r
+ Inc(ascii_freq, s.dyn_ltree[n].fc.Freq);\r
+ Inc(n);\r
+ end;\r
+ while (n < LITERALS) do\r
+ begin\r
+ Inc(bin_freq, s.dyn_ltree[n].fc.Freq);\r
+ Inc(n);\r
+ end;\r
+ if (bin_freq > (ascii_freq shr 2)) then\r
+ s.data_type := Byte(Z_BINARY)\r
+ else\r
+ s.data_type := Byte(Z_ASCII);\r
+end;\r
+\r
+{ ===========================================================================\r
+ Send the block data compressed using the given Huffman trees }\r
+\r
+{local}\r
+procedure compress_block(var s : deflate_state;\r
+ var ltree : array of ct_data; { literal tree }\r
+ var dtree : array of ct_data); { distance tree }\r
+var\r
+ dist : unsigned; { distance of matched string }\r
+ lc : int; { match length or unmatched char (if dist == 0) }\r
+ lx : unsigned; { running index in l_buf }\r
+ code : unsigned; { the code to send }\r
+ extra : int; { number of extra bits to send }\r
+begin\r
+ lx := 0;\r
+ if (s.last_lit <> 0) then\r
+ repeat\r
+ dist := s.d_buf^[lx];\r
+ lc := s.l_buf^[lx];\r
+ Inc(lx);\r
+ if (dist = 0) then\r
+ begin\r
+ { send a literal byte }\r
+ {$ifdef DEBUG}\r
+ Tracevvv(#13'cd '+IntToStr(lc));\r
+ Tracecv((lc > 31) and (lc < 128), ' '+char(lc)+' ');\r
+ {$ENDIF}\r
+ send_bits(s, ltree[lc].fc.Code, ltree[lc].dl.Len);\r
+ end\r
+ else\r
+ begin\r
+ { Here, lc is the match length - MIN_MATCH }\r
+ code := _length_code[lc];\r
+ { send the length code }\r
+ {$ifdef DEBUG}\r
+ Tracevvv(#13'cd '+IntToStr(code+LITERALS+1));\r
+ {$ENDIF}\r
+ send_bits(s, ltree[code+LITERALS+1].fc.Code, ltree[code+LITERALS+1].dl.Len);\r
+ extra := extra_lbits[code];\r
+ if (extra <> 0) then\r
+ begin\r
+ Dec(lc, base_length[code]);\r
+ send_bits(s, lc, extra); { send the extra length bits }\r
+ end;\r
+ Dec(dist); { dist is now the match distance - 1 }\r
+ {code := d_code(dist);}\r
+ if (dist < 256) then\r
+ code := _dist_code[dist]\r
+ else\r
+ code := _dist_code[256+(dist shr 7)];\r
+\r
+ {$IFDEF DEBUG}\r
+ Assert (code < D_CODES, 'bad d_code');\r
+ {$ENDIF}\r
+\r
+ { send the distance code }\r
+ {$ifdef DEBUG}\r
+ Tracevvv(#13'cd '+IntToStr(code));\r
+ {$ENDIF}\r
+ send_bits(s, dtree[code].fc.Code, dtree[code].dl.Len);\r
+ extra := extra_dbits[code];\r
+ if (extra <> 0) then\r
+ begin\r
+ Dec(dist, base_dist[code]);\r
+ send_bits(s, dist, extra); { send the extra distance bits }\r
+ end;\r
+ end; { literal or match pair ? }\r
+\r
+ { Check that the overlay between pending_buf and d_buf+l_buf is ok: }\r
+ {$IFDEF DEBUG}\r
+ Assert(s.pending < s.lit_bufsize + 2*lx, 'pendingBuf overflow');\r
+ {$ENDIF}\r
+ until (lx >= s.last_lit);\r
+\r
+ {$ifdef DEBUG}\r
+ Tracevvv(#13'cd '+IntToStr(END_BLOCK));\r
+ {$ENDIF}\r
+ send_bits(s, ltree[END_BLOCK].fc.Code, ltree[END_BLOCK].dl.Len);\r
+ s.last_eob_len := ltree[END_BLOCK].dl.Len;\r
+end;\r
+\r
+\r
+{ ===========================================================================\r
+ Determine the best encoding for the current block: dynamic trees, static\r
+ trees or store, and output the encoded block to the zip file. This function\r
+ returns the total compressed length for the file so far. }\r
+\r
+function _tr_flush_block (var s : deflate_state;\r
+ buf : pcharf; { input block, or NULL if too old }\r
+ stored_len : ulg; { length of input block }\r
+ eof : boolean) : ulg; { true if this is the last block for a file }\r
+var\r
+ opt_lenb, static_lenb : ulg; { opt_len and static_len in bytes }\r
+ max_blindex : int; { index of last bit length code of non zero freq }\r
+begin\r
+ max_blindex := 0;\r
+\r
+ { Build the Huffman trees unless a stored block is forced }\r
+ if (s.level > 0) then\r
+ begin\r
+ { Check if the file is ascii or binary }\r
+ if (s.data_type = Z_UNKNOWN) then\r
+ set_data_type(s);\r
+\r
+ { Construct the literal and distance trees }\r
+ build_tree(s, s.l_desc);\r
+ {$ifdef DEBUG}\r
+ Tracev(^M'lit data: dyn %ld, stat %ld {s.opt_len, s.static_len}');\r
+ {$ENDIF}\r
+\r
+ build_tree(s, s.d_desc);\r
+ {$ifdef DEBUG}\r
+ Tracev(^M'dist data: dyn %ld, stat %ld {s.opt_len, s.static_len}');\r
+ {$ENDIF}\r
+ { At this point, opt_len and static_len are the total bit lengths of\r
+ the compressed block data, excluding the tree representations. }\r
+\r
+ { Build the bit length tree for the above two trees, and get the index\r
+ in bl_order of the last bit length code to send. }\r
+ max_blindex := build_bl_tree(s);\r
+\r
+ { Determine the best encoding. Compute first the block length in bytes}\r
+ opt_lenb := (s.opt_len+3+7) shr 3;\r
+ static_lenb := (s.static_len+3+7) shr 3;\r
+\r
+ {$ifdef DEBUG}\r
+ Tracev(^M'opt %lu(%lu) stat %lu(%lu) stored %lu lit %u '+\r
+ '{opt_lenb, s.opt_len, static_lenb, s.static_len, stored_len,'+\r
+ 's.last_lit}');\r
+ {$ENDIF}\r
+\r
+ if (static_lenb <= opt_lenb) then\r
+ opt_lenb := static_lenb;\r
+\r
+ end\r
+ else\r
+ begin\r
+ {$IFDEF DEBUG}\r
+ Assert(buf <> pcharf(NIL), 'lost buf');\r
+ {$ENDIF}\r
+ static_lenb := stored_len + 5;\r
+ opt_lenb := static_lenb; { force a stored block }\r
+ end;\r
+\r
+ { If compression failed and this is the first and last block,\r
+ and if the .zip file can be seeked (to rewrite the local header),\r
+ the whole file is transformed into a stored file: }\r
+\r
+{$ifdef STORED_FILE_OK}\r
+{$ifdef FORCE_STORED_FILE}\r
+ if eof and (s.compressed_len = Long(0)) then\r
+ begin { force stored file }\r
+{$else}\r
+ if (stored_len <= opt_lenb) and eof and (s.compressed_len=Long(0))\r
+ and seekable()) do\r
+ begin\r
+{$endif}\r
+ { Since LIT_BUFSIZE <= 2*WSIZE, the input data must be there: }\r
+ if (buf = pcharf(0)) then\r
+ error ('block vanished');\r
+\r
+ copy_block(buf, unsigned(stored_len), 0); { without header }\r
+ s.compressed_len := stored_len shl 3;\r
+ s.method := STORED;\r
+ end\r
+ else\r
+{$endif} { STORED_FILE_OK }\r
+\r
+{$ifdef FORCE_STORED}\r
+ if (buf <> pchar(0)) then\r
+ begin { force stored block }\r
+{$else}\r
+ if (stored_len+4 <= opt_lenb) and (buf <> pcharf(0)) then\r
+ begin\r
+ { 4: two words for the lengths }\r
+{$endif}\r
+ { The test buf <> NULL is only necessary if LIT_BUFSIZE > WSIZE.\r
+ Otherwise we can't have processed more than WSIZE input bytes since\r
+ the last block flush, because compression would have been\r
+ successful. If LIT_BUFSIZE <= WSIZE, it is never too late to\r
+ transform a block into a stored block. }\r
+\r
+ _tr_stored_block(s, buf, stored_len, eof);\r
+\r
+{$ifdef FORCE_STATIC}\r
+ end\r
+ else\r
+ if (static_lenb >= 0) then\r
+ begin { force static trees }\r
+{$else}\r
+ end\r
+ else\r
+ if (static_lenb = opt_lenb) then\r
+ begin\r
+{$endif}\r
+ send_bits(s, (STATIC_TREES shl 1)+ord(eof), 3);\r
+ compress_block(s, static_ltree, static_dtree);\r
+ Inc(s.compressed_len, 3 + s.static_len);\r
+ end\r
+ else\r
+ begin\r
+ send_bits(s, (DYN_TREES shl 1)+ord(eof), 3);\r
+ send_all_trees(s, s.l_desc.max_code+1, s.d_desc.max_code+1,\r
+ max_blindex+1);\r
+ compress_block(s, s.dyn_ltree, s.dyn_dtree);\r
+ Inc(s.compressed_len, 3 + s.opt_len);\r
+ end;\r
+ {$ifdef DEBUG}\r
+ Assert (s.compressed_len = s.bits_sent, 'bad compressed size');\r
+ {$ENDIF}\r
+ init_block(s);\r
+\r
+ if (eof) then\r
+ begin\r
+ bi_windup(s);\r
+ Inc(s.compressed_len, 7); { align on byte boundary }\r
+ end;\r
+ {$ifdef DEBUG}\r
+ Tracev(#13'comprlen %lu(%lu) {s.compressed_len shr 3,'+\r
+ 's.compressed_len-7*ord(eof)}');\r
+ {$ENDIF}\r
+\r
+ _tr_flush_block := s.compressed_len shr 3;\r
+end;\r
+\r
+\r
+{ ===========================================================================\r
+ Save the match info and tally the frequency counts. Return true if\r
+ the current block must be flushed. }\r
+\r
+function _tr_tally (var s : deflate_state;\r
+ dist : unsigned; { distance of matched string }\r
+ lc : unsigned) : boolean; { match length-MIN_MATCH or unmatched char (if dist=0) }\r
+var\r
+ {$IFDEF DEBUG}\r
+ MAX_DIST : ush;\r
+ {$ENDIF}\r
+ code : ush;\r
+{$ifdef TRUNCATE_BLOCK}\r
+var\r
+ out_length : ulg;\r
+ in_length : ulg;\r
+ dcode : int;\r
+{$endif}\r
+begin\r
+ s.d_buf^[s.last_lit] := ush(dist);\r
+ s.l_buf^[s.last_lit] := uch(lc);\r
+ Inc(s.last_lit);\r
+ if (dist = 0) then\r
+ begin\r
+ { lc is the unmatched char }\r
+ Inc(s.dyn_ltree[lc].fc.Freq);\r
+ end\r
+ else\r
+ begin\r
+ Inc(s.matches);\r
+ { Here, lc is the match length - MIN_MATCH }\r
+ Dec(dist); { dist := match distance - 1 }\r
+\r
+ {macro d_code(dist)}\r
+ if (dist) < 256 then\r
+ code := _dist_code[dist]\r
+ else\r
+ code := _dist_code[256+(dist shr 7)];\r
+ {$IFDEF DEBUG}\r
+{macro MAX_DIST(s) <=> ((s)^.w_size-MIN_LOOKAHEAD)\r
+ In order to simplify the code, particularly on 16 bit machines, match\r
+ distances are limited to MAX_DIST instead of WSIZE. }\r
+ MAX_DIST := ush(s.w_size-MIN_LOOKAHEAD);\r
+ Assert((dist < ush(MAX_DIST)) and\r
+ (ush(lc) <= ush(MAX_MATCH-MIN_MATCH)) and\r
+ (ush(code) < ush(D_CODES)), '_tr_tally: bad match');\r
+ {$ENDIF}\r
+ Inc(s.dyn_ltree[_length_code[lc]+LITERALS+1].fc.Freq);\r
+ {s.dyn_dtree[d_code(dist)].Freq++;}\r
+ Inc(s.dyn_dtree[code].fc.Freq);\r
+ end;\r
+\r
+{$ifdef TRUNCATE_BLOCK}\r
+ { Try to guess if it is profitable to stop the current block here }\r
+ if (s.last_lit and $1fff = 0) and (s.level > 2) then\r
+ begin\r
+ { Compute an upper bound for the compressed length }\r
+ out_length := ulg(s.last_lit)*Long(8);\r
+ in_length := ulg(long(s.strstart) - s.block_start);\r
+ for dcode := 0 to D_CODES-1 do\r
+ begin\r
+ Inc(out_length, ulg(s.dyn_dtree[dcode].fc.Freq *\r
+ (Long(5)+extra_dbits[dcode])) );\r
+ end;\r
+ out_length := out_length shr 3;\r
+ {$ifdef DEBUG}\r
+ Tracev(^M'last_lit %u, in %ld, out ~%ld(%ld%%) ');\r
+ { s.last_lit, in_length, out_length,\r
+ Long(100) - out_length*Long(100) div in_length)); }\r
+ {$ENDIF}\r
+ if (s.matches < s.last_lit div 2) and (out_length < in_length div 2) then\r
+ begin\r
+ _tr_tally := TRUE;\r
+ exit;\r
+ end;\r
+ end;\r
+{$endif}\r
+ _tr_tally := (s.last_lit = s.lit_bufsize-1);\r
+ { We avoid equality with lit_bufsize because of wraparound at 64K\r
+ on 16 bit machines and because stored blocks are restricted to\r
+ 64K-1 bytes. }\r
+end;\r
+\r
+end.
\ No newline at end of file
--- /dev/null
+type\r
+ {delphi 3 and before do not have a 32 bits unsigned integer type,\r
+ but longint has the correct behavior - it doesn't on newer delphi versions}\r
+ {$ifndef fpc}\r
+ {$ifdef ver70}{$define pred4}{$endif} {tp7}\r
+ {$ifdef ver80}{$define pred4}{$endif} {delphi 1}\r
+ {$ifdef ver90}{$define pred4}{$endif} {delphi 2}\r
+ {$ifdef ver100}{$define pred4}{$endif} {delphi 3}\r
+ {$endif}\r
+ uint32={$ifdef pred4}longint{$else}longword{$endif};\r
--- /dev/null
+{ -------------------------------------------------------------------- }\r
+\r
+{$DEFINE MAX_MATCH_IS_258}\r
+\r
+{ Compile with -DMAXSEG_64K if the alloc function cannot allocate more\r
+ than 64k bytes at a time (needed on systems with 16-bit int). }\r
+\r
+{- $DEFINE MAXSEG_64K}\r
+{$IFDEF VER70}\r
+ {$DEFINE MAXSEG_64K}\r
+{$ENDIF}\r
+{$IFNDEF WIN32}\r
+ {$DEFINE UNALIGNED_OK} { requires SizeOf(ush) = 2 ! }\r
+{$ENDIF}\r
+\r
+{$UNDEF DYNAMIC_CRC_TABLE}\r
+{$UNDEF FASTEST}\r
+{$define patch112} { apply patch from the zlib home page }\r
+{ -------------------------------------------------------------------- }\r
+{$IFDEF WIN32}\r
+ {$DEFINE Delphi32}\r
+ {- $DEFINE Delphi5} { keep compiler quiet }\r
+{$ENDIF}\r
+\r
+{$IFDEF DPMI}\r
+ {$DEFINE MSDOS}\r
+{$ENDIF}\r
+\r
+{$IFDEF FPC}\r
+ {$DEFINE Use32}\r
+ {$UNDEF DPMI}\r
+ {$UNDEF MSDOS}\r
+ {$UNDEF UNALIGNED_OK} { requires SizeOf(ush) = 2 ! }\r
+ {$UNDEF MAXSEG_64K}\r
+ {$UNDEF Delphi32}\r
+{$ENDIF}\r
--- /dev/null
+Unit zDeflate;\r
+\r
+{ Orginal: deflate.h -- internal compression state\r
+ deflate.c -- compress data using the deflation algorithm\r
+ Copyright (C) 1995-1996 Jean-loup Gailly.\r
+\r
+ Pascal tranlastion\r
+ Copyright (C) 1998 by Jacques Nomssi Nzali\r
+ For conditions of distribution and use, see copyright notice in readme.paszlib\r
+}\r
+\r
+\r
+{ ALGORITHM\r
+\r
+ The "deflation" process depends on being able to identify portions\r
+ of the input text which are identical to earlier input (within a\r
+ sliding window trailing behind the input currently being processed).\r
+\r
+ The most straightforward technique turns out to be the fastest for\r
+ most input files: try all possible matches and select the longest.\r
+ The key feature of this algorithm is that insertions into the string\r
+ dictionary are very simple and thus fast, and deletions are avoided\r
+ completely. Insertions are performed at each input character, whereas\r
+ string matches are performed only when the previous match ends. So it\r
+ is preferable to spend more time in matches to allow very fast string\r
+ insertions and avoid deletions. The matching algorithm for small\r
+ strings is inspired from that of Rabin & Karp. A brute force approach\r
+ is used to find longer strings when a small match has been found.\r
+ A similar algorithm is used in comic (by Jan-Mark Wams) and freeze\r
+ (by Leonid Broukhis).\r
+ A previous version of this file used a more sophisticated algorithm\r
+ (by Fiala and Greene) which is guaranteed to run in linear amortized\r
+ time, but has a larger average cost, uses more memory and is patented.\r
+ However the F&G algorithm may be faster for some highly redundant\r
+ files if the parameter max_chain_length (described below) is too large.\r
+\r
+ ACKNOWLEDGEMENTS\r
+\r
+ The idea of lazy evaluation of matches is due to Jan-Mark Wams, and\r
+ I found it in 'freeze' written by Leonid Broukhis.\r
+ Thanks to many people for bug reports and testing.\r
+\r
+ REFERENCES\r
+\r
+ Deutsch, L.P.,"'Deflate' Compressed Data Format Specification".\r
+ Available in ftp.uu.net:/pub/archiving/zip/doc/deflate-1.1.doc\r
+\r
+ A description of the Rabin and Karp algorithm is given in the book\r
+ "Algorithms" by R. Sedgewick, Addison-Wesley, p252.\r
+\r
+ Fiala,E.R., and Greene,D.H.\r
+ Data Compression with Finite Windows, Comm.ACM, 32,4 (1989) 490-595}\r
+\r
+{ $Id: deflate.c,v 1.14 1996/07/02 12:40:55 me Exp $ }\r
+\r
+interface\r
+\r
+{$I zconf.inc}\r
+\r
+uses\r
+ zutil, zlib;\r
+\r
+\r
+function deflateInit_(strm : z_streamp;\r
+ level : int;\r
+ const version : string;\r
+ stream_size : int) : int;\r
+\r
+\r
+function deflateInit (var strm : z_stream; level : int) : int;\r
+\r
+{ Initializes the internal stream state for compression. The fields\r
+ zalloc, zfree and opaque must be initialized before by the caller.\r
+ If zalloc and zfree are set to Z_NULL, deflateInit updates them to\r
+ use default allocation functions.\r
+\r
+ The compression level must be Z_DEFAULT_COMPRESSION, or between 0 and 9:\r
+ 1 gives best speed, 9 gives best compression, 0 gives no compression at\r
+ all (the input data is simply copied a block at a time).\r
+ Z_DEFAULT_COMPRESSION requests a default compromise between speed and\r
+ compression (currently equivalent to level 6).\r
+\r
+ deflateInit returns Z_OK if success, Z_MEM_ERROR if there was not\r
+ enough memory, Z_STREAM_ERROR if level is not a valid compression level,\r
+ Z_VERSION_ERROR if the zlib library version (zlib_version) is incompatible\r
+ with the version assumed by the caller (ZLIB_VERSION).\r
+ msg is set to null if there is no error message. deflateInit does not\r
+ perform any compression: this will be done by deflate(). }\r
+\r
+\r
+{EXPORT}\r
+function deflate (var strm : z_stream; flush : int) : int;\r
+\r
+{ Performs one or both of the following actions:\r
+\r
+ - Compress more input starting at next_in and update next_in and avail_in\r
+ accordingly. If not all input can be processed (because there is not\r
+ enough room in the output buffer), next_in and avail_in are updated and\r
+ processing will resume at this point for the next call of deflate().\r
+\r
+ - Provide more output starting at next_out and update next_out and avail_out\r
+ accordingly. This action is forced if the parameter flush is non zero.\r
+ Forcing flush frequently degrades the compression ratio, so this parameter\r
+ should be set only when necessary (in interactive applications).\r
+ Some output may be provided even if flush is not set.\r
+\r
+ Before the call of deflate(), the application should ensure that at least\r
+ one of the actions is possible, by providing more input and/or consuming\r
+ more output, and updating avail_in or avail_out accordingly; avail_out\r
+ should never be zero before the call. The application can consume the\r
+ compressed output when it wants, for example when the output buffer is full\r
+ (avail_out == 0), or after each call of deflate(). If deflate returns Z_OK\r
+ and with zero avail_out, it must be called again after making room in the\r
+ output buffer because there might be more output pending.\r
+\r
+ If the parameter flush is set to Z_PARTIAL_FLUSH, the current compression\r
+ block is terminated and flushed to the output buffer so that the\r
+ decompressor can get all input data available so far. For method 9, a future\r
+ variant on method 8, the current block will be flushed but not terminated.\r
+ Z_SYNC_FLUSH has the same effect as partial flush except that the compressed\r
+ output is byte aligned (the compressor can clear its internal bit buffer)\r
+ and the current block is always terminated; this can be useful if the\r
+ compressor has to be restarted from scratch after an interruption (in which\r
+ case the internal state of the compressor may be lost).\r
+ If flush is set to Z_FULL_FLUSH, the compression block is terminated, a\r
+ special marker is output and the compression dictionary is discarded; this\r
+ is useful to allow the decompressor to synchronize if one compressed block\r
+ has been damaged (see inflateSync below). Flushing degrades compression and\r
+ so should be used only when necessary. Using Z_FULL_FLUSH too often can\r
+ seriously degrade the compression. If deflate returns with avail_out == 0,\r
+ this function must be called again with the same value of the flush\r
+ parameter and more output space (updated avail_out), until the flush is\r
+ complete (deflate returns with non-zero avail_out).\r
+\r
+ If the parameter flush is set to Z_FINISH, all pending input is processed,\r
+ all pending output is flushed and deflate returns with Z_STREAM_END if there\r
+ was enough output space; if deflate returns with Z_OK, this function must be\r
+ called again with Z_FINISH and more output space (updated avail_out) but no\r
+ more input data, until it returns with Z_STREAM_END or an error. After\r
+ deflate has returned Z_STREAM_END, the only possible operations on the\r
+ stream are deflateReset or deflateEnd.\r
+\r
+ Z_FINISH can be used immediately after deflateInit if all the compression\r
+ is to be done in a single step. In this case, avail_out must be at least\r
+ 0.1% larger than avail_in plus 12 bytes. If deflate does not return\r
+ Z_STREAM_END, then it must be called again as described above.\r
+\r
+ deflate() may update data_type if it can make a good guess about\r
+ the input data type (Z_ASCII or Z_BINARY). In doubt, the data is considered\r
+ binary. This field is only for information purposes and does not affect\r
+ the compression algorithm in any manner.\r
+\r
+ deflate() returns Z_OK if some progress has been made (more input\r
+ processed or more output produced), Z_STREAM_END if all input has been\r
+ consumed and all output has been produced (only when flush is set to\r
+ Z_FINISH), Z_STREAM_ERROR if the stream state was inconsistent (for example\r
+ if next_in or next_out was NULL), Z_BUF_ERROR if no progress is possible. }\r
+\r
+\r
+function deflateEnd (var strm : z_stream) : int;\r
+\r
+{ All dynamically allocated data structures for this stream are freed.\r
+ This function discards any unprocessed input and does not flush any\r
+ pending output.\r
+\r
+ deflateEnd returns Z_OK if success, Z_STREAM_ERROR if the\r
+ stream state was inconsistent, Z_DATA_ERROR if the stream was freed\r
+ prematurely (some input or output was discarded). In the error case,\r
+ msg may be set but then points to a static string (which must not be\r
+ deallocated). }\r
+\r
+\r
+\r
+\r
+ { Advanced functions }\r
+\r
+{ The following functions are needed only in some special applications. }\r
+\r
+\r
+{EXPORT}\r
+function deflateInit2 (var strm : z_stream;\r
+ level : int;\r
+ method : int;\r
+ windowBits : int;\r
+ memLevel : int;\r
+ strategy : int) : int;\r
+\r
+{ This is another version of deflateInit with more compression options. The\r
+ fields next_in, zalloc, zfree and opaque must be initialized before by\r
+ the caller.\r
+\r
+ The method parameter is the compression method. It must be Z_DEFLATED in\r
+ this version of the library. (Method 9 will allow a 64K history buffer and\r
+ partial block flushes.)\r
+\r
+ The windowBits parameter is the base two logarithm of the window size\r
+ (the size of the history buffer). It should be in the range 8..15 for this\r
+ version of the library (the value 16 will be allowed for method 9). Larger\r
+ values of this parameter result in better compression at the expense of\r
+ memory usage. The default value is 15 if deflateInit is used instead.\r
+\r
+ The memLevel parameter specifies how much memory should be allocated\r
+ for the internal compression state. memLevel=1 uses minimum memory but\r
+ is slow and reduces compression ratio; memLevel=9 uses maximum memory\r
+ for optimal speed. The default value is 8. See zconf.h for total memory\r
+ usage as a function of windowBits and memLevel.\r
+\r
+ The strategy parameter is used to tune the compression algorithm. Use the\r
+ value Z_DEFAULT_STRATEGY for normal data, Z_FILTERED for data produced by a\r
+ filter (or predictor), or Z_HUFFMAN_ONLY to force Huffman encoding only (no\r
+ string match). Filtered data consists mostly of small values with a\r
+ somewhat random distribution. In this case, the compression algorithm is\r
+ tuned to compress them better. The effect of Z_FILTERED is to force more\r
+ Huffman coding and less string matching; it is somewhat intermediate\r
+ between Z_DEFAULT and Z_HUFFMAN_ONLY. The strategy parameter only affects\r
+ the compression ratio but not the correctness of the compressed output even\r
+ if it is not set appropriately.\r
+\r
+ If next_in is not null, the library will use this buffer to hold also\r
+ some history information; the buffer must either hold the entire input\r
+ data, or have at least 1<<(windowBits+1) bytes and be writable. If next_in\r
+ is null, the library will allocate its own history buffer (and leave next_in\r
+ null). next_out need not be provided here but must be provided by the\r
+ application for the next call of deflate().\r
+\r
+ If the history buffer is provided by the application, next_in must\r
+ must never be changed by the application since the compressor maintains\r
+ information inside this buffer from call to call; the application\r
+ must provide more input only by increasing avail_in. next_in is always\r
+ reset by the library in this case.\r
+\r
+ deflateInit2 returns Z_OK if success, Z_MEM_ERROR if there was\r
+ not enough memory, Z_STREAM_ERROR if a parameter is invalid (such as\r
+ an invalid method). msg is set to null if there is no error message.\r
+ deflateInit2 does not perform any compression: this will be done by\r
+ deflate(). }\r
+\r
+\r
+{EXPORT}\r
+function deflateSetDictionary (var strm : z_stream;\r
+ dictionary : pBytef; {const bytes}\r
+ dictLength : uint) : int;\r
+\r
+{ Initializes the compression dictionary (history buffer) from the given\r
+ byte sequence without producing any compressed output. This function must\r
+ be called immediately after deflateInit or deflateInit2, before any call\r
+ of deflate. The compressor and decompressor must use exactly the same\r
+ dictionary (see inflateSetDictionary).\r
+ The dictionary should consist of strings (byte sequences) that are likely\r
+ to be encountered later in the data to be compressed, with the most commonly\r
+ used strings preferably put towards the end of the dictionary. Using a\r
+ dictionary is most useful when the data to be compressed is short and\r
+ can be predicted with good accuracy; the data can then be compressed better\r
+ than with the default empty dictionary. In this version of the library,\r
+ only the last 32K bytes of the dictionary are used.\r
+ Upon return of this function, strm->adler is set to the Adler32 value\r
+ of the dictionary; the decompressor may later use this value to determine\r
+ which dictionary has been used by the compressor. (The Adler32 value\r
+ applies to the whole dictionary even if only a subset of the dictionary is\r
+ actually used by the compressor.)\r
+\r
+ deflateSetDictionary returns Z_OK if success, or Z_STREAM_ERROR if a\r
+ parameter is invalid (such as NULL dictionary) or the stream state\r
+ is inconsistent (for example if deflate has already been called for this\r
+ stream). deflateSetDictionary does not perform any compression: this will\r
+ be done by deflate(). }\r
+\r
+{EXPORT}\r
+function deflateCopy (dest : z_streamp;\r
+ source : z_streamp) : int;\r
+\r
+{ Sets the destination stream as a complete copy of the source stream. If\r
+ the source stream is using an application-supplied history buffer, a new\r
+ buffer is allocated for the destination stream. The compressed output\r
+ buffer is always application-supplied. It's the responsibility of the\r
+ application to provide the correct values of next_out and avail_out for the\r
+ next call of deflate.\r
+\r
+ This function can be useful when several compression strategies will be\r
+ tried, for example when there are several ways of pre-processing the input\r
+ data with a filter. The streams that will be discarded should then be freed\r
+ by calling deflateEnd. Note that deflateCopy duplicates the internal\r
+ compression state which can be quite large, so this strategy is slow and\r
+ can consume lots of memory.\r
+\r
+ deflateCopy returns Z_OK if success, Z_MEM_ERROR if there was not\r
+ enough memory, Z_STREAM_ERROR if the source stream state was inconsistent\r
+ (such as zalloc being NULL). msg is left unchanged in both source and\r
+ destination. }\r
+\r
+{EXPORT}\r
+function deflateReset (var strm : z_stream) : int;\r
+\r
+{ This function is equivalent to deflateEnd followed by deflateInit,\r
+ but does not free and reallocate all the internal compression state.\r
+ The stream will keep the same compression level and any other attributes\r
+ that may have been set by deflateInit2.\r
+\r
+ deflateReset returns Z_OK if success, or Z_STREAM_ERROR if the source\r
+ stream state was inconsistent (such as zalloc or state being NIL). }\r
+\r
+\r
+{EXPORT}\r
+function deflateParams (var strm : z_stream; level : int; strategy : int) : int;\r
+\r
+{ Dynamically update the compression level and compression strategy.\r
+ This can be used to switch between compression and straight copy of\r
+ the input data, or to switch to a different kind of input data requiring\r
+ a different strategy. If the compression level is changed, the input\r
+ available so far is compressed with the old level (and may be flushed);\r
+ the new level will take effect only at the next call of deflate().\r
+\r
+ Before the call of deflateParams, the stream state must be set as for\r
+ a call of deflate(), since the currently available input may have to\r
+ be compressed and flushed. In particular, strm->avail_out must be non-zero.\r
+\r
+ deflateParams returns Z_OK if success, Z_STREAM_ERROR if the source\r
+ stream state was inconsistent or if a parameter was invalid, Z_BUF_ERROR\r
+ if strm->avail_out was zero. }\r
+\r
+\r
+const\r
+ deflate_copyright : string = ' deflate 1.1.2 Copyright 1995-1998 Jean-loup Gailly ';\r
+\r
+{ If you use the zlib library in a product, an acknowledgment is welcome\r
+ in the documentation of your product. If for some reason you cannot\r
+ include such an acknowledgment, I would appreciate that you keep this\r
+ copyright string in the executable of your product. }\r
+\r
+implementation\r
+\r
+uses\r
+ trees, adler;\r
+\r
+{ ===========================================================================\r
+ Function prototypes. }\r
+\r
+type\r
+ block_state = (\r
+ need_more, { block not completed, need more input or more output }\r
+ block_done, { block flush performed }\r
+ finish_started, { finish started, need only more output at next deflate }\r
+ finish_done); { finish done, accept no more input or output }\r
+\r
+{ Compression function. Returns the block state after the call. }\r
+type\r
+ compress_func = function(var s : deflate_state; flush : int) : block_state;\r
+\r
+{local}\r
+procedure fill_window(var s : deflate_state); forward;\r
+{local}\r
+function deflate_stored(var s : deflate_state; flush : int) : block_state; far; forward;\r
+{local}\r
+function deflate_fast(var s : deflate_state; flush : int) : block_state; far; forward;\r
+{local}\r
+function deflate_slow(var s : deflate_state; flush : int) : block_state; far; forward;\r
+{local}\r
+procedure lm_init(var s : deflate_state); forward;\r
+\r
+{local}\r
+procedure putShortMSB(var s : deflate_state; b : uInt); forward;\r
+{local}\r
+procedure flush_pending (var strm : z_stream); forward;\r
+{local}\r
+function read_buf(strm : z_streamp;\r
+ buf : pBytef;\r
+ size : unsigned) : int; forward;\r
+{$ifdef ASMV}\r
+procedure match_init; { asm code initialization }\r
+function longest_match(var deflate_state; cur_match : IPos) : uInt; forward;\r
+{$else}\r
+{local}\r
+function longest_match(var s : deflate_state; cur_match : IPos) : uInt;\r
+ forward;\r
+{$endif}\r
+\r
+{$ifdef DEBUG}\r
+{local}\r
+procedure check_match(var s : deflate_state;\r
+ start, match : IPos;\r
+ length : int); forward;\r
+{$endif}\r
+\r
+{ ==========================================================================\r
+ local data }\r
+\r
+const\r
+ ZNIL = 0;\r
+{ Tail of hash chains }\r
+\r
+const\r
+ TOO_FAR = 4096;\r
+{ Matches of length 3 are discarded if their distance exceeds TOO_FAR }\r
+\r
+const\r
+ MIN_LOOKAHEAD = (MAX_MATCH+MIN_MATCH+1);\r
+{ Minimum amount of lookahead, except at the end of the input file.\r
+ See deflate.c for comments about the MIN_MATCH+1. }\r
+\r
+{macro MAX_DIST(var s : deflate_state) : uInt;\r
+begin\r
+ MAX_DIST := (s.w_size - MIN_LOOKAHEAD);\r
+end;\r
+ In order to simplify the code, particularly on 16 bit machines, match\r
+ distances are limited to MAX_DIST instead of WSIZE. }\r
+\r
+\r
+{ Values for max_lazy_match, good_match and max_chain_length, depending on\r
+ the desired pack level (0..9). The values given below have been tuned to\r
+ exclude worst case performance for pathological files. Better values may be\r
+ found for specific files. }\r
+\r
+type\r
+ config = record\r
+ good_length : ush; { reduce lazy search above this match length }\r
+ max_lazy : ush; { do not perform lazy search above this match length }\r
+ nice_length : ush; { quit search above this match length }\r
+ max_chain : ush;\r
+ func : compress_func;\r
+ end;\r
+\r
+{local}\r
+const\r
+ configuration_table : array[0..10-1] of config = (\r
+{ good lazy nice chain }\r
+{0} (good_length:0; max_lazy:0; nice_length:0; max_chain:0; func:deflate_stored), { store only }\r
+{1} (good_length:4; max_lazy:4; nice_length:8; max_chain:4; func:deflate_fast), { maximum speed, no lazy matches }\r
+{2} (good_length:4; max_lazy:5; nice_length:16; max_chain:8; func:deflate_fast),\r
+{3} (good_length:4; max_lazy:6; nice_length:32; max_chain:32; func:deflate_fast),\r
+\r
+{4} (good_length:4; max_lazy:4; nice_length:16; max_chain:16; func:deflate_slow), { lazy matches }\r
+{5} (good_length:8; max_lazy:16; nice_length:32; max_chain:32; func:deflate_slow),\r
+{6} (good_length:8; max_lazy:16; nice_length:128; max_chain:128; func:deflate_slow),\r
+{7} (good_length:8; max_lazy:32; nice_length:128; max_chain:256; func:deflate_slow),\r
+{8} (good_length:32; max_lazy:128; nice_length:258; max_chain:1024; func:deflate_slow),\r
+{9} (good_length:32; max_lazy:258; nice_length:258; max_chain:4096; func:deflate_slow)); { maximum compression }\r
+\r
+{ Note: the deflate() code requires max_lazy >= MIN_MATCH and max_chain >= 4\r
+ For deflate_fast() (levels <= 3) good is ignored and lazy has a different\r
+ meaning. }\r
+\r
+const\r
+ EQUAL = 0;\r
+{ result of memcmp for equal strings }\r
+\r
+{ ==========================================================================\r
+ Update a hash value with the given input byte\r
+ IN assertion: all calls to to UPDATE_HASH are made with consecutive\r
+ input characters, so that a running hash key can be computed from the\r
+ previous key instead of complete recalculation each time.\r
+\r
+macro UPDATE_HASH(s,h,c)\r
+ h := (( (h) shl s^.hash_shift) xor (c)) and s^.hash_mask;\r
+}\r
+\r
+{ ===========================================================================\r
+ Insert string str in the dictionary and set match_head to the previous head\r
+ of the hash chain (the most recent string with same hash key). Return\r
+ the previous length of the hash chain.\r
+ If this file is compiled with -DFASTEST, the compression level is forced\r
+ to 1, and no hash chains are maintained.\r
+ IN assertion: all calls to to INSERT_STRING are made with consecutive\r
+ input characters and the first MIN_MATCH bytes of str are valid\r
+ (except for the last MIN_MATCH-1 bytes of the input file). }\r
+\r
+procedure INSERT_STRING(var s : deflate_state;\r
+ str : uInt;\r
+ var match_head : IPos);\r
+begin\r
+{$ifdef FASTEST}\r
+ {UPDATE_HASH(s, s.ins_h, s.window[(str) + (MIN_MATCH-1)])}\r
+ s.ins_h := ((s.ins_h shl s.hash_shift) xor\r
+ (s.window^[(str) + (MIN_MATCH-1)])) and s.hash_mask;\r
+ match_head := s.head[s.ins_h]\r
+ s.head[s.ins_h] := Pos(str);\r
+{$else}\r
+ {UPDATE_HASH(s, s.ins_h, s.window[(str) + (MIN_MATCH-1)])}\r
+ s.ins_h := ((s.ins_h shl s.hash_shift) xor\r
+ (s.window^[(str) + (MIN_MATCH-1)])) and s.hash_mask;\r
+\r
+ match_head := s.head^[s.ins_h];\r
+ s.prev^[(str) and s.w_mask] := match_head;\r
+ s.head^[s.ins_h] := Pos(str);\r
+{$endif}\r
+end;\r
+\r
+{ =========================================================================\r
+ Initialize the hash table (avoiding 64K overflow for 16 bit systems).\r
+ prev[] will be initialized on the fly.\r
+\r
+macro CLEAR_HASH(s)\r
+ s^.head[s^.hash_size-1] := ZNIL;\r
+ zmemzero(pBytef(s^.head), unsigned(s^.hash_size-1)*sizeof(s^.head^[0]));\r
+}\r
+\r
+{ ======================================================================== }\r
+\r
+function deflateInit2_(var strm : z_stream;\r
+ level : int;\r
+ method : int;\r
+ windowBits : int;\r
+ memLevel : int;\r
+ strategy : int;\r
+ const version : string;\r
+ stream_size : int) : int;\r
+var\r
+ s : deflate_state_ptr;\r
+ noheader : int;\r
+\r
+ overlay : pushfArray;\r
+ { We overlay pending_buf and d_buf+l_buf. This works since the average\r
+ output size for (length,distance) codes is <= 24 bits. }\r
+begin\r
+ noheader := 0;\r
+ if (version = '') or (version[1] <> ZLIB_VERSION[1]) or\r
+ (stream_size <> sizeof(z_stream)) then\r
+ begin\r
+ deflateInit2_ := Z_VERSION_ERROR;\r
+ exit;\r
+ end;\r
+ {\r
+ if (strm = Z_NULL) then\r
+ begin\r
+ deflateInit2_ := Z_STREAM_ERROR;\r
+ exit;\r
+ end;\r
+ }\r
+ { SetLength(strm.msg, 255); }\r
+ strm.msg := '';\r
+ if not Assigned(strm.zalloc) then\r
+ begin\r
+ {$IFDEF FPC} strm.zalloc := @zcalloc; {$ELSE}\r
+ strm.zalloc := zcalloc;\r
+ {$ENDIF}\r
+ strm.opaque := voidpf(0);\r
+ end;\r
+ if not Assigned(strm.zfree) then\r
+ {$IFDEF FPC} strm.zfree := @zcfree; {$ELSE}\r
+ strm.zfree := zcfree;\r
+ {$ENDIF}\r
+\r
+ if (level = Z_DEFAULT_COMPRESSION) then\r
+ level := 6;\r
+{$ifdef FASTEST}\r
+ level := 1;\r
+{$endif}\r
+\r
+ if (windowBits < 0) then { undocumented feature: suppress zlib header }\r
+ begin\r
+ noheader := 1;\r
+ windowBits := -windowBits;\r
+ end;\r
+ if (memLevel < 1) or (memLevel > MAX_MEM_LEVEL) or (method <> Z_DEFLATED)\r
+ or (windowBits < 8) or (windowBits > 15) or (level < 0)\r
+ or (level > 9) or (strategy < 0) or (strategy > Z_HUFFMAN_ONLY) then\r
+ begin\r
+ deflateInit2_ := Z_STREAM_ERROR;\r
+ exit;\r
+ end;\r
+\r
+ s := deflate_state_ptr (ZALLOC(strm, 1, sizeof(deflate_state)));\r
+ if (s = Z_NULL) then\r
+ begin\r
+ deflateInit2_ := Z_MEM_ERROR;\r
+ exit;\r
+ end;\r
+ strm.state := pInternal_state(s);\r
+ s^.strm := @strm;\r
+\r
+ s^.noheader := noheader;\r
+ s^.w_bits := windowBits;\r
+ s^.w_size := 1 shl s^.w_bits;\r
+ s^.w_mask := s^.w_size - 1;\r
+\r
+ s^.hash_bits := memLevel + 7;\r
+ s^.hash_size := 1 shl s^.hash_bits;\r
+ s^.hash_mask := s^.hash_size - 1;\r
+ s^.hash_shift := ((s^.hash_bits+MIN_MATCH-1) div MIN_MATCH);\r
+\r
+ s^.window := pzByteArray (ZALLOC(strm, s^.w_size, 2*sizeof(Byte)));\r
+ s^.prev := pzPosfArray (ZALLOC(strm, s^.w_size, sizeof(Pos)));\r
+ s^.head := pzPosfArray (ZALLOC(strm, s^.hash_size, sizeof(Pos)));\r
+\r
+ s^.lit_bufsize := 1 shl (memLevel + 6); { 16K elements by default }\r
+\r
+ overlay := pushfArray (ZALLOC(strm, s^.lit_bufsize, sizeof(ush)+2));\r
+ s^.pending_buf := pzByteArray (overlay);\r
+ s^.pending_buf_size := ulg(s^.lit_bufsize) * (sizeof(ush)+Long(2));\r
+\r
+ if (s^.window = Z_NULL) or (s^.prev = Z_NULL) or (s^.head = Z_NULL)\r
+ or (s^.pending_buf = Z_NULL) then\r
+ begin\r
+ {ERR_MSG(Z_MEM_ERROR);}\r
+ strm.msg := z_errmsg[z_errbase-Z_MEM_ERROR];\r
+ deflateEnd (strm);\r
+ deflateInit2_ := Z_MEM_ERROR;\r
+ exit;\r
+ end;\r
+ s^.d_buf := pushfArray( @overlay^[s^.lit_bufsize div sizeof(ush)] );\r
+ s^.l_buf := puchfArray( @s^.pending_buf^[(1+sizeof(ush))*s^.lit_bufsize] );\r
+\r
+ s^.level := level;\r
+ s^.strategy := strategy;\r
+ s^.method := Byte(method);\r
+\r
+ deflateInit2_ := deflateReset(strm);\r
+end;\r
+\r
+{ ========================================================================= }\r
+\r
+function deflateInit2(var strm : z_stream;\r
+ level : int;\r
+ method : int;\r
+ windowBits : int;\r
+ memLevel : int;\r
+ strategy : int) : int;\r
+{ a macro }\r
+begin\r
+ deflateInit2 := deflateInit2_(strm, level, method, windowBits,\r
+ memLevel, strategy, ZLIB_VERSION, sizeof(z_stream));\r
+end;\r
+\r
+{ ========================================================================= }\r
+\r
+function deflateInit_(strm : z_streamp;\r
+ level : int;\r
+ const version : string;\r
+ stream_size : int) : int;\r
+begin\r
+ if (strm = Z_NULL) then\r
+ deflateInit_ := Z_STREAM_ERROR\r
+ else\r
+ deflateInit_ := deflateInit2_(strm^, level, Z_DEFLATED, MAX_WBITS,\r
+ DEF_MEM_LEVEL, Z_DEFAULT_STRATEGY, version, stream_size);\r
+ { To do: ignore strm^.next_in if we use it as window }\r
+end;\r
+\r
+{ ========================================================================= }\r
+\r
+function deflateInit(var strm : z_stream; level : int) : int;\r
+{ deflateInit is a macro to allow checking the zlib version\r
+ and the compiler's view of z_stream: }\r
+begin\r
+ deflateInit := deflateInit2_(strm, level, Z_DEFLATED, MAX_WBITS,\r
+ DEF_MEM_LEVEL, Z_DEFAULT_STRATEGY, ZLIB_VERSION, sizeof(z_stream));\r
+end;\r
+\r
+{ ======================================================================== }\r
+function deflateSetDictionary (var strm : z_stream;\r
+ dictionary : pBytef;\r
+ dictLength : uInt) : int;\r
+var\r
+ s : deflate_state_ptr;\r
+ length : uInt;\r
+ n : uInt;\r
+ hash_head : IPos;\r
+var\r
+ MAX_DIST : uInt; {macro}\r
+begin\r
+ length := dictLength;\r
+ hash_head := 0;\r
+\r
+ if {(@strm = Z_NULL) or}\r
+ (strm.state = Z_NULL) or (dictionary = Z_NULL)\r
+ or (deflate_state_ptr(strm.state)^.status <> INIT_STATE) then\r
+ begin\r
+ deflateSetDictionary := Z_STREAM_ERROR;\r
+ exit;\r
+ end;\r
+\r
+ s := deflate_state_ptr(strm.state);\r
+ strm.adler := adler32(strm.adler, dictionary, dictLength);\r
+\r
+ if (length < MIN_MATCH) then\r
+ begin\r
+ deflateSetDictionary := Z_OK;\r
+ exit;\r
+ end;\r
+ MAX_DIST := (s^.w_size - MIN_LOOKAHEAD);\r
+ if (length > MAX_DIST) then\r
+ begin\r
+ length := MAX_DIST;\r
+{$ifndef USE_DICT_HEAD}\r
+ Inc(dictionary, dictLength - length); { use the tail of the dictionary }\r
+{$endif}\r
+ end;\r
+\r
+ zmemcpy( pBytef(s^.window), dictionary, length);\r
+ s^.strstart := length;\r
+ s^.block_start := long(length);\r
+\r
+ { Insert all strings in the hash table (except for the last two bytes).\r
+ s^.lookahead stays null, so s^.ins_h will be recomputed at the next\r
+ call of fill_window. }\r
+\r
+ s^.ins_h := s^.window^[0];\r
+ {UPDATE_HASH(s, s^.ins_h, s^.window[1]);}\r
+ s^.ins_h := ((s^.ins_h shl s^.hash_shift) xor (s^.window^[1]))\r
+ and s^.hash_mask;\r
+\r
+ for n := 0 to length - MIN_MATCH do\r
+ begin\r
+ INSERT_STRING(s^, n, hash_head);\r
+ end;\r
+ {if (hash_head <> 0) then\r
+ hash_head := 0; - to make compiler happy }\r
+ deflateSetDictionary := Z_OK;\r
+end;\r
+\r
+{ ======================================================================== }\r
+function deflateReset (var strm : z_stream) : int;\r
+var\r
+ s : deflate_state_ptr;\r
+begin\r
+ if {(@strm = Z_NULL) or}\r
+ (strm.state = Z_NULL)\r
+ or (not Assigned(strm.zalloc)) or (not Assigned(strm.zfree)) then\r
+ begin\r
+ deflateReset := Z_STREAM_ERROR;\r
+ exit;\r
+ end;\r
+\r
+ strm.total_out := 0;\r
+ strm.total_in := 0;\r
+ strm.msg := ''; { use zfree if we ever allocate msg dynamically }\r
+ strm.data_type := Z_UNKNOWN;\r
+\r
+ s := deflate_state_ptr(strm.state);\r
+ s^.pending := 0;\r
+ s^.pending_out := pBytef(s^.pending_buf);\r
+\r
+ if (s^.noheader < 0) then\r
+ begin\r
+ s^.noheader := 0; { was set to -1 by deflate(..., Z_FINISH); }\r
+ end;\r
+ if s^.noheader <> 0 then\r
+ s^.status := BUSY_STATE\r
+ else\r
+ s^.status := INIT_STATE;\r
+ strm.adler := 1;\r
+ s^.last_flush := Z_NO_FLUSH;\r
+\r
+ _tr_init(s^);\r
+ lm_init(s^);\r
+\r
+ deflateReset := Z_OK;\r
+end;\r
+\r
+{ ======================================================================== }\r
+function deflateParams(var strm : z_stream;\r
+ level : int;\r
+ strategy : int) : int;\r
+var\r
+ s : deflate_state_ptr;\r
+ func : compress_func;\r
+ err : int;\r
+begin\r
+ err := Z_OK;\r
+ if {(@strm = Z_NULL) or} (strm.state = Z_NULL) then\r
+ begin\r
+ deflateParams := Z_STREAM_ERROR;\r
+ exit;\r
+ end;\r
+\r
+ s := deflate_state_ptr(strm.state);\r
+\r
+ if (level = Z_DEFAULT_COMPRESSION) then\r
+ begin\r
+ level := 6;\r
+ end;\r
+ if (level < 0) or (level > 9) or (strategy < 0)\r
+ or (strategy > Z_HUFFMAN_ONLY) then\r
+ begin\r
+ deflateParams := Z_STREAM_ERROR;\r
+ exit;\r
+ end;\r
+ func := configuration_table[s^.level].func;\r
+\r
+ if (@func <> @configuration_table[level].func)\r
+ and (strm.total_in <> 0) then\r
+ begin\r
+ { Flush the last buffer: }\r
+ err := deflate(strm, Z_PARTIAL_FLUSH);\r
+ end;\r
+ if (s^.level <> level) then\r
+ begin\r
+ s^.level := level;\r
+ s^.max_lazy_match := configuration_table[level].max_lazy;\r
+ s^.good_match := configuration_table[level].good_length;\r
+ s^.nice_match := configuration_table[level].nice_length;\r
+ s^.max_chain_length := configuration_table[level].max_chain;\r
+ end;\r
+ s^.strategy := strategy;\r
+ deflateParams := err;\r
+end;\r
+\r
+{ =========================================================================\r
+ Put a short in the pending buffer. The 16-bit value is put in MSB order.\r
+ IN assertion: the stream state is correct and there is enough room in\r
+ pending_buf. }\r
+\r
+{local}\r
+procedure putShortMSB (var s : deflate_state; b : uInt);\r
+begin\r
+ s.pending_buf^[s.pending] := Byte(b shr 8);\r
+ Inc(s.pending);\r
+ s.pending_buf^[s.pending] := Byte(b and $ff);\r
+ Inc(s.pending);\r
+end;\r
+\r
+{ =========================================================================\r
+ Flush as much pending output as possible. All deflate() output goes\r
+ through this function so some applications may wish to modify it\r
+ to avoid allocating a large strm^.next_out buffer and copying into it.\r
+ (See also read_buf()). }\r
+\r
+{local}\r
+procedure flush_pending(var strm : z_stream);\r
+var\r
+ len : unsigned;\r
+ s : deflate_state_ptr;\r
+begin\r
+ s := deflate_state_ptr(strm.state);\r
+ len := s^.pending;\r
+\r
+ if (len > strm.avail_out) then\r
+ len := strm.avail_out;\r
+ if (len = 0) then\r
+ exit;\r
+\r
+ zmemcpy(strm.next_out, s^.pending_out, len);\r
+ Inc(strm.next_out, len);\r
+ Inc(s^.pending_out, len);\r
+ Inc(strm.total_out, len);\r
+ Dec(strm.avail_out, len);\r
+ Dec(s^.pending, len);\r
+ if (s^.pending = 0) then\r
+ begin\r
+ s^.pending_out := pBytef(s^.pending_buf);\r
+ end;\r
+end;\r
+\r
+{ ========================================================================= }\r
+function deflate (var strm : z_stream; flush : int) : int;\r
+var\r
+ old_flush : int; { value of flush param for previous deflate call }\r
+ s : deflate_state_ptr;\r
+var\r
+ header : uInt;\r
+ level_flags : uInt;\r
+var\r
+ bstate : block_state;\r
+begin\r
+ if {(@strm = Z_NULL) or} (strm.state = Z_NULL)\r
+ or (flush > Z_FINISH) or (flush < 0) then\r
+ begin\r
+ deflate := Z_STREAM_ERROR;\r
+ exit;\r
+ end;\r
+ s := deflate_state_ptr(strm.state);\r
+\r
+ if (strm.next_out = Z_NULL) or\r
+ ((strm.next_in = Z_NULL) and (strm.avail_in <> 0)) or\r
+ ((s^.status = FINISH_STATE) and (flush <> Z_FINISH)) then\r
+ begin\r
+ {ERR_RETURN(strm^, Z_STREAM_ERROR);}\r
+ strm.msg := z_errmsg[z_errbase - Z_STREAM_ERROR];\r
+ deflate := Z_STREAM_ERROR;\r
+ exit;\r
+ end;\r
+ if (strm.avail_out = 0) then\r
+ begin\r
+ {ERR_RETURN(strm^, Z_BUF_ERROR);}\r
+ strm.msg := z_errmsg[z_errbase - Z_BUF_ERROR];\r
+ deflate := Z_BUF_ERROR;\r
+ exit;\r
+ end;\r
+\r
+ s^.strm := @strm; { just in case }\r
+ old_flush := s^.last_flush;\r
+ s^.last_flush := flush;\r
+\r
+ { Write the zlib header }\r
+ if (s^.status = INIT_STATE) then\r
+ begin\r
+\r
+ header := (Z_DEFLATED + ((s^.w_bits-8) shl 4)) shl 8;\r
+ level_flags := (s^.level-1) shr 1;\r
+\r
+ if (level_flags > 3) then\r
+ level_flags := 3;\r
+ header := header or (level_flags shl 6);\r
+ if (s^.strstart <> 0) then\r
+ header := header or PRESET_DICT;\r
+ Inc(header, 31 - (header mod 31));\r
+\r
+ s^.status := BUSY_STATE;\r
+ putShortMSB(s^, header);\r
+\r
+ { Save the adler32 of the preset dictionary: }\r
+ if (s^.strstart <> 0) then\r
+ begin\r
+ putShortMSB(s^, uInt(strm.adler shr 16));\r
+ putShortMSB(s^, uInt(strm.adler and $ffff));\r
+ end;\r
+ strm.adler := long(1);\r
+ end;\r
+\r
+ { Flush as much pending output as possible }\r
+ if (s^.pending <> 0) then\r
+ begin\r
+ flush_pending(strm);\r
+ if (strm.avail_out = 0) then\r
+ begin\r
+ { Since avail_out is 0, deflate will be called again with\r
+ more output space, but possibly with both pending and\r
+ avail_in equal to zero. There won't be anything to do,\r
+ but this is not an error situation so make sure we\r
+ return OK instead of BUF_ERROR at next call of deflate: }\r
+\r
+ s^.last_flush := -1;\r
+ deflate := Z_OK;\r
+ exit;\r
+ end;\r
+\r
+ { Make sure there is something to do and avoid duplicate consecutive\r
+ flushes. For repeated and useless calls with Z_FINISH, we keep\r
+ returning Z_STREAM_END instead of Z_BUFF_ERROR. }\r
+\r
+ end\r
+ else\r
+ if (strm.avail_in = 0) and (flush <= old_flush)\r
+ and (flush <> Z_FINISH) then\r
+ begin\r
+ {ERR_RETURN(strm^, Z_BUF_ERROR);}\r
+ strm.msg := z_errmsg[z_errbase - Z_BUF_ERROR];\r
+ deflate := Z_BUF_ERROR;\r
+ exit;\r
+ end;\r
+\r
+ { User must not provide more input after the first FINISH: }\r
+ if (s^.status = FINISH_STATE) and (strm.avail_in <> 0) then\r
+ begin\r
+ {ERR_RETURN(strm^, Z_BUF_ERROR);}\r
+ strm.msg := z_errmsg[z_errbase - Z_BUF_ERROR];\r
+ deflate := Z_BUF_ERROR;\r
+ exit;\r
+ end;\r
+\r
+ { Start a new block or continue the current one. }\r
+ if (strm.avail_in <> 0) or (s^.lookahead <> 0)\r
+ or ((flush <> Z_NO_FLUSH) and (s^.status <> FINISH_STATE)) then\r
+ begin\r
+ bstate := configuration_table[s^.level].func(s^, flush);\r
+\r
+ if (bstate = finish_started) or (bstate = finish_done) then\r
+ s^.status := FINISH_STATE;\r
+\r
+ if (bstate = need_more) or (bstate = finish_started) then\r
+ begin\r
+ if (strm.avail_out = 0) then\r
+ s^.last_flush := -1; { avoid BUF_ERROR next call, see above }\r
+\r
+ deflate := Z_OK;\r
+ exit;\r
+ { If flush != Z_NO_FLUSH && avail_out == 0, the next call\r
+ of deflate should use the same flush parameter to make sure\r
+ that the flush is complete. So we don't have to output an\r
+ empty block here, this will be done at next call. This also\r
+ ensures that for a very small output buffer, we emit at most\r
+ one empty block. }\r
+ end;\r
+ if (bstate = block_done) then\r
+ begin\r
+ if (flush = Z_PARTIAL_FLUSH) then\r
+ _tr_align(s^)\r
+ else\r
+ begin { FULL_FLUSH or SYNC_FLUSH }\r
+ _tr_stored_block(s^, pcharf(NIL), Long(0), FALSE);\r
+ { For a full flush, this empty block will be recognized\r
+ as a special marker by inflate_sync(). }\r
+\r
+ if (flush = Z_FULL_FLUSH) then\r
+ begin\r
+ {macro CLEAR_HASH(s);} { forget history }\r
+ s^.head^[s^.hash_size-1] := ZNIL;\r
+ zmemzero(pBytef(s^.head), unsigned(s^.hash_size-1)*sizeof(s^.head^[0]));\r
+ end;\r
+ end;\r
+\r
+ flush_pending(strm);\r
+ if (strm.avail_out = 0) then\r
+ begin\r
+ s^.last_flush := -1; { avoid BUF_ERROR at next call, see above }\r
+ deflate := Z_OK;\r
+ exit;\r
+ end;\r
+\r
+ end;\r
+ end;\r
+ {$IFDEF DEBUG}\r
+ Assert(strm.avail_out > 0, 'bug2');\r
+ {$ENDIF}\r
+ if (flush <> Z_FINISH) then\r
+ begin\r
+ deflate := Z_OK;\r
+ exit;\r
+ end;\r
+\r
+ if (s^.noheader <> 0) then\r
+ begin\r
+ deflate := Z_STREAM_END;\r
+ exit;\r
+ end;\r
+\r
+ { Write the zlib trailer (adler32) }\r
+ putShortMSB(s^, uInt(strm.adler shr 16));\r
+ putShortMSB(s^, uInt(strm.adler and $ffff));\r
+ flush_pending(strm);\r
+ { If avail_out is zero, the application will call deflate again\r
+ to flush the rest. }\r
+\r
+ s^.noheader := -1; { write the trailer only once! }\r
+ if s^.pending <> 0 then\r
+ deflate := Z_OK\r
+ else\r
+ deflate := Z_STREAM_END;\r
+end;\r
+\r
+{ ========================================================================= }\r
+function deflateEnd (var strm : z_stream) : int;\r
+var\r
+ status : int;\r
+ s : deflate_state_ptr;\r
+begin\r
+ if {(@strm = Z_NULL) or} (strm.state = Z_NULL) then\r
+ begin\r
+ deflateEnd := Z_STREAM_ERROR;\r
+ exit;\r
+ end;\r
+\r
+ s := deflate_state_ptr(strm.state);\r
+ status := s^.status;\r
+ if (status <> INIT_STATE) and (status <> BUSY_STATE) and\r
+ (status <> FINISH_STATE) then\r
+ begin\r
+ deflateEnd := Z_STREAM_ERROR;\r
+ exit;\r
+ end;\r
+\r
+ { Deallocate in reverse order of allocations: }\r
+ TRY_FREE(strm, s^.pending_buf);\r
+ TRY_FREE(strm, s^.head);\r
+ TRY_FREE(strm, s^.prev);\r
+ TRY_FREE(strm, s^.window);\r
+\r
+ ZFREE(strm, s);\r
+ strm.state := Z_NULL;\r
+\r
+ if status = BUSY_STATE then\r
+ deflateEnd := Z_DATA_ERROR\r
+ else\r
+ deflateEnd := Z_OK;\r
+end;\r
+\r
+{ =========================================================================\r
+ Copy the source state to the destination state.\r
+ To simplify the source, this is not supported for 16-bit MSDOS (which\r
+ doesn't have enough memory anyway to duplicate compression states). }\r
+\r
+\r
+{ ========================================================================= }\r
+function deflateCopy (dest, source : z_streamp) : int;\r
+{$ifndef MAXSEG_64K}\r
+var\r
+ ds : deflate_state_ptr;\r
+ ss : deflate_state_ptr;\r
+ overlay : pushfArray;\r
+{$endif}\r
+begin\r
+{$ifdef MAXSEG_64K}\r
+ deflateCopy := Z_STREAM_ERROR;\r
+ exit;\r
+{$else}\r
+\r
+ if (source = Z_NULL) or (dest = Z_NULL) or (source^.state = Z_NULL) then\r
+ begin\r
+ deflateCopy := Z_STREAM_ERROR;\r
+ exit;\r
+ end;\r
+ ss := deflate_state_ptr(source^.state);\r
+ dest^ := source^;\r
+\r
+ ds := deflate_state_ptr( ZALLOC(dest^, 1, sizeof(deflate_state)) );\r
+ if (ds = Z_NULL) then\r
+ begin\r
+ deflateCopy := Z_MEM_ERROR;\r
+ exit;\r
+ end;\r
+ dest^.state := pInternal_state(ds);\r
+ ds^ := ss^;\r
+ ds^.strm := dest;\r
+\r
+ ds^.window := pzByteArray ( ZALLOC(dest^, ds^.w_size, 2*sizeof(Byte)) );\r
+ ds^.prev := pzPosfArray ( ZALLOC(dest^, ds^.w_size, sizeof(Pos)) );\r
+ ds^.head := pzPosfArray ( ZALLOC(dest^, ds^.hash_size, sizeof(Pos)) );\r
+ overlay := pushfArray ( ZALLOC(dest^, ds^.lit_bufsize, sizeof(ush)+2) );\r
+ ds^.pending_buf := pzByteArray ( overlay );\r
+\r
+ if (ds^.window = Z_NULL) or (ds^.prev = Z_NULL) or (ds^.head = Z_NULL)\r
+ or (ds^.pending_buf = Z_NULL) then\r
+ begin\r
+ deflateEnd (dest^);\r
+ deflateCopy := Z_MEM_ERROR;\r
+ exit;\r
+ end;\r
+ { following zmemcpy do not work for 16-bit MSDOS }\r
+ zmemcpy(pBytef(ds^.window), pBytef(ss^.window), ds^.w_size * 2 * sizeof(Byte));\r
+ zmemcpy(pBytef(ds^.prev), pBytef(ss^.prev), ds^.w_size * sizeof(Pos));\r
+ zmemcpy(pBytef(ds^.head), pBytef(ss^.head), ds^.hash_size * sizeof(Pos));\r
+ zmemcpy(pBytef(ds^.pending_buf), pBytef(ss^.pending_buf), uInt(ds^.pending_buf_size));\r
+\r
+ ds^.pending_out := @ds^.pending_buf^[ptr2int(ss^.pending_out) - ptr2int(ss^.pending_buf)];\r
+ ds^.d_buf := pushfArray (@overlay^[ds^.lit_bufsize div sizeof(ush)] );\r
+ ds^.l_buf := puchfArray (@ds^.pending_buf^[(1+sizeof(ush))*ds^.lit_bufsize]);\r
+\r
+ ds^.l_desc.dyn_tree := tree_ptr(@ds^.dyn_ltree);\r
+ ds^.d_desc.dyn_tree := tree_ptr(@ds^.dyn_dtree);\r
+ ds^.bl_desc.dyn_tree := tree_ptr(@ds^.bl_tree);\r
+\r
+ deflateCopy := Z_OK;\r
+{$endif}\r
+end;\r
+\r
+\r
+{ ===========================================================================\r
+ Read a new buffer from the current input stream, update the adler32\r
+ and total number of bytes read. All deflate() input goes through\r
+ this function so some applications may wish to modify it to avoid\r
+ allocating a large strm^.next_in buffer and copying from it.\r
+ (See also flush_pending()). }\r
+\r
+{local}\r
+function read_buf(strm : z_streamp; buf : pBytef; size : unsigned) : int;\r
+var\r
+ len : unsigned;\r
+begin\r
+ len := strm^.avail_in;\r
+\r
+ if (len > size) then\r
+ len := size;\r
+ if (len = 0) then\r
+ begin\r
+ read_buf := 0;\r
+ exit;\r
+ end;\r
+\r
+ Dec(strm^.avail_in, len);\r
+\r
+ if deflate_state_ptr(strm^.state)^.noheader = 0 then\r
+ begin\r
+ strm^.adler := adler32(strm^.adler, strm^.next_in, len);\r
+ end;\r
+ zmemcpy(buf, strm^.next_in, len);\r
+ Inc(strm^.next_in, len);\r
+ Inc(strm^.total_in, len);\r
+\r
+ read_buf := int(len);\r
+end;\r
+\r
+{ ===========================================================================\r
+ Initialize the "longest match" routines for a new zlib stream }\r
+\r
+{local}\r
+procedure lm_init (var s : deflate_state);\r
+begin\r
+ s.window_size := ulg( uLong(2)*s.w_size);\r
+\r
+ {macro CLEAR_HASH(s);}\r
+ s.head^[s.hash_size-1] := ZNIL;\r
+ zmemzero(pBytef(s.head), unsigned(s.hash_size-1)*sizeof(s.head^[0]));\r
+\r
+ { Set the default configuration parameters: }\r
+\r
+ s.max_lazy_match := configuration_table[s.level].max_lazy;\r
+ s.good_match := configuration_table[s.level].good_length;\r
+ s.nice_match := configuration_table[s.level].nice_length;\r
+ s.max_chain_length := configuration_table[s.level].max_chain;\r
+\r
+ s.strstart := 0;\r
+ s.block_start := long(0);\r
+ s.lookahead := 0;\r
+ s.prev_length := MIN_MATCH-1;\r
+ s.match_length := MIN_MATCH-1;\r
+ s.match_available := FALSE;\r
+ s.ins_h := 0;\r
+{$ifdef ASMV}\r
+ match_init; { initialize the asm code }\r
+{$endif}\r
+end;\r
+\r
+{ ===========================================================================\r
+ Set match_start to the longest match starting at the given string and\r
+ return its length. Matches shorter or equal to prev_length are discarded,\r
+ in which case the result is equal to prev_length and match_start is\r
+ garbage.\r
+ IN assertions: cur_match is the head of the hash chain for the current\r
+ string (strstart) and its distance is <= MAX_DIST, and prev_length >= 1\r
+ OUT assertion: the match length is not greater than s^.lookahead. }\r
+\r
+\r
+{$ifndef ASMV}\r
+{ For 80x86 and 680x0, an optimized version will be provided in match.asm or\r
+ match.S. The code will be functionally equivalent. }\r
+\r
+{$ifndef FASTEST}\r
+\r
+{local}\r
+function longest_match(var s : deflate_state;\r
+ cur_match : IPos { current match }\r
+ ) : uInt;\r
+label\r
+ nextstep;\r
+var\r
+ chain_length : unsigned; { max hash chain length }\r
+ {register} scan : pBytef; { current string }\r
+ {register} match : pBytef; { matched string }\r
+ {register} len : int; { length of current match }\r
+ best_len : int; { best match length so far }\r
+ nice_match : int; { stop if match long enough }\r
+ limit : IPos;\r
+\r
+ prev : pzPosfArray;\r
+ wmask : uInt;\r
+{$ifdef UNALIGNED_OK}\r
+ {register} strend : pBytef;\r
+ {register} scan_start : ush;\r
+ {register} scan_end : ush;\r
+{$else}\r
+ {register} strend : pBytef;\r
+ {register} scan_end1 : Byte;\r
+ {register} scan_end : Byte;\r
+{$endif}\r
+var\r
+ MAX_DIST : uInt;\r
+begin\r
+ chain_length := s.max_chain_length; { max hash chain length }\r
+ scan := @(s.window^[s.strstart]);\r
+ best_len := s.prev_length; { best match length so far }\r
+ nice_match := s.nice_match; { stop if match long enough }\r
+\r
+\r
+ MAX_DIST := s.w_size - MIN_LOOKAHEAD;\r
+{In order to simplify the code, particularly on 16 bit machines, match\r
+distances are limited to MAX_DIST instead of WSIZE. }\r
+\r
+ if s.strstart > IPos(MAX_DIST) then\r
+ limit := s.strstart - IPos(MAX_DIST)\r
+ else\r
+ limit := ZNIL;\r
+ { Stop when cur_match becomes <= limit. To simplify the code,\r
+ we prevent matches with the string of window index 0. }\r
+\r
+ prev := s.prev;\r
+ wmask := s.w_mask;\r
+\r
+{$ifdef UNALIGNED_OK}\r
+ { Compare two bytes at a time. Note: this is not always beneficial.\r
+ Try with and without -DUNALIGNED_OK to check. }\r
+\r
+ strend := pBytef(@(s.window^[s.strstart + MAX_MATCH - 1]));\r
+ scan_start := pushf(scan)^;\r
+ scan_end := pushfArray(scan)^[best_len-1]; { fix }\r
+{$else}\r
+ strend := pBytef(@(s.window^[s.strstart + MAX_MATCH]));\r
+ {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF}\r
+ scan_end1 := pzByteArray(scan)^[best_len-1];\r
+ {$IFDEF NoRangeCheck} {$R+} {$UNDEF NoRangeCheck} {$ENDIF}\r
+ scan_end := pzByteArray(scan)^[best_len];\r
+{$endif}\r
+\r
+ { The code is optimized for HASH_BITS >= 8 and MAX_MATCH-2 multiple of 16.\r
+ It is easy to get rid of this optimization if necessary. }\r
+ {$IFDEF DEBUG}\r
+ Assert((s.hash_bits >= 8) and (MAX_MATCH = 258), 'Code too clever');\r
+ {$ENDIF}\r
+ { Do not waste too much time if we already have a good match: }\r
+ if (s.prev_length >= s.good_match) then\r
+ begin\r
+ chain_length := chain_length shr 2;\r
+ end;\r
+\r
+ { Do not look for matches beyond the end of the input. This is necessary\r
+ to make deflate deterministic. }\r
+\r
+ if (uInt(nice_match) > s.lookahead) then\r
+ nice_match := s.lookahead;\r
+ {$IFDEF DEBUG}\r
+ Assert(ulg(s.strstart) <= s.window_size-MIN_LOOKAHEAD, 'need lookahead');\r
+ {$ENDIF}\r
+ repeat\r
+ {$IFDEF DEBUG}\r
+ Assert(cur_match < s.strstart, 'no future');\r
+ {$ENDIF}\r
+ match := @(s.window^[cur_match]);\r
+\r
+ { Skip to next match if the match length cannot increase\r
+ or if the match length is less than 2: }\r
+\r
+{$undef DO_UNALIGNED_OK}\r
+{$ifdef UNALIGNED_OK}\r
+ {$ifdef MAX_MATCH_IS_258}\r
+ {$define DO_UNALIGNED_OK}\r
+ {$endif}\r
+{$endif}\r
+\r
+{$ifdef DO_UNALIGNED_OK}\r
+ { This code assumes sizeof(unsigned short) = 2. Do not use\r
+ UNALIGNED_OK if your compiler uses a different size. }\r
+ {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF}\r
+ if (pushfArray(match)^[best_len-1] <> scan_end) or\r
+ (pushf(match)^ <> scan_start) then\r
+ goto nextstep; {continue;}\r
+ {$IFDEF NoRangeCheck} {$R+} {$UNDEF NoRangeCheck} {$ENDIF}\r
+\r
+ { It is not necessary to compare scan[2] and match[2] since they are\r
+ always equal when the other bytes match, given that the hash keys\r
+ are equal and that HASH_BITS >= 8. Compare 2 bytes at a time at\r
+ strstart+3, +5, ... up to strstart+257. We check for insufficient\r
+ lookahead only every 4th comparison; the 128th check will be made\r
+ at strstart+257. If MAX_MATCH-2 is not a multiple of 8, it is\r
+ necessary to put more guard bytes at the end of the window, or\r
+ to check more often for insufficient lookahead. }\r
+ {$IFDEF DEBUG}\r
+ Assert(pzByteArray(scan)^[2] = pzByteArray(match)^[2], 'scan[2]?');\r
+ {$ENDIF}\r
+ Inc(scan);\r
+ Inc(match);\r
+\r
+ repeat\r
+ Inc(scan,2); Inc(match,2); if (pushf(scan)^<>pushf(match)^) then break;\r
+ Inc(scan,2); Inc(match,2); if (pushf(scan)^<>pushf(match)^) then break;\r
+ Inc(scan,2); Inc(match,2); if (pushf(scan)^<>pushf(match)^) then break;\r
+ Inc(scan,2); Inc(match,2); if (pushf(scan)^<>pushf(match)^) then break;\r
+ until (ptr2int(scan) >= ptr2int(strend));\r
+ { The funny "do while" generates better code on most compilers }\r
+\r
+ { Here, scan <= window+strstart+257 }\r
+ {$IFDEF DEBUG}\r
+ {$ifopt R+} {$define RangeCheck} {$endif} {$R-}\r
+ Assert(ptr2int(scan) <=\r
+ ptr2int(@(s.window^[unsigned(s.window_size-1)])),\r
+ 'wild scan');\r
+ {$ifdef RangeCheck} {$R+} {$undef RangeCheck} {$endif}\r
+ {$ENDIF}\r
+ if (scan^ = match^) then\r
+ Inc(scan);\r
+\r
+ len := (MAX_MATCH - 1) - int(ptr2int(strend)) + int(ptr2int(scan));\r
+ scan := strend;\r
+ Dec(scan, (MAX_MATCH-1));\r
+\r
+{$else} { UNALIGNED_OK }\r
+\r
+ {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF}\r
+ if (pzByteArray(match)^[best_len] <> scan_end) or\r
+ (pzByteArray(match)^[best_len-1] <> scan_end1) or\r
+ (match^ <> scan^) then\r
+ goto nextstep; {continue;}\r
+ {$IFDEF NoRangeCheck} {$R+} {$UNDEF NoRangeCheck} {$ENDIF}\r
+ Inc(match);\r
+ if (match^ <> pzByteArray(scan)^[1]) then\r
+ goto nextstep; {continue;}\r
+\r
+ { The check at best_len-1 can be removed because it will be made\r
+ again later. (This heuristic is not always a win.)\r
+ It is not necessary to compare scan[2] and match[2] since they\r
+ are always equal when the other bytes match, given that\r
+ the hash keys are equal and that HASH_BITS >= 8. }\r
+\r
+ Inc(scan, 2);\r
+ Inc(match);\r
+ {$IFDEF DEBUG}\r
+ Assert( scan^ = match^, 'match[2]?');\r
+ {$ENDIF}\r
+ { We check for insufficient lookahead only every 8th comparison;\r
+ the 256th check will be made at strstart+258. }\r
+\r
+ repeat\r
+ Inc(scan); Inc(match); if (scan^ <> match^) then break;\r
+ Inc(scan); Inc(match); if (scan^ <> match^) then break;\r
+ Inc(scan); Inc(match); if (scan^ <> match^) then break;\r
+ Inc(scan); Inc(match); if (scan^ <> match^) then break;\r
+ Inc(scan); Inc(match); if (scan^ <> match^) then break;\r
+ Inc(scan); Inc(match); if (scan^ <> match^) then break;\r
+ Inc(scan); Inc(match); if (scan^ <> match^) then break;\r
+ Inc(scan); Inc(match); if (scan^ <> match^) then break;\r
+ until (ptr2int(scan) >= ptr2int(strend));\r
+\r
+ {$IFDEF DEBUG}\r
+ Assert(ptr2int(scan) <=\r
+ ptr2int(@(s.window^[unsigned(s.window_size-1)])),\r
+ 'wild scan');\r
+ {$ENDIF}\r
+\r
+ len := MAX_MATCH - int(ptr2int(strend) - ptr2int(scan));\r
+ scan := strend;\r
+ Dec(scan, MAX_MATCH);\r
+\r
+{$endif} { UNALIGNED_OK }\r
+\r
+ if (len > best_len) then\r
+ begin\r
+ s.match_start := cur_match;\r
+ best_len := len;\r
+ if (len >= nice_match) then\r
+ break;\r
+ {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF}\r
+{$ifdef UNALIGNED_OK}\r
+ scan_end := pzByteArray(scan)^[best_len-1];\r
+{$else}\r
+ scan_end1 := pzByteArray(scan)^[best_len-1];\r
+ scan_end := pzByteArray(scan)^[best_len];\r
+{$endif}\r
+ {$IFDEF NoRangeCheck} {$R+} {$UNDEF NoRangeCheck} {$ENDIF}\r
+ end;\r
+ nextstep:\r
+ cur_match := prev^[cur_match and wmask];\r
+ Dec(chain_length);\r
+ until (cur_match <= limit) or (chain_length = 0);\r
+\r
+ if (uInt(best_len) <= s.lookahead) then\r
+ longest_match := uInt(best_len)\r
+ else\r
+ longest_match := s.lookahead;\r
+end;\r
+{$endif} { ASMV }\r
+\r
+{$else} { FASTEST }\r
+{ ---------------------------------------------------------------------------\r
+ Optimized version for level = 1 only }\r
+\r
+{local}\r
+function longest_match(var s : deflate_state;\r
+ cur_match : IPos { current match }\r
+ ) : uInt;\r
+var\r
+ {register} scan : pBytef; { current string }\r
+ {register} match : pBytef; { matched string }\r
+ {register} len : int; { length of current match }\r
+ {register} strend : pBytef;\r
+begin\r
+ scan := @s.window^[s.strstart];\r
+ strend := @s.window^[s.strstart + MAX_MATCH];\r
+\r
+\r
+ { The code is optimized for HASH_BITS >= 8 and MAX_MATCH-2 multiple of 16.\r
+ It is easy to get rid of this optimization if necessary. }\r
+ {$IFDEF DEBUG}\r
+ Assert((s.hash_bits >= 8) and (MAX_MATCH = 258), 'Code too clever');\r
+\r
+ Assert(ulg(s.strstart) <= s.window_size-MIN_LOOKAHEAD, 'need lookahead');\r
+\r
+ Assert(cur_match < s.strstart, 'no future');\r
+ {$ENDIF}\r
+ match := s.window + cur_match;\r
+\r
+ { Return failure if the match length is less than 2: }\r
+\r
+ if (match[0] <> scan[0]) or (match[1] <> scan[1]) then\r
+ begin\r
+ longest_match := MIN_MATCH-1;\r
+ exit;\r
+ end;\r
+\r
+ { The check at best_len-1 can be removed because it will be made\r
+ again later. (This heuristic is not always a win.)\r
+ It is not necessary to compare scan[2] and match[2] since they\r
+ are always equal when the other bytes match, given that\r
+ the hash keys are equal and that HASH_BITS >= 8. }\r
+\r
+ scan += 2, match += 2;\r
+ Assert(scan^ = match^, 'match[2]?');\r
+\r
+ { We check for insufficient lookahead only every 8th comparison;\r
+ the 256th check will be made at strstart+258. }\r
+\r
+ repeat\r
+ Inc(scan); Inc(match); if scan^<>match^ then break;\r
+ Inc(scan); Inc(match); if scan^<>match^ then break;\r
+ Inc(scan); Inc(match); if scan^<>match^ then break;\r
+ Inc(scan); Inc(match); if scan^<>match^ then break;\r
+ Inc(scan); Inc(match); if scan^<>match^ then break;\r
+ Inc(scan); Inc(match); if scan^<>match^ then break;\r
+ Inc(scan); Inc(match); if scan^<>match^ then break;\r
+ Inc(scan); Inc(match); if scan^<>match^ then break;\r
+ until (ptr2int(scan) >= ptr2int(strend));\r
+\r
+ Assert(scan <= s.window+unsigned(s.window_size-1), 'wild scan');\r
+\r
+ len := MAX_MATCH - int(strend - scan);\r
+\r
+ if (len < MIN_MATCH) then\r
+ begin\r
+ return := MIN_MATCH - 1;\r
+ exit;\r
+ end;\r
+\r
+ s.match_start := cur_match;\r
+ if len <= s.lookahead then\r
+ longest_match := len\r
+ else\r
+ longest_match := s.lookahead;\r
+end;\r
+{$endif} { FASTEST }\r
+\r
+{$ifdef DEBUG}\r
+{ ===========================================================================\r
+ Check that the match at match_start is indeed a match. }\r
+\r
+{local}\r
+procedure check_match(var s : deflate_state;\r
+ start, match : IPos;\r
+ length : int);\r
+begin\r
+ exit;\r
+ { check that the match is indeed a match }\r
+ if (zmemcmp(pBytef(@s.window^[match]),\r
+ pBytef(@s.window^[start]), length) <> EQUAL) then\r
+ begin\r
+ WriteLn(' start ',start,', match ',match ,' length ', length);\r
+ repeat\r
+ Write(char(s.window^[match]), char(s.window^[start]));\r
+ Inc(match);\r
+ Inc(start);\r
+ Dec(length);\r
+ Until (length = 0);\r
+ z_error('invalid match');\r
+ end;\r
+ if (z_verbose > 1) then\r
+ begin\r
+ Write('\\[',start-match,',',length,']');\r
+ repeat\r
+ Write(char(s.window^[start]));\r
+ Inc(start);\r
+ Dec(length);\r
+ Until (length = 0);\r
+ end;\r
+end;\r
+{$endif}\r
+\r
+{ ===========================================================================\r
+ Fill the window when the lookahead becomes insufficient.\r
+ Updates strstart and lookahead.\r
+\r
+ IN assertion: lookahead < MIN_LOOKAHEAD\r
+ OUT assertions: strstart <= window_size-MIN_LOOKAHEAD\r
+ At least one byte has been read, or avail_in = 0; reads are\r
+ performed for at least two bytes (required for the zip translate_eol\r
+ option -- not supported here). }\r
+\r
+{local}\r
+procedure fill_window(var s : deflate_state);\r
+var\r
+ {register} n, m : unsigned;\r
+ {register} p : pPosf;\r
+ more : unsigned; { Amount of free space at the end of the window. }\r
+ wsize : uInt;\r
+begin\r
+ wsize := s.w_size;\r
+ repeat\r
+ more := unsigned(s.window_size -ulg(s.lookahead) -ulg(s.strstart));\r
+\r
+ { Deal with !@#$% 64K limit: }\r
+ if (more = 0) and (s.strstart = 0) and (s.lookahead = 0) then\r
+ more := wsize\r
+ else\r
+ if (more = unsigned(-1)) then\r
+ begin\r
+ { Very unlikely, but possible on 16 bit machine if strstart = 0\r
+ and lookahead = 1 (input done one byte at time) }\r
+ Dec(more);\r
+\r
+ { If the window is almost full and there is insufficient lookahead,\r
+ move the upper half to the lower one to make room in the upper half.}\r
+ end\r
+ else\r
+ if (s.strstart >= wsize+ {MAX_DIST}(wsize-MIN_LOOKAHEAD)) then\r
+ begin\r
+ zmemcpy( pBytef(s.window), pBytef(@(s.window^[wsize])),\r
+ unsigned(wsize));\r
+ Dec(s.match_start, wsize);\r
+ Dec(s.strstart, wsize); { we now have strstart >= MAX_DIST }\r
+ Dec(s.block_start, long(wsize));\r
+\r
+ { Slide the hash table (could be avoided with 32 bit values\r
+ at the expense of memory usage). We slide even when level = 0\r
+ to keep the hash table consistent if we switch back to level > 0\r
+ later. (Using level 0 permanently is not an optimal usage of\r
+ zlib, so we don't care about this pathological case.) }\r
+\r
+ n := s.hash_size;\r
+ p := @s.head^[n];\r
+ repeat\r
+ Dec(p);\r
+ m := p^;\r
+ if (m >= wsize) then\r
+ p^ := Pos(m-wsize)\r
+ else\r
+ p^ := Pos(ZNIL);\r
+ Dec(n);\r
+ Until (n=0);\r
+\r
+ n := wsize;\r
+{$ifndef FASTEST}\r
+ p := @s.prev^[n];\r
+ repeat\r
+ Dec(p);\r
+ m := p^;\r
+ if (m >= wsize) then\r
+ p^ := Pos(m-wsize)\r
+ else\r
+ p^:= Pos(ZNIL);\r
+ { If n is not on any hash chain, prev^[n] is garbage but\r
+ its value will never be used. }\r
+ Dec(n);\r
+ Until (n=0);\r
+{$endif}\r
+ Inc(more, wsize);\r
+ end;\r
+ if (s.strm^.avail_in = 0) then\r
+ exit;\r
+\r
+ {* If there was no sliding:\r
+ * strstart <= WSIZE+MAX_DIST-1 && lookahead <= MIN_LOOKAHEAD - 1 &&\r
+ * more == window_size - lookahead - strstart\r
+ * => more >= window_size - (MIN_LOOKAHEAD-1 + WSIZE + MAX_DIST-1)\r
+ * => more >= window_size - 2*WSIZE + 2\r
+ * In the BIG_MEM or MMAP case (not yet supported),\r
+ * window_size == input_size + MIN_LOOKAHEAD &&\r
+ * strstart + s->lookahead <= input_size => more >= MIN_LOOKAHEAD.\r
+ * Otherwise, window_size == 2*WSIZE so more >= 2.\r
+ * If there was sliding, more >= WSIZE. So in all cases, more >= 2. }\r
+\r
+ {$IFDEF DEBUG}\r
+ Assert(more >= 2, 'more < 2');\r
+ {$ENDIF}\r
+\r
+ n := read_buf(s.strm, pBytef(@(s.window^[s.strstart + s.lookahead])),\r
+ more);\r
+ Inc(s.lookahead, n);\r
+\r
+ { Initialize the hash value now that we have some input: }\r
+ if (s.lookahead >= MIN_MATCH) then\r
+ begin\r
+ s.ins_h := s.window^[s.strstart];\r
+ {UPDATE_HASH(s, s.ins_h, s.window[s.strstart+1]);}\r
+ s.ins_h := ((s.ins_h shl s.hash_shift) xor s.window^[s.strstart+1])\r
+ and s.hash_mask;\r
+{$ifdef MIN_MATCH <> 3}\r
+ Call UPDATE_HASH() MIN_MATCH-3 more times\r
+{$endif}\r
+ end;\r
+ { If the whole input has less than MIN_MATCH bytes, ins_h is garbage,\r
+ but this is not important since only literal bytes will be emitted. }\r
+\r
+ until (s.lookahead >= MIN_LOOKAHEAD) or (s.strm^.avail_in = 0);\r
+end;\r
+\r
+{ ===========================================================================\r
+ Flush the current block, with given end-of-file flag.\r
+ IN assertion: strstart is set to the end of the current match. }\r
+\r
+procedure FLUSH_BLOCK_ONLY(var s : deflate_state; eof : boolean); {macro}\r
+begin\r
+ if (s.block_start >= Long(0)) then\r
+ _tr_flush_block(s, pcharf(@s.window^[unsigned(s.block_start)]),\r
+ ulg(long(s.strstart) - s.block_start), eof)\r
+ else\r
+ _tr_flush_block(s, pcharf(Z_NULL),\r
+ ulg(long(s.strstart) - s.block_start), eof);\r
+\r
+ s.block_start := s.strstart;\r
+ flush_pending(s.strm^);\r
+ {$IFDEF DEBUG}\r
+ Tracev('[FLUSH]');\r
+ {$ENDIF}\r
+end;\r
+\r
+{ Same but force premature exit if necessary.\r
+macro FLUSH_BLOCK(var s : deflate_state; eof : boolean) : boolean;\r
+var\r
+ result : block_state;\r
+begin\r
+ FLUSH_BLOCK_ONLY(s, eof);\r
+ if (s.strm^.avail_out = 0) then\r
+ begin\r
+ if eof then\r
+ result := finish_started\r
+ else\r
+ result := need_more;\r
+ exit;\r
+ end;\r
+end;\r
+}\r
+\r
+{ ===========================================================================\r
+ Copy without compression as much as possible from the input stream, return\r
+ the current block state.\r
+ This function does not insert new strings in the dictionary since\r
+ uncompressible data is probably not useful. This function is used\r
+ only for the level=0 compression option.\r
+ NOTE: this function should be optimized to avoid extra copying from\r
+ window to pending_buf. }\r
+\r
+\r
+{local}\r
+function deflate_stored(var s : deflate_state; flush : int) : block_state;\r
+{ Stored blocks are limited to 0xffff bytes, pending_buf is limited\r
+ to pending_buf_size, and each stored block has a 5 byte header: }\r
+var\r
+ max_block_size : ulg;\r
+ max_start : ulg;\r
+begin\r
+ max_block_size := $ffff;\r
+ if (max_block_size > s.pending_buf_size - 5) then\r
+ max_block_size := s.pending_buf_size - 5;\r
+\r
+ { Copy as much as possible from input to output: }\r
+ while TRUE do\r
+ begin\r
+ { Fill the window as much as possible: }\r
+ if (s.lookahead <= 1) then\r
+ begin\r
+ {$IFDEF DEBUG}\r
+ Assert( (s.strstart < s.w_size + {MAX_DIST}s.w_size-MIN_LOOKAHEAD) or\r
+ (s.block_start >= long(s.w_size)), 'slide too late');\r
+ {$ENDIF}\r
+ fill_window(s);\r
+ if (s.lookahead = 0) and (flush = Z_NO_FLUSH) then\r
+ begin\r
+ deflate_stored := need_more;\r
+ exit;\r
+ end;\r
+\r
+ if (s.lookahead = 0) then\r
+ break; { flush the current block }\r
+ end;\r
+ {$IFDEF DEBUG}\r
+ Assert(s.block_start >= long(0), 'block gone');\r
+ {$ENDIF}\r
+ Inc(s.strstart, s.lookahead);\r
+ s.lookahead := 0;\r
+\r
+ { Emit a stored block if pending_buf will be full: }\r
+ max_start := s.block_start + max_block_size;\r
+ if (s.strstart = 0) or (ulg(s.strstart) >= max_start) then\r
+ begin\r
+ { strstart = 0 is possible when wraparound on 16-bit machine }\r
+ s.lookahead := uInt(s.strstart - max_start);\r
+ s.strstart := uInt(max_start);\r
+ {FLUSH_BLOCK(s, FALSE);}\r
+ FLUSH_BLOCK_ONLY(s, FALSE);\r
+ if (s.strm^.avail_out = 0) then\r
+ begin\r
+ deflate_stored := need_more;\r
+ exit;\r
+ end;\r
+ end;\r
+\r
+ { Flush if we may have to slide, otherwise block_start may become\r
+ negative and the data will be gone: }\r
+\r
+ if (s.strstart - uInt(s.block_start) >= {MAX_DIST}\r
+ s.w_size-MIN_LOOKAHEAD) then\r
+ begin\r
+ {FLUSH_BLOCK(s, FALSE);}\r
+ FLUSH_BLOCK_ONLY(s, FALSE);\r
+ if (s.strm^.avail_out = 0) then\r
+ begin\r
+ deflate_stored := need_more;\r
+ exit;\r
+ end;\r
+ end;\r
+ end;\r
+\r
+ {FLUSH_BLOCK(s, flush = Z_FINISH);}\r
+ FLUSH_BLOCK_ONLY(s, flush = Z_FINISH);\r
+ if (s.strm^.avail_out = 0) then\r
+ begin\r
+ if flush = Z_FINISH then\r
+ deflate_stored := finish_started\r
+ else\r
+ deflate_stored := need_more;\r
+ exit;\r
+ end;\r
+\r
+ if flush = Z_FINISH then\r
+ deflate_stored := finish_done\r
+ else\r
+ deflate_stored := block_done;\r
+end;\r
+\r
+{ ===========================================================================\r
+ Compress as much as possible from the input stream, return the current\r
+ block state.\r
+ This function does not perform lazy evaluation of matches and inserts\r
+ new strings in the dictionary only for unmatched strings or for short\r
+ matches. It is used only for the fast compression options. }\r
+\r
+{local}\r
+function deflate_fast(var s : deflate_state; flush : int) : block_state;\r
+var\r
+ hash_head : IPos; { head of the hash chain }\r
+ bflush : boolean; { set if current block must be flushed }\r
+begin\r
+ hash_head := ZNIL;\r
+ while TRUE do\r
+ begin\r
+ { Make sure that we always have enough lookahead, except\r
+ at the end of the input file. We need MAX_MATCH bytes\r
+ for the next match, plus MIN_MATCH bytes to insert the\r
+ string following the next match. }\r
+\r
+ if (s.lookahead < MIN_LOOKAHEAD) then\r
+ begin\r
+ fill_window(s);\r
+ if (s.lookahead < MIN_LOOKAHEAD) and (flush = Z_NO_FLUSH) then\r
+ begin\r
+ deflate_fast := need_more;\r
+ exit;\r
+ end;\r
+\r
+ if (s.lookahead = 0) then\r
+ break; { flush the current block }\r
+ end;\r
+\r
+\r
+ { Insert the string window[strstart .. strstart+2] in the\r
+ dictionary, and set hash_head to the head of the hash chain: }\r
+\r
+ if (s.lookahead >= MIN_MATCH) then\r
+ begin\r
+ INSERT_STRING(s, s.strstart, hash_head);\r
+ end;\r
+\r
+ { Find the longest match, discarding those <= prev_length.\r
+ At this point we have always match_length < MIN_MATCH }\r
+ if (hash_head <> ZNIL) and\r
+ (s.strstart - hash_head <= (s.w_size-MIN_LOOKAHEAD){MAX_DIST}) then\r
+ begin\r
+ { To simplify the code, we prevent matches with the string\r
+ of window index 0 (in particular we have to avoid a match\r
+ of the string with itself at the start of the input file). }\r
+ if (s.strategy <> Z_HUFFMAN_ONLY) then\r
+ begin\r
+ s.match_length := longest_match (s, hash_head);\r
+ end;\r
+ { longest_match() sets match_start }\r
+ end;\r
+ if (s.match_length >= MIN_MATCH) then\r
+ begin\r
+ {$IFDEF DEBUG}\r
+ check_match(s, s.strstart, s.match_start, s.match_length);\r
+ {$ENDIF}\r
+\r
+ {_tr_tally_dist(s, s.strstart - s.match_start,\r
+ s.match_length - MIN_MATCH, bflush);}\r
+ bflush := _tr_tally(s, s.strstart - s.match_start,\r
+ s.match_length - MIN_MATCH);\r
+\r
+ Dec(s.lookahead, s.match_length);\r
+\r
+ { Insert new strings in the hash table only if the match length\r
+ is not too large. This saves time but degrades compression. }\r
+\r
+{$ifndef FASTEST}\r
+ if (s.match_length <= s.max_insert_length)\r
+ and (s.lookahead >= MIN_MATCH) then\r
+ begin\r
+ Dec(s.match_length); { string at strstart already in hash table }\r
+ repeat\r
+ Inc(s.strstart);\r
+ INSERT_STRING(s, s.strstart, hash_head);\r
+ { strstart never exceeds WSIZE-MAX_MATCH, so there are\r
+ always MIN_MATCH bytes ahead. }\r
+ Dec(s.match_length);\r
+ until (s.match_length = 0);\r
+ Inc(s.strstart);\r
+ end\r
+ else\r
+{$endif}\r
+\r
+ begin\r
+ Inc(s.strstart, s.match_length);\r
+ s.match_length := 0;\r
+ s.ins_h := s.window^[s.strstart];\r
+ {UPDATE_HASH(s, s.ins_h, s.window[s.strstart+1]);}\r
+ s.ins_h := (( s.ins_h shl s.hash_shift) xor\r
+ s.window^[s.strstart+1]) and s.hash_mask;\r
+if MIN_MATCH <> 3 then { the linker removes this }\r
+begin\r
+ {Call UPDATE_HASH() MIN_MATCH-3 more times}\r
+end;\r
+\r
+ { If lookahead < MIN_MATCH, ins_h is garbage, but it does not\r
+ matter since it will be recomputed at next deflate call. }\r
+\r
+ end;\r
+ end\r
+ else\r
+ begin\r
+ { No match, output a literal byte }\r
+ {$IFDEF DEBUG}\r
+ Tracevv(char(s.window^[s.strstart]));\r
+ {$ENDIF}\r
+ {_tr_tally_lit (s, 0, s.window^[s.strstart], bflush);}\r
+ bflush := _tr_tally (s, 0, s.window^[s.strstart]);\r
+\r
+ Dec(s.lookahead);\r
+ Inc(s.strstart);\r
+ end;\r
+ if bflush then\r
+ begin {FLUSH_BLOCK(s, FALSE);}\r
+ FLUSH_BLOCK_ONLY(s, FALSE);\r
+ if (s.strm^.avail_out = 0) then\r
+ begin\r
+ deflate_fast := need_more;\r
+ exit;\r
+ end;\r
+ end;\r
+ end;\r
+ {FLUSH_BLOCK(s, flush = Z_FINISH);}\r
+ FLUSH_BLOCK_ONLY(s, flush = Z_FINISH);\r
+ if (s.strm^.avail_out = 0) then\r
+ begin\r
+ if flush = Z_FINISH then\r
+ deflate_fast := finish_started\r
+ else\r
+ deflate_fast := need_more;\r
+ exit;\r
+ end;\r
+\r
+ if flush = Z_FINISH then\r
+ deflate_fast := finish_done\r
+ else\r
+ deflate_fast := block_done;\r
+end;\r
+\r
+{ ===========================================================================\r
+ Same as above, but achieves better compression. We use a lazy\r
+ evaluation for matches: a match is finally adopted only if there is\r
+ no better match at the next window position. }\r
+\r
+{local}\r
+function deflate_slow(var s : deflate_state; flush : int) : block_state;\r
+var\r
+ hash_head : IPos; { head of hash chain }\r
+ bflush : boolean; { set if current block must be flushed }\r
+var\r
+ max_insert : uInt;\r
+begin\r
+ hash_head := ZNIL;\r
+\r
+ { Process the input block. }\r
+ while TRUE do\r
+ begin\r
+ { Make sure that we always have enough lookahead, except\r
+ at the end of the input file. We need MAX_MATCH bytes\r
+ for the next match, plus MIN_MATCH bytes to insert the\r
+ string following the next match. }\r
+\r
+ if (s.lookahead < MIN_LOOKAHEAD) then\r
+ begin\r
+ fill_window(s);\r
+ if (s.lookahead < MIN_LOOKAHEAD) and (flush = Z_NO_FLUSH) then\r
+ begin\r
+ deflate_slow := need_more;\r
+ exit;\r
+ end;\r
+\r
+ if (s.lookahead = 0) then\r
+ break; { flush the current block }\r
+ end;\r
+\r
+ { Insert the string window[strstart .. strstart+2] in the\r
+ dictionary, and set hash_head to the head of the hash chain: }\r
+\r
+ if (s.lookahead >= MIN_MATCH) then\r
+ begin\r
+ INSERT_STRING(s, s.strstart, hash_head);\r
+ end;\r
+\r
+ { Find the longest match, discarding those <= prev_length. }\r
+\r
+ s.prev_length := s.match_length;\r
+ s.prev_match := s.match_start;\r
+ s.match_length := MIN_MATCH-1;\r
+\r
+ if (hash_head <> ZNIL) and (s.prev_length < s.max_lazy_match) and\r
+ (s.strstart - hash_head <= {MAX_DIST}(s.w_size-MIN_LOOKAHEAD)) then\r
+ begin\r
+ { To simplify the code, we prevent matches with the string\r
+ of window index 0 (in particular we have to avoid a match\r
+ of the string with itself at the start of the input file). }\r
+\r
+ if (s.strategy <> Z_HUFFMAN_ONLY) then\r
+ begin\r
+ s.match_length := longest_match (s, hash_head);\r
+ end;\r
+ { longest_match() sets match_start }\r
+\r
+ if (s.match_length <= 5) and ((s.strategy = Z_FILTERED) or\r
+ ((s.match_length = MIN_MATCH) and\r
+ (s.strstart - s.match_start > TOO_FAR))) then\r
+ begin\r
+ { If prev_match is also MIN_MATCH, match_start is garbage\r
+ but we will ignore the current match anyway. }\r
+\r
+ s.match_length := MIN_MATCH-1;\r
+ end;\r
+ end;\r
+ { If there was a match at the previous step and the current\r
+ match is not better, output the previous match: }\r
+\r
+ if (s.prev_length >= MIN_MATCH)\r
+ and (s.match_length <= s.prev_length) then\r
+ begin\r
+ max_insert := s.strstart + s.lookahead - MIN_MATCH;\r
+ { Do not insert strings in hash table beyond this. }\r
+ {$ifdef DEBUG}\r
+ check_match(s, s.strstart-1, s.prev_match, s.prev_length);\r
+ {$endif}\r
+\r
+ {_tr_tally_dist(s, s->strstart -1 - s->prev_match,\r
+ s->prev_length - MIN_MATCH, bflush);}\r
+ bflush := _tr_tally(s, s.strstart -1 - s.prev_match,\r
+ s.prev_length - MIN_MATCH);\r
+\r
+ { Insert in hash table all strings up to the end of the match.\r
+ strstart-1 and strstart are already inserted. If there is not\r
+ enough lookahead, the last two strings are not inserted in\r
+ the hash table. }\r
+\r
+ Dec(s.lookahead, s.prev_length-1);\r
+ Dec(s.prev_length, 2);\r
+ repeat\r
+ Inc(s.strstart);\r
+ if (s.strstart <= max_insert) then\r
+ begin\r
+ INSERT_STRING(s, s.strstart, hash_head);\r
+ end;\r
+ Dec(s.prev_length);\r
+ until (s.prev_length = 0);\r
+ s.match_available := FALSE;\r
+ s.match_length := MIN_MATCH-1;\r
+ Inc(s.strstart);\r
+\r
+ if (bflush) then {FLUSH_BLOCK(s, FALSE);}\r
+ begin\r
+ FLUSH_BLOCK_ONLY(s, FALSE);\r
+ if (s.strm^.avail_out = 0) then\r
+ begin\r
+ deflate_slow := need_more;\r
+ exit;\r
+ end;\r
+ end;\r
+ end\r
+ else\r
+ if (s.match_available) then\r
+ begin\r
+ { If there was no match at the previous position, output a\r
+ single literal. If there was a match but the current match\r
+ is longer, truncate the previous match to a single literal. }\r
+ {$IFDEF DEBUG}\r
+ Tracevv(char(s.window^[s.strstart-1]));\r
+ {$ENDIF}\r
+ bflush := _tr_tally (s, 0, s.window^[s.strstart-1]);\r
+\r
+ if bflush then\r
+ begin\r
+ FLUSH_BLOCK_ONLY(s, FALSE);\r
+ end;\r
+ Inc(s.strstart);\r
+ Dec(s.lookahead);\r
+ if (s.strm^.avail_out = 0) then\r
+ begin\r
+ deflate_slow := need_more;\r
+ exit;\r
+ end;\r
+ end\r
+ else\r
+ begin\r
+ { There is no previous match to compare with, wait for\r
+ the next step to decide. }\r
+\r
+ s.match_available := TRUE;\r
+ Inc(s.strstart);\r
+ Dec(s.lookahead);\r
+ end;\r
+ end;\r
+\r
+ {$IFDEF DEBUG}\r
+ Assert (flush <> Z_NO_FLUSH, 'no flush?');\r
+ {$ENDIF}\r
+ if (s.match_available) then\r
+ begin\r
+ {$IFDEF DEBUG}\r
+ Tracevv(char(s.window^[s.strstart-1]));\r
+ bflush :=\r
+ {$ENDIF}\r
+ _tr_tally (s, 0, s.window^[s.strstart-1]);\r
+ s.match_available := FALSE;\r
+ end;\r
+ {FLUSH_BLOCK(s, flush = Z_FINISH);}\r
+ FLUSH_BLOCK_ONLY(s, flush = Z_FINISH);\r
+ if (s.strm^.avail_out = 0) then\r
+ begin\r
+ if flush = Z_FINISH then\r
+ deflate_slow := finish_started\r
+ else\r
+ deflate_slow := need_more;\r
+ exit;\r
+ end;\r
+ if flush = Z_FINISH then\r
+ deflate_slow := finish_done\r
+ else\r
+ deflate_slow := block_done;\r
+end;\r
+\r
+end.
\ No newline at end of file
--- /dev/null
+Unit zInflate;\r
+\r
+{ inflate.c -- zlib interface to inflate modules\r
+ Copyright (C) 1995-1998 Mark Adler\r
+\r
+ Pascal tranlastion\r
+ Copyright (C) 1998 by Jacques Nomssi Nzali\r
+ For conditions of distribution and use, see copyright notice in readme.paszlib\r
+}\r
+\r
+interface\r
+\r
+{$I zconf.inc}\r
+\r
+uses\r
+ zutil, zlib, infblock, infutil;\r
+\r
+function inflateInit(var z : z_stream) : int;\r
+\r
+{ Initializes the internal stream state for decompression. The fields\r
+ zalloc, zfree and opaque must be initialized before by the caller. If\r
+ zalloc and zfree are set to Z_NULL, inflateInit updates them to use default\r
+ allocation functions.\r
+\r
+ inflateInit returns Z_OK if success, Z_MEM_ERROR if there was not\r
+ enough memory, Z_VERSION_ERROR if the zlib library version is incompatible\r
+ with the version assumed by the caller. msg is set to null if there is no\r
+ error message. inflateInit does not perform any decompression: this will be\r
+ done by inflate(). }\r
+\r
+\r
+\r
+function inflateInit_(z : z_streamp;\r
+ const version : string;\r
+ stream_size : int) : int;\r
+\r
+\r
+function inflateInit2_(var z: z_stream;\r
+ w : int;\r
+ const version : string;\r
+ stream_size : int) : int;\r
+\r
+function inflateInit2(var z: z_stream;\r
+ windowBits : int) : int;\r
+\r
+{\r
+ This is another version of inflateInit with an extra parameter. The\r
+ fields next_in, avail_in, zalloc, zfree and opaque must be initialized\r
+ before by the caller.\r
+\r
+ The windowBits parameter is the base two logarithm of the maximum window\r
+ size (the size of the history buffer). It should be in the range 8..15 for\r
+ this version of the library. The default value is 15 if inflateInit is used\r
+ instead. If a compressed stream with a larger window size is given as\r
+ input, inflate() will return with the error code Z_DATA_ERROR instead of\r
+ trying to allocate a larger window.\r
+\r
+ inflateInit2 returns Z_OK if success, Z_MEM_ERROR if there was not enough\r
+ memory, Z_STREAM_ERROR if a parameter is invalid (such as a negative\r
+ memLevel). msg is set to null if there is no error message. inflateInit2\r
+ does not perform any decompression apart from reading the zlib header if\r
+ present: this will be done by inflate(). (So next_in and avail_in may be\r
+ modified, but next_out and avail_out are unchanged.)\r
+}\r
+\r
+\r
+\r
+function inflateEnd(var z : z_stream) : int;\r
+\r
+{\r
+ All dynamically allocated data structures for this stream are freed.\r
+ This function discards any unprocessed input and does not flush any\r
+ pending output.\r
+\r
+ inflateEnd returns Z_OK if success, Z_STREAM_ERROR if the stream state\r
+ was inconsistent. In the error case, msg may be set but then points to a\r
+ static string (which must not be deallocated).\r
+}\r
+\r
+function inflateReset(var z : z_stream) : int;\r
+\r
+{\r
+ This function is equivalent to inflateEnd followed by inflateInit,\r
+ but does not free and reallocate all the internal decompression state.\r
+ The stream will keep attributes that may have been set by inflateInit2.\r
+\r
+ inflateReset returns Z_OK if success, or Z_STREAM_ERROR if the source\r
+ stream state was inconsistent (such as zalloc or state being NULL).\r
+}\r
+\r
+\r
+function inflate(var z : z_stream;\r
+ f : int) : int;\r
+{\r
+ inflate decompresses as much data as possible, and stops when the input\r
+ buffer becomes empty or the output buffer becomes full. It may introduce\r
+ some output latency (reading input without producing any output)\r
+ except when forced to flush.\r
+\r
+ The detailed semantics are as follows. inflate performs one or both of the\r
+ following actions:\r
+\r
+ - Decompress more input starting at next_in and update next_in and avail_in\r
+ accordingly. If not all input can be processed (because there is not\r
+ enough room in the output buffer), next_in is updated and processing\r
+ will resume at this point for the next call of inflate().\r
+\r
+ - Provide more output starting at next_out and update next_out and avail_out\r
+ accordingly. inflate() provides as much output as possible, until there\r
+ is no more input data or no more space in the output buffer (see below\r
+ about the flush parameter).\r
+\r
+ Before the call of inflate(), the application should ensure that at least\r
+ one of the actions is possible, by providing more input and/or consuming\r
+ more output, and updating the next_* and avail_* values accordingly.\r
+ The application can consume the uncompressed output when it wants, for\r
+ example when the output buffer is full (avail_out == 0), or after each\r
+ call of inflate(). If inflate returns Z_OK and with zero avail_out, it\r
+ must be called again after making room in the output buffer because there\r
+ might be more output pending.\r
+\r
+ If the parameter flush is set to Z_SYNC_FLUSH, inflate flushes as much\r
+ output as possible to the output buffer. The flushing behavior of inflate is\r
+ not specified for values of the flush parameter other than Z_SYNC_FLUSH\r
+ and Z_FINISH, but the current implementation actually flushes as much output\r
+ as possible anyway.\r
+\r
+ inflate() should normally be called until it returns Z_STREAM_END or an\r
+ error. However if all decompression is to be performed in a single step\r
+ (a single call of inflate), the parameter flush should be set to\r
+ Z_FINISH. In this case all pending input is processed and all pending\r
+ output is flushed; avail_out must be large enough to hold all the\r
+ uncompressed data. (The size of the uncompressed data may have been saved\r
+ by the compressor for this purpose.) The next operation on this stream must\r
+ be inflateEnd to deallocate the decompression state. The use of Z_FINISH\r
+ is never required, but can be used to inform inflate that a faster routine\r
+ may be used for the single inflate() call.\r
+\r
+ If a preset dictionary is needed at this point (see inflateSetDictionary\r
+ below), inflate sets strm-adler to the adler32 checksum of the\r
+ dictionary chosen by the compressor and returns Z_NEED_DICT; otherwise \r
+ it sets strm->adler to the adler32 checksum of all output produced\r
+ so far (that is, total_out bytes) and returns Z_OK, Z_STREAM_END or\r
+ an error code as described below. At the end of the stream, inflate()\r
+ checks that its computed adler32 checksum is equal to that saved by the\r
+ compressor and returns Z_STREAM_END only if the checksum is correct.\r
+\r
+ inflate() returns Z_OK if some progress has been made (more input processed\r
+ or more output produced), Z_STREAM_END if the end of the compressed data has\r
+ been reached and all uncompressed output has been produced, Z_NEED_DICT if a\r
+ preset dictionary is needed at this point, Z_DATA_ERROR if the input data was\r
+ corrupted (input stream not conforming to the zlib format or incorrect\r
+ adler32 checksum), Z_STREAM_ERROR if the stream structure was inconsistent\r
+ (for example if next_in or next_out was NULL), Z_MEM_ERROR if there was not\r
+ enough memory, Z_BUF_ERROR if no progress is possible or if there was not\r
+ enough room in the output buffer when Z_FINISH is used. In the Z_DATA_ERROR\r
+ case, the application may then call inflateSync to look for a good\r
+ compression block.\r
+}\r
+\r
+\r
+function inflateSetDictionary(var z : z_stream;\r
+ dictionary : pBytef; {const array of byte}\r
+ dictLength : uInt) : int;\r
+\r
+{\r
+ Initializes the decompression dictionary from the given uncompressed byte\r
+ sequence. This function must be called immediately after a call of inflate\r
+ if this call returned Z_NEED_DICT. The dictionary chosen by the compressor\r
+ can be determined from the Adler32 value returned by this call of\r
+ inflate. The compressor and decompressor must use exactly the same\r
+ dictionary (see deflateSetDictionary).\r
+\r
+ inflateSetDictionary returns Z_OK if success, Z_STREAM_ERROR if a\r
+ parameter is invalid (such as NULL dictionary) or the stream state is\r
+ inconsistent, Z_DATA_ERROR if the given dictionary doesn't match the\r
+ expected one (incorrect Adler32 value). inflateSetDictionary does not\r
+ perform any decompression: this will be done by subsequent calls of\r
+ inflate().\r
+}\r
+\r
+function inflateSync(var z : z_stream) : int;\r
+\r
+{\r
+ Skips invalid compressed data until a full flush point (see above the\r
+ description of deflate with Z_FULL_FLUSH) can be found, or until all\r
+ available input is skipped. No output is provided.\r
+\r
+ inflateSync returns Z_OK if a full flush point has been found, Z_BUF_ERROR\r
+ if no more input was provided, Z_DATA_ERROR if no flush point has been found,\r
+ or Z_STREAM_ERROR if the stream structure was inconsistent. In the success\r
+ case, the application may save the current current value of total_in which\r
+ indicates where valid compressed data was found. In the error case, the\r
+ application may repeatedly call inflateSync, providing more input each time,\r
+ until success or end of the input data.\r
+}\r
+\r
+\r
+function inflateSyncPoint(var z : z_stream) : int;\r
+\r
+\r
+implementation\r
+\r
+uses\r
+ adler;\r
+\r
+function inflateReset(var z : z_stream) : int;\r
+begin\r
+ if (z.state = Z_NULL) then\r
+ begin\r
+ inflateReset := Z_STREAM_ERROR;\r
+ exit;\r
+ end;\r
+ z.total_out := 0;\r
+ z.total_in := 0;\r
+ z.msg := '';\r
+ if z.state^.nowrap then\r
+ z.state^.mode := BLOCKS\r
+ else\r
+ z.state^.mode := METHOD;\r
+ inflate_blocks_reset(z.state^.blocks^, z, Z_NULL);\r
+ {$IFDEF DEBUG}\r
+ Tracev('inflate: reset');\r
+ {$ENDIF}\r
+ inflateReset := Z_OK;\r
+end;\r
+\r
+\r
+function inflateEnd(var z : z_stream) : int;\r
+begin\r
+ if (z.state = Z_NULL) or not Assigned(z.zfree) then\r
+ begin\r
+ inflateEnd := Z_STREAM_ERROR;\r
+ exit;\r
+ end;\r
+ if (z.state^.blocks <> Z_NULL) then\r
+ inflate_blocks_free(z.state^.blocks, z);\r
+ ZFREE(z, z.state);\r
+ z.state := Z_NULL;\r
+ {$IFDEF DEBUG}\r
+ Tracev('inflate: end');\r
+ {$ENDIF}\r
+ inflateEnd := Z_OK;\r
+end;\r
+\r
+\r
+function inflateInit2_(var z: z_stream;\r
+ w : int;\r
+ const version : string;\r
+ stream_size : int) : int;\r
+begin\r
+ if (version = '') or (version[1] <> ZLIB_VERSION[1]) or\r
+ (stream_size <> sizeof(z_stream)) then\r
+ begin\r
+ inflateInit2_ := Z_VERSION_ERROR;\r
+ exit;\r
+ end;\r
+ { initialize state }\r
+ { SetLength(strm.msg, 255); }\r
+ z.msg := '';\r
+ if not Assigned(z.zalloc) then\r
+ begin\r
+ {$IFDEF FPC} z.zalloc := @zcalloc; {$ELSE}\r
+ z.zalloc := zcalloc;\r
+ {$endif}\r
+ z.opaque := voidpf(0);\r
+ end;\r
+ if not Assigned(z.zfree) then\r
+ {$IFDEF FPC} z.zfree := @zcfree; {$ELSE}\r
+ z.zfree := zcfree;\r
+ {$ENDIF}\r
+\r
+ z.state := pInternal_state( ZALLOC(z,1,sizeof(internal_state)) );\r
+ if (z.state = Z_NULL) then\r
+ begin\r
+ inflateInit2_ := Z_MEM_ERROR;\r
+ exit;\r
+ end;\r
+\r
+ z.state^.blocks := Z_NULL;\r
+\r
+ { handle undocumented nowrap option (no zlib header or check) }\r
+ z.state^.nowrap := FALSE;\r
+ if (w < 0) then\r
+ begin\r
+ w := - w;\r
+ z.state^.nowrap := TRUE;\r
+ end;\r
+\r
+ { set window size }\r
+ if (w < 8) or (w > 15) then\r
+ begin\r
+ inflateEnd(z);\r
+ inflateInit2_ := Z_STREAM_ERROR;\r
+ exit;\r
+ end;\r
+ z.state^.wbits := uInt(w);\r
+\r
+ { create inflate_blocks state }\r
+ if z.state^.nowrap then\r
+ z.state^.blocks := inflate_blocks_new(z, NIL, uInt(1) shl w)\r
+ else\r
+ {$IFDEF FPC}\r
+ z.state^.blocks := inflate_blocks_new(z, @adler32, uInt(1) shl w);\r
+ {$ELSE}\r
+ z.state^.blocks := inflate_blocks_new(z, adler32, uInt(1) shl w);\r
+ {$ENDIF}\r
+ if (z.state^.blocks = Z_NULL) then\r
+ begin\r
+ inflateEnd(z);\r
+ inflateInit2_ := Z_MEM_ERROR;\r
+ exit;\r
+ end;\r
+ {$IFDEF DEBUG}\r
+ Tracev('inflate: allocated');\r
+ {$ENDIF}\r
+ { reset state }\r
+ inflateReset(z);\r
+ inflateInit2_ := Z_OK;\r
+end;\r
+\r
+function inflateInit2(var z: z_stream; windowBits : int) : int;\r
+begin\r
+ inflateInit2 := inflateInit2_(z, windowBits, ZLIB_VERSION, sizeof(z_stream));\r
+end;\r
+\r
+\r
+function inflateInit(var z : z_stream) : int;\r
+{ inflateInit is a macro to allow checking the zlib version\r
+ and the compiler's view of z_stream: }\r
+begin\r
+ inflateInit := inflateInit2_(z, DEF_WBITS, ZLIB_VERSION, sizeof(z_stream));\r
+end;\r
+\r
+function inflateInit_(z : z_streamp;\r
+ const version : string;\r
+ stream_size : int) : int;\r
+begin\r
+ { initialize state }\r
+ if (z = Z_NULL) then\r
+ inflateInit_ := Z_STREAM_ERROR\r
+ else\r
+ inflateInit_ := inflateInit2_(z^, DEF_WBITS, version, stream_size);\r
+end;\r
+\r
+function inflate(var z : z_stream;\r
+ f : int) : int;\r
+var\r
+ r : int;\r
+ b : uInt;\r
+begin\r
+ if (z.state = Z_NULL) or (z.next_in = Z_NULL) then\r
+ begin\r
+ inflate := Z_STREAM_ERROR;\r
+ exit;\r
+ end;\r
+ if f = Z_FINISH then\r
+ f := Z_BUF_ERROR\r
+ else\r
+ f := Z_OK;\r
+ r := Z_BUF_ERROR;\r
+ while True do\r
+ case (z.state^.mode) of\r
+ BLOCKS:\r
+ begin\r
+ r := inflate_blocks(z.state^.blocks^, z, r);\r
+ if (r = Z_DATA_ERROR) then\r
+ begin\r
+ z.state^.mode := BAD;\r
+ z.state^.sub.marker := 0; { can try inflateSync }\r
+ continue; { break C-switch }\r
+ end;\r
+ if (r = Z_OK) then\r
+ r := f;\r
+ if (r <> Z_STREAM_END) then\r
+ begin\r
+ inflate := r;\r
+ exit;\r
+ end;\r
+ r := f;\r
+ inflate_blocks_reset(z.state^.blocks^, z, @z.state^.sub.check.was);\r
+ if (z.state^.nowrap) then\r
+ begin\r
+ z.state^.mode := DONE;\r
+ continue; { break C-switch }\r
+ end;\r
+ z.state^.mode := CHECK4; { falltrough }\r
+ end;\r
+ CHECK4:\r
+ begin\r
+ {NEEDBYTE}\r
+ if (z.avail_in = 0) then\r
+ begin\r
+ inflate := r;\r
+ exit;\r
+ end;\r
+ r := f;\r
+\r
+ {z.state^.sub.check.need := uLong(NEXTBYTE(z)) shl 24;}\r
+ Dec(z.avail_in);\r
+ Inc(z.total_in);\r
+ z.state^.sub.check.need := uLong(z.next_in^) shl 24;\r
+ Inc(z.next_in);\r
+\r
+ z.state^.mode := CHECK3; { falltrough }\r
+ end;\r
+ CHECK3:\r
+ begin\r
+ {NEEDBYTE}\r
+ if (z.avail_in = 0) then\r
+ begin\r
+ inflate := r;\r
+ exit;\r
+ end;\r
+ r := f;\r
+ {Inc( z.state^.sub.check.need, uLong(NEXTBYTE(z)) shl 16);}\r
+ Dec(z.avail_in);\r
+ Inc(z.total_in);\r
+ Inc(z.state^.sub.check.need, uLong(z.next_in^) shl 16);\r
+ Inc(z.next_in);\r
+\r
+ z.state^.mode := CHECK2; { falltrough }\r
+ end;\r
+ CHECK2:\r
+ begin\r
+ {NEEDBYTE}\r
+ if (z.avail_in = 0) then\r
+ begin\r
+ inflate := r;\r
+ exit;\r
+ end;\r
+ r := f;\r
+\r
+ {Inc( z.state^.sub.check.need, uLong(NEXTBYTE(z)) shl 8);}\r
+ Dec(z.avail_in);\r
+ Inc(z.total_in);\r
+ Inc(z.state^.sub.check.need, uLong(z.next_in^) shl 8);\r
+ Inc(z.next_in);\r
+\r
+ z.state^.mode := CHECK1; { falltrough }\r
+ end;\r
+ CHECK1:\r
+ begin\r
+ {NEEDBYTE}\r
+ if (z.avail_in = 0) then\r
+ begin\r
+ inflate := r;\r
+ exit;\r
+ end;\r
+ r := f;\r
+ {Inc( z.state^.sub.check.need, uLong(NEXTBYTE(z)) );}\r
+ Dec(z.avail_in);\r
+ Inc(z.total_in);\r
+ Inc(z.state^.sub.check.need, uLong(z.next_in^) );\r
+ Inc(z.next_in);\r
+\r
+\r
+ if (z.state^.sub.check.was <> z.state^.sub.check.need) then\r
+ begin\r
+ z.state^.mode := BAD;\r
+ z.msg := 'incorrect data check';\r
+ z.state^.sub.marker := 5; { can't try inflateSync }\r
+ continue; { break C-switch }\r
+ end;\r
+ {$IFDEF DEBUG}\r
+ Tracev('inflate: zlib check ok');\r
+ {$ENDIF}\r
+ z.state^.mode := DONE; { falltrough }\r
+ end;\r
+ DONE:\r
+ begin\r
+ inflate := Z_STREAM_END;\r
+ exit;\r
+ end;\r
+ METHOD:\r
+ begin\r
+ {NEEDBYTE}\r
+ if (z.avail_in = 0) then\r
+ begin\r
+ inflate := r;\r
+ exit;\r
+ end;\r
+ r := f; {}\r
+\r
+ {z.state^.sub.method := NEXTBYTE(z);}\r
+ Dec(z.avail_in);\r
+ Inc(z.total_in);\r
+ z.state^.sub.method := z.next_in^;\r
+ Inc(z.next_in);\r
+\r
+ if ((z.state^.sub.method and $0f) <> Z_DEFLATED) then\r
+ begin\r
+ z.state^.mode := BAD;\r
+ z.msg := 'unknown compression method';\r
+ z.state^.sub.marker := 5; { can't try inflateSync }\r
+ continue; { break C-switch }\r
+ end;\r
+ if ((z.state^.sub.method shr 4) + 8 > z.state^.wbits) then\r
+ begin\r
+ z.state^.mode := BAD;\r
+ z.msg := 'invalid window size';\r
+ z.state^.sub.marker := 5; { can't try inflateSync }\r
+ continue; { break C-switch }\r
+ end;\r
+ z.state^.mode := FLAG;\r
+ { fall trough }\r
+ end;\r
+ FLAG:\r
+ begin\r
+ {NEEDBYTE}\r
+ if (z.avail_in = 0) then\r
+ begin\r
+ inflate := r;\r
+ exit;\r
+ end;\r
+ r := f; {}\r
+ {b := NEXTBYTE(z);}\r
+ Dec(z.avail_in);\r
+ Inc(z.total_in);\r
+ b := z.next_in^;\r
+ Inc(z.next_in);\r
+\r
+ if (((z.state^.sub.method shl 8) + b) mod 31) <> 0 then {% mod ?}\r
+ begin\r
+ z.state^.mode := BAD;\r
+ z.msg := 'incorrect header check';\r
+ z.state^.sub.marker := 5; { can't try inflateSync }\r
+ continue; { break C-switch }\r
+ end;\r
+ {$IFDEF DEBUG}\r
+ Tracev('inflate: zlib header ok');\r
+ {$ENDIF}\r
+ if ((b and PRESET_DICT) = 0) then\r
+ begin\r
+ z.state^.mode := BLOCKS;\r
+ continue; { break C-switch }\r
+ end;\r
+ z.state^.mode := DICT4;\r
+ { falltrough }\r
+ end;\r
+ DICT4:\r
+ begin\r
+ if (z.avail_in = 0) then\r
+ begin\r
+ inflate := r;\r
+ exit;\r
+ end;\r
+ r := f;\r
+\r
+ {z.state^.sub.check.need := uLong(NEXTBYTE(z)) shl 24;}\r
+ Dec(z.avail_in);\r
+ Inc(z.total_in);\r
+ z.state^.sub.check.need := uLong(z.next_in^) shl 24;\r
+ Inc(z.next_in);\r
+\r
+ z.state^.mode := DICT3; { falltrough }\r
+ end;\r
+ DICT3:\r
+ begin\r
+ if (z.avail_in = 0) then\r
+ begin\r
+ inflate := r;\r
+ exit;\r
+ end;\r
+ r := f;\r
+ {Inc(z.state^.sub.check.need, uLong(NEXTBYTE(z)) shl 16);}\r
+ Dec(z.avail_in);\r
+ Inc(z.total_in);\r
+ Inc(z.state^.sub.check.need, uLong(z.next_in^) shl 16);\r
+ Inc(z.next_in);\r
+\r
+ z.state^.mode := DICT2; { falltrough }\r
+ end;\r
+ DICT2:\r
+ begin\r
+ if (z.avail_in = 0) then\r
+ begin\r
+ inflate := r;\r
+ exit;\r
+ end;\r
+ r := f;\r
+\r
+ {Inc(z.state^.sub.check.need, uLong(NEXTBYTE(z)) shl 8);}\r
+ Dec(z.avail_in);\r
+ Inc(z.total_in);\r
+ Inc(z.state^.sub.check.need, uLong(z.next_in^) shl 8);\r
+ Inc(z.next_in);\r
+\r
+ z.state^.mode := DICT1; { falltrough }\r
+ end;\r
+ DICT1:\r
+ begin\r
+ if (z.avail_in = 0) then\r
+ begin\r
+ inflate := r;\r
+ exit;\r
+ end;\r
+ { r := f; --- wird niemals benutzt }\r
+ {Inc(z.state^.sub.check.need, uLong(NEXTBYTE(z)) );}\r
+ Dec(z.avail_in);\r
+ Inc(z.total_in);\r
+ Inc(z.state^.sub.check.need, uLong(z.next_in^) );\r
+ Inc(z.next_in);\r
+\r
+ z.adler := z.state^.sub.check.need;\r
+ z.state^.mode := DICT0;\r
+ inflate := Z_NEED_DICT;\r
+ exit;\r
+ end;\r
+ DICT0:\r
+ begin\r
+ z.state^.mode := BAD;\r
+ z.msg := 'need dictionary';\r
+ z.state^.sub.marker := 0; { can try inflateSync }\r
+ inflate := Z_STREAM_ERROR;\r
+ exit;\r
+ end;\r
+ BAD:\r
+ begin\r
+ inflate := Z_DATA_ERROR;\r
+ exit;\r
+ end;\r
+ else\r
+ begin\r
+ inflate := Z_STREAM_ERROR;\r
+ exit;\r
+ end;\r
+ end;\r
+{$ifdef NEED_DUMMY_result}\r
+ result := Z_STREAM_ERROR; { Some dumb compilers complain without this }\r
+{$endif}\r
+end;\r
+\r
+function inflateSetDictionary(var z : z_stream;\r
+ dictionary : pBytef; {const array of byte}\r
+ dictLength : uInt) : int;\r
+var\r
+ length : uInt;\r
+begin\r
+ length := dictLength;\r
+\r
+ if (z.state = Z_NULL) or (z.state^.mode <> DICT0) then\r
+ begin\r
+ inflateSetDictionary := Z_STREAM_ERROR;\r
+ exit;\r
+ end;\r
+ if (adler32(Long(1), dictionary, dictLength) <> z.adler) then\r
+ begin\r
+ inflateSetDictionary := Z_DATA_ERROR;\r
+ exit;\r
+ end;\r
+ z.adler := Long(1);\r
+\r
+ if (length >= (uInt(1) shl z.state^.wbits)) then\r
+ begin\r
+ length := (1 shl z.state^.wbits)-1;\r
+ Inc( dictionary, dictLength - length);\r
+ end;\r
+ inflate_set_dictionary(z.state^.blocks^, dictionary^, length);\r
+ z.state^.mode := BLOCKS;\r
+ inflateSetDictionary := Z_OK;\r
+end;\r
+\r
+\r
+function inflateSync(var z : z_stream) : int;\r
+const\r
+ mark : packed array[0..3] of byte = (0, 0, $ff, $ff);\r
+var\r
+ n : uInt; { number of bytes to look at }\r
+ p : pBytef; { pointer to bytes }\r
+ m : uInt; { number of marker bytes found in a row }\r
+ r, w : uLong; { temporaries to save total_in and total_out }\r
+begin\r
+ { set up }\r
+ if (z.state = Z_NULL) then\r
+ begin\r
+ inflateSync := Z_STREAM_ERROR;\r
+ exit;\r
+ end;\r
+ if (z.state^.mode <> BAD) then\r
+ begin\r
+ z.state^.mode := BAD;\r
+ z.state^.sub.marker := 0;\r
+ end;\r
+ n := z.avail_in;\r
+ if (n = 0) then\r
+ begin\r
+ inflateSync := Z_BUF_ERROR;\r
+ exit;\r
+ end;\r
+ p := z.next_in;\r
+ m := z.state^.sub.marker;\r
+\r
+ { search }\r
+ while (n <> 0) and (m < 4) do\r
+ begin\r
+ if (p^ = mark[m]) then\r
+ Inc(m)\r
+ else\r
+ if (p^ <> 0) then\r
+ m := 0\r
+ else\r
+ m := 4 - m;\r
+ Inc(p);\r
+ Dec(n);\r
+ end;\r
+\r
+ { restore }\r
+ Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));\r
+ z.next_in := p;\r
+ z.avail_in := n;\r
+ z.state^.sub.marker := m;\r
+\r
+\r
+ { return no joy or set up to restart on a new block }\r
+ if (m <> 4) then\r
+ begin\r
+ inflateSync := Z_DATA_ERROR;\r
+ exit;\r
+ end;\r
+ r := z.total_in;\r
+ w := z.total_out;\r
+ inflateReset(z);\r
+ z.total_in := r;\r
+ z.total_out := w;\r
+ z.state^.mode := BLOCKS;\r
+ inflateSync := Z_OK;\r
+end;\r
+\r
+\r
+{\r
+ returns true if inflate is currently at the end of a block generated\r
+ by Z_SYNC_FLUSH or Z_FULL_FLUSH. This function is used by one PPP\r
+ implementation to provide an additional safety check. PPP uses Z_SYNC_FLUSH\r
+ but removes the length bytes of the resulting empty stored block. When\r
+ decompressing, PPP checks that at the end of input packet, inflate is\r
+ waiting for these length bytes.\r
+}\r
+\r
+function inflateSyncPoint(var z : z_stream) : int;\r
+begin\r
+ if (z.state = Z_NULL) or (z.state^.blocks = Z_NULL) then\r
+ begin\r
+ inflateSyncPoint := Z_STREAM_ERROR;\r
+ exit;\r
+ end;\r
+ inflateSyncPoint := inflate_blocks_sync_point(z.state^.blocks^);\r
+end;\r
+\r
+end.\r
--- /dev/null
+Unit Zlib;\r
+\r
+\r
+{ Original:\r
+ zlib.h -- interface of the 'zlib' general purpose compression library\r
+ version 1.1.0, Feb 24th, 1998\r
+\r
+ Copyright (C) 1995-1998 Jean-loup Gailly and Mark Adler\r
+\r
+ This software is provided 'as-is', without any express or implied\r
+ warranty. In no event will the authors be held liable for any damages\r
+ arising from the use of this software.\r
+\r
+ Permission is granted to anyone to use this software for any purpose,\r
+ including commercial applications, and to alter it and redistribute it\r
+ freely, subject to the following restrictions:\r
+\r
+ 1. The origin of this software must not be misrepresented; you must not\r
+ claim that you wrote the original software. If you use this software\r
+ in a product, an acknowledgment in the product documentation would be\r
+ appreciated but is not required.\r
+ 2. Altered source versions must be plainly marked as such, and must not be\r
+ misrepresented as being the original software.\r
+ 3. This notice may not be removed or altered from any source distribution.\r
+\r
+ Jean-loup Gailly Mark Adler\r
+ jloup@gzip.org madler@alumni.caltech.edu\r
+\r
+\r
+ The data format used by the zlib library is described by RFCs (Request for\r
+ Comments) 1950 to 1952 in the files ftp://ds.internic.net/rfc/rfc1950.txt\r
+ (zlib format), rfc1951.txt (deflate format) and rfc1952.txt (gzip format).\r
+\r
+\r
+ Pascal tranlastion\r
+ Copyright (C) 1998 by Jacques Nomssi Nzali\r
+ For conditions of distribution and use, see copyright notice in readme.txt\r
+}\r
+\r
+interface\r
+\r
+{$I zconf.inc}\r
+\r
+uses\r
+ zutil;\r
+\r
+{ zconf.h -- configuration of the zlib compression library }\r
+{ zutil.c -- target dependent utility functions for the compression library }\r
+\r
+{ The 'zlib' compression library provides in-memory compression and\r
+ decompression functions, including integrity checks of the uncompressed\r
+ data. This version of the library supports only one compression method\r
+ (deflation) but other algorithms will be added later and will have the same\r
+ stream interface.\r
+\r
+ Compression can be done in a single step if the buffers are large\r
+ enough (for example if an input file is mmap'ed), or can be done by\r
+ repeated calls of the compression function. In the latter case, the\r
+ application must provide more input and/or consume the output\r
+ (providing more output space) before each call.\r
+\r
+ The library also supports reading and writing files in gzip (.gz) format\r
+ with an interface similar to that of stdio.\r
+\r
+ The library does not install any signal handler. The decoder checks\r
+ the consistency of the compressed data, so the library should never\r
+ crash even in case of corrupted input. }\r
+\r
+\r
+\r
+{ Compile with -DMAXSEG_64K if the alloc function cannot allocate more\r
+ than 64k bytes at a time (needed on systems with 16-bit int). }\r
+\r
+{ Maximum value for memLevel in deflateInit2 }\r
+{$ifdef MAXSEG_64K}\r
+ {$IFDEF VER70}\r
+ const\r
+ MAX_MEM_LEVEL = 7;\r
+ DEF_MEM_LEVEL = MAX_MEM_LEVEL; { default memLevel }\r
+ {$ELSE}\r
+ const\r
+ MAX_MEM_LEVEL = 8;\r
+ DEF_MEM_LEVEL = MAX_MEM_LEVEL; { default memLevel }\r
+ {$ENDIF}\r
+{$else}\r
+const\r
+ MAX_MEM_LEVEL = 9;\r
+ DEF_MEM_LEVEL = 8; { if MAX_MEM_LEVEL > 8 }\r
+{$endif}\r
+\r
+{ Maximum value for windowBits in deflateInit2 and inflateInit2 }\r
+const\r
+{$IFDEF VER70}\r
+ MAX_WBITS = 14; { 32K LZ77 window }\r
+{$ELSE}\r
+ MAX_WBITS = 15; { 32K LZ77 window }\r
+{$ENDIF}\r
+\r
+{ default windowBits for decompression. MAX_WBITS is for compression only }\r
+const\r
+ DEF_WBITS = MAX_WBITS;\r
+\r
+{ The memory requirements for deflate are (in bytes):\r
+ 1 shl (windowBits+2) + 1 shl (memLevel+9)\r
+ that is: 128K for windowBits=15 + 128K for memLevel = 8 (default values)\r
+ plus a few kilobytes for small objects. For example, if you want to reduce\r
+ the default memory requirements from 256K to 128K, compile with\r
+ DMAX_WBITS=14 DMAX_MEM_LEVEL=7\r
+ Of course this will generally degrade compression (there's no free lunch).\r
+\r
+ The memory requirements for inflate are (in bytes) 1 shl windowBits\r
+ that is, 32K for windowBits=15 (default value) plus a few kilobytes\r
+ for small objects. }\r
+\r
+\r
+{ Huffman code lookup table entry--this entry is four bytes for machines\r
+ that have 16-bit pointers (e.g. PC's in the small or medium model). }\r
+\r
+type\r
+ pInflate_huft = ^inflate_huft;\r
+ inflate_huft = Record\r
+ Exop, { number of extra bits or operation }\r
+ bits : Byte; { number of bits in this code or subcode }\r
+ {pad : uInt;} { pad structure to a power of 2 (4 bytes for }\r
+ { 16-bit, 8 bytes for 32-bit int's) }\r
+ base : uInt; { literal, length base, or distance base }\r
+ { or table offset }\r
+ End;\r
+\r
+type\r
+ huft_field = Array[0..(MaxMemBlock div SizeOf(inflate_huft))-1] of inflate_huft;\r
+ huft_ptr = ^huft_field;\r
+type\r
+ ppInflate_huft = ^pInflate_huft;\r
+\r
+type\r
+ inflate_codes_mode = ( { waiting for "i:"=input, "o:"=output, "x:"=nothing }\r
+ START, { x: set up for LEN }\r
+ LEN, { i: get length/literal/eob next }\r
+ LENEXT, { i: getting length extra (have base) }\r
+ DIST, { i: get distance next }\r
+ DISTEXT, { i: getting distance extra }\r
+ COPY, { o: copying bytes in window, waiting for space }\r
+ LIT, { o: got literal, waiting for output space }\r
+ WASH, { o: got eob, possibly still output waiting }\r
+ ZEND, { x: got eob and all data flushed }\r
+ BADCODE); { x: got error }\r
+\r
+{ inflate codes private state }\r
+type\r
+ pInflate_codes_state = ^inflate_codes_state;\r
+ inflate_codes_state = record\r
+\r
+ mode : inflate_codes_mode; { current inflate_codes mode }\r
+\r
+ { mode dependent information }\r
+ len : uInt;\r
+ sub : record { submode }\r
+ Case Byte of\r
+ 0:(code : record { if LEN or DIST, where in tree }\r
+ tree : pInflate_huft; { pointer into tree }\r
+ need : uInt; { bits needed }\r
+ end);\r
+ 1:(lit : uInt); { if LIT, literal }\r
+ 2:(copy: record { if EXT or COPY, where and how much }\r
+ get : uInt; { bits to get for extra }\r
+ dist : uInt; { distance back to copy from }\r
+ end);\r
+ end;\r
+\r
+ { mode independent information }\r
+ lbits : Byte; { ltree bits decoded per branch }\r
+ dbits : Byte; { dtree bits decoder per branch }\r
+ ltree : pInflate_huft; { literal/length/eob tree }\r
+ dtree : pInflate_huft; { distance tree }\r
+ end;\r
+\r
+type\r
+ check_func = function(check : uLong;\r
+ buf : pBytef;\r
+ {const buf : array of byte;}\r
+ len : uInt) : uLong;\r
+type\r
+ inflate_block_mode =\r
+ (ZTYPE, { get type bits (3, including end bit) }\r
+ LENS, { get lengths for stored }\r
+ STORED, { processing stored block }\r
+ TABLE, { get table lengths }\r
+ BTREE, { get bit lengths tree for a dynamic block }\r
+ DTREE, { get length, distance trees for a dynamic block }\r
+ CODES, { processing fixed or dynamic block }\r
+ DRY, { output remaining window bytes }\r
+ BLKDONE, { finished last block, done }\r
+ BLKBAD); { got a data error--stuck here }\r
+\r
+type\r
+ pInflate_blocks_state = ^inflate_blocks_state;\r
+\r
+{ inflate blocks semi-private state }\r
+ inflate_blocks_state = record\r
+\r
+ mode : inflate_block_mode; { current inflate_block mode }\r
+\r
+ { mode dependent information }\r
+ sub : record { submode }\r
+ case Byte of\r
+ 0:(left : uInt); { if STORED, bytes left to copy }\r
+ 1:(trees : record { if DTREE, decoding info for trees }\r
+ table : uInt; { table lengths (14 bits) }\r
+ index : uInt; { index into blens (or border) }\r
+ blens : PuIntArray; { bit lengths of codes }\r
+ bb : uInt; { bit length tree depth }\r
+ tb : pInflate_huft; { bit length decoding tree }\r
+ end);\r
+ 2:(decode : record { if CODES, current state }\r
+ tl : pInflate_huft;\r
+ td : pInflate_huft; { trees to free }\r
+ codes : pInflate_codes_state;\r
+ end);\r
+ end;\r
+ last : boolean; { true if this block is the last block }\r
+\r
+ { mode independent information }\r
+ bitk : uInt; { bits in bit buffer }\r
+ bitb : uLong; { bit buffer }\r
+ hufts : huft_ptr; {pInflate_huft;} { single malloc for tree space }\r
+ window : pBytef; { sliding window }\r
+ zend : pBytef; { one byte after sliding window }\r
+ read : pBytef; { window read pointer }\r
+ write : pBytef; { window write pointer }\r
+ checkfn : check_func; { check function }\r
+ check : uLong; { check on output }\r
+ end;\r
+\r
+type\r
+ inflate_mode = (\r
+ METHOD, { waiting for method byte }\r
+ FLAG, { waiting for flag byte }\r
+ DICT4, { four dictionary check bytes to go }\r
+ DICT3, { three dictionary check bytes to go }\r
+ DICT2, { two dictionary check bytes to go }\r
+ DICT1, { one dictionary check byte to go }\r
+ DICT0, { waiting for inflateSetDictionary }\r
+ BLOCKS, { decompressing blocks }\r
+ CHECK4, { four check bytes to go }\r
+ CHECK3, { three check bytes to go }\r
+ CHECK2, { two check bytes to go }\r
+ CHECK1, { one check byte to go }\r
+ DONE, { finished check, done }\r
+ BAD); { got an error--stay here }\r
+\r
+{ inflate private state }\r
+type\r
+ pInternal_state = ^internal_state; { or point to a deflate_state record }\r
+ internal_state = record\r
+\r
+ mode : inflate_mode; { current inflate mode }\r
+\r
+ { mode dependent information }\r
+ sub : record { submode }\r
+ case byte of\r
+ 0:(method : uInt); { if FLAGS, method byte }\r
+ 1:(check : record { if CHECK, check values to compare }\r
+ was : uLong; { computed check value }\r
+ need : uLong; { stream check value }\r
+ end);\r
+ 2:(marker : uInt); { if BAD, inflateSync's marker bytes count }\r
+ end;\r
+\r
+ { mode independent information }\r
+ nowrap : boolean; { flag for no wrapper }\r
+ wbits : uInt; { log2(window size) (8..15, defaults to 15) }\r
+ blocks : pInflate_blocks_state; { current inflate_blocks state }\r
+ end;\r
+\r
+type\r
+ alloc_func = function(opaque : voidpf; items : uInt; size : uInt) : voidpf;\r
+ free_func = procedure(opaque : voidpf; address : voidpf);\r
+\r
+type\r
+ z_streamp = ^z_stream;\r
+ z_stream = record\r
+ next_in : pBytef; { next input byte }\r
+ avail_in : uInt; { number of bytes available at next_in }\r
+ total_in : uLong; { total nb of input bytes read so far }\r
+\r
+ next_out : pBytef; { next output byte should be put there }\r
+ avail_out : uInt; { remaining free space at next_out }\r
+ total_out : uLong; { total nb of bytes output so far }\r
+\r
+ msg : string[255]; { last error message, '' if no error }\r
+ state : pInternal_state; { not visible by applications }\r
+\r
+ zalloc : alloc_func; { used to allocate the internal state }\r
+ zfree : free_func; { used to free the internal state }\r
+ opaque : voidpf; { private data object passed to zalloc and zfree }\r
+\r
+ data_type : int; { best guess about the data type: ascii or binary }\r
+ adler : uLong; { adler32 value of the uncompressed data }\r
+ reserved : uLong; { reserved for future use }\r
+ end;\r
+\r
+\r
+{ The application must update next_in and avail_in when avail_in has\r
+ dropped to zero. It must update next_out and avail_out when avail_out\r
+ has dropped to zero. The application must initialize zalloc, zfree and\r
+ opaque before calling the init function. All other fields are set by the\r
+ compression library and must not be updated by the application.\r
+\r
+ The opaque value provided by the application will be passed as the first\r
+ parameter for calls of zalloc and zfree. This can be useful for custom\r
+ memory management. The compression library attaches no meaning to the\r
+ opaque value.\r
+\r
+ zalloc must return Z_NULL if there is not enough memory for the object.\r
+ On 16-bit systems, the functions zalloc and zfree must be able to allocate\r
+ exactly 65536 bytes, but will not be required to allocate more than this\r
+ if the symbol MAXSEG_64K is defined (see zconf.h). WARNING: On MSDOS,\r
+ pointers returned by zalloc for objects of exactly 65536 bytes *must*\r
+ have their offset normalized to zero. The default allocation function\r
+ provided by this library ensures this (see zutil.c). To reduce memory\r
+ requirements and avoid any allocation of 64K objects, at the expense of\r
+ compression ratio, compile the library with -DMAX_WBITS=14 (see zconf.h).\r
+\r
+ The fields total_in and total_out can be used for statistics or\r
+ progress reports. After compression, total_in holds the total size of\r
+ the uncompressed data and may be saved for use in the decompressor\r
+ (particularly if the decompressor wants to decompress everything in\r
+ a single step). }\r
+\r
+const { constants }\r
+ Z_NO_FLUSH = 0;\r
+ Z_PARTIAL_FLUSH = 1;\r
+ Z_SYNC_FLUSH = 2;\r
+ Z_FULL_FLUSH = 3;\r
+ Z_FINISH = 4;\r
+{ Allowed flush values; see deflate() below for details }\r
+\r
+ Z_OK = 0;\r
+ Z_STREAM_END = 1;\r
+ Z_NEED_DICT = 2;\r
+ Z_ERRNO = (-1);\r
+ Z_STREAM_ERROR = (-2);\r
+ Z_DATA_ERROR = (-3);\r
+ Z_MEM_ERROR = (-4);\r
+ Z_BUF_ERROR = (-5);\r
+ Z_VERSION_ERROR = (-6);\r
+{ Return codes for the compression/decompression functions. Negative\r
+ values are errors, positive values are used for special but normal events.}\r
+\r
+ Z_NO_COMPRESSION = 0;\r
+ Z_BEST_SPEED = 1;\r
+ Z_BEST_COMPRESSION = 9;\r
+ Z_DEFAULT_COMPRESSION = (-1);\r
+{ compression levels }\r
+\r
+ Z_FILTERED = 1;\r
+ Z_HUFFMAN_ONLY = 2;\r
+ Z_DEFAULT_STRATEGY = 0;\r
+{ compression strategy; see deflateInit2() below for details }\r
+\r
+ Z_BINARY = 0;\r
+ Z_ASCII = 1;\r
+ Z_UNKNOWN = 2;\r
+{ Possible values of the data_type field }\r
+\r
+ Z_DEFLATED = 8;\r
+{ The deflate compression method (the only one supported in this version) }\r
+\r
+ Z_NULL = NIL; { for initializing zalloc, zfree, opaque }\r
+\r
+ {$IFDEF GZIO}\r
+var\r
+ errno : int;\r
+ {$ENDIF}\r
+\r
+ { common constants }\r
+\r
+\r
+{ The three kinds of block type }\r
+const\r
+ STORED_BLOCK = 0;\r
+ STATIC_TREES = 1;\r
+ DYN_TREES = 2;\r
+{ The minimum and maximum match lengths }\r
+const\r
+ MIN_MATCH = 3;\r
+{$ifdef MAX_MATCH_IS_258}\r
+ MAX_MATCH = 258;\r
+{$else}\r
+ MAX_MATCH = ??; { deliberate syntax error }\r
+{$endif}\r
+\r
+const\r
+ PRESET_DICT = $20; { preset dictionary flag in zlib header }\r
+\r
+\r
+ {$IFDEF DEBUG}\r
+ procedure Assert(cond : boolean; msg : string);\r
+ {$ENDIF}\r
+\r
+ procedure Trace(x : string);\r
+ procedure Tracev(x : string);\r
+ procedure Tracevv(x : string);\r
+ procedure Tracevvv(x : string);\r
+ procedure Tracec(c : boolean; x : string);\r
+ procedure Tracecv(c : boolean; x : string);\r
+\r
+function zlibVersion : string;\r
+{ The application can compare zlibVersion and ZLIB_VERSION for consistency.\r
+ If the first character differs, the library code actually used is\r
+ not compatible with the zlib.h header file used by the application.\r
+ This check is automatically made by deflateInit and inflateInit. }\r
+\r
+function zError(err : int) : string;\r
+\r
+function ZALLOC (var strm : z_stream; items : uInt; size : uInt) : voidpf;\r
+\r
+procedure ZFREE (var strm : z_stream; ptr : voidpf);\r
+\r
+procedure TRY_FREE (var strm : z_stream; ptr : voidpf);\r
+\r
+const\r
+ ZLIB_VERSION : string[10] = '1.1.2';\r
+\r
+const\r
+ z_errbase = Z_NEED_DICT;\r
+ z_errmsg : Array[0..9] of string[21] = { indexed by 2-zlib_error }\r
+ ('need dictionary', { Z_NEED_DICT 2 }\r
+ 'stream end', { Z_STREAM_END 1 }\r
+ '', { Z_OK 0 }\r
+ 'file error', { Z_ERRNO (-1) }\r
+ 'stream error', { Z_STREAM_ERROR (-2) }\r
+ 'data error', { Z_DATA_ERROR (-3) }\r
+ 'insufficient memory', { Z_MEM_ERROR (-4) }\r
+ 'buffer error', { Z_BUF_ERROR (-5) }\r
+ 'incompatible version',{ Z_VERSION_ERROR (-6) }\r
+ '');\r
+const\r
+ z_verbose : int = 1;\r
+\r
+{$IFDEF DEBUG}\r
+procedure z_error (m : string);\r
+{$ENDIF}\r
+\r
+implementation\r
+\r
+function zError(err : int) : string;\r
+begin\r
+ zError := z_errmsg[Z_NEED_DICT-err];\r
+end;\r
+\r
+function zlibVersion : string;\r
+begin\r
+ zlibVersion := ZLIB_VERSION;\r
+end;\r
+\r
+procedure z_error (m : string);\r
+begin\r
+ WriteLn(output, m);\r
+ Write('Zlib - Halt...');\r
+ ReadLn;\r
+ Halt(1);\r
+end;\r
+\r
+procedure Assert(cond : boolean; msg : string);\r
+begin\r
+ if not cond then\r
+ z_error(msg);\r
+end;\r
+\r
+procedure Trace(x : string);\r
+begin\r
+ WriteLn(x);\r
+end;\r
+\r
+procedure Tracev(x : string);\r
+begin\r
+ if (z_verbose>0) then\r
+ WriteLn(x);\r
+end;\r
+\r
+procedure Tracevv(x : string);\r
+begin\r
+ if (z_verbose>1) then\r
+ WriteLn(x);\r
+end;\r
+\r
+procedure Tracevvv(x : string);\r
+begin\r
+ if (z_verbose>2) then\r
+ WriteLn(x);\r
+end;\r
+\r
+procedure Tracec(c : boolean; x : string);\r
+begin\r
+ if (z_verbose>0) and (c) then\r
+ WriteLn(x);\r
+end;\r
+\r
+procedure Tracecv(c : boolean; x : string);\r
+begin\r
+ if (z_verbose>1) and c then\r
+ WriteLn(x);\r
+end;\r
+\r
+function ZALLOC (var strm : z_stream; items : uInt; size : uInt) : voidpf;\r
+begin\r
+ ZALLOC := strm.zalloc(strm.opaque, items, size);\r
+end;\r
+\r
+procedure ZFREE (var strm : z_stream; ptr : voidpf);\r
+begin\r
+ strm.zfree(strm.opaque, ptr);\r
+end;\r
+\r
+procedure TRY_FREE (var strm : z_stream; ptr : voidpf);\r
+begin\r
+ {if @strm <> Z_NULL then}\r
+ strm.zfree(strm.opaque, ptr);\r
+end;\r
+\r
+end.
\ No newline at end of file
--- /dev/null
+//Modified by plugwash for 64 bit support\r
+Unit ZUtil;\r
+\r
+{\r
+ Copyright (C) 1998 by Jacques Nomssi Nzali\r
+ For conditions of distribution and use, see copyright notice in readme.paszlib\r
+}\r
+\r
+interface\r
+\r
+{$I zconf.inc}\r
+\r
+{ Type declarations }\r
+\r
+type\r
+ {Byte = usigned char; 8 bits}\r
+ Bytef = byte;\r
+ charf = byte;\r
+\r
+{$IFDEF FPC}\r
+ int = longint;\r
+{$ELSE}\r
+ int = integer;\r
+{$ENDIF}\r
+\r
+ intf = int;\r
+{$IFDEF MSDOS}\r
+ uInt = Word;\r
+{$ELSE}\r
+ {$IFDEF FPC}\r
+ uInt = longint; { 16 bits or more }\r
+ {$INFO Cardinal}\r
+ {$ELSE}\r
+ uInt = cardinal; { 16 bits or more }\r
+ {$ENDIF}\r
+{$ENDIF}\r
+ uIntf = uInt;\r
+\r
+ Long = longint;\r
+{$ifdef Delphi5} \r
+ uLong = Cardinal;\r
+{$else}\r
+ uLong = LongInt; { 32 bits or more }\r
+{$endif}\r
+ uLongf = uLong;\r
+\r
+ voidp = pointer;\r
+ voidpf = voidp;\r
+ pBytef = ^Bytef;\r
+ pIntf = ^intf;\r
+ puIntf = ^uIntf;\r
+ puLong = ^uLongf;\r
+ {$ifdef fpc}\r
+ ptr2int = sizeint;\r
+ {$else}\r
+ ptr2int = uInt;\r
+ {$endif}\r
+{ a pointer to integer casting is used to do pointer arithmetic.\r
+ ptr2int must be an integer type and sizeof(ptr2int) must be less\r
+ than sizeof(pointer) - Nomssi }\r
+\r
+const\r
+ {$IFDEF MAXSEG_64K}\r
+ MaxMemBlock = $FFFF;\r
+ {$ELSE}\r
+ MaxMemBlock = MaxInt;\r
+ {$ENDIF}\r
+\r
+type\r
+ zByteArray = array[0..(MaxMemBlock div SizeOf(Bytef))-1] of Bytef;\r
+ pzByteArray = ^zByteArray;\r
+type\r
+ zIntfArray = array[0..(MaxMemBlock div SizeOf(Intf))-1] of Intf;\r
+ pzIntfArray = ^zIntfArray;\r
+type\r
+ zuIntArray = array[0..(MaxMemBlock div SizeOf(uInt))-1] of uInt;\r
+ PuIntArray = ^zuIntArray;\r
+\r
+{ Type declarations - only for deflate }\r
+\r
+type\r
+ uch = Byte;\r
+ uchf = uch; { FAR }\r
+ ush = Word;\r
+ ushf = ush;\r
+ ulg = LongInt;\r
+\r
+ unsigned = uInt;\r
+\r
+ pcharf = ^charf;\r
+ puchf = ^uchf;\r
+ pushf = ^ushf;\r
+\r
+type\r
+ zuchfArray = zByteArray;\r
+ puchfArray = ^zuchfArray;\r
+type\r
+ zushfArray = array[0..(MaxMemBlock div SizeOf(ushf))-1] of ushf;\r
+ pushfArray = ^zushfArray;\r
+\r
+procedure zmemcpy(destp : pBytef; sourcep : pBytef; len : uInt);\r
+function zmemcmp(s1p, s2p : pBytef; len : uInt) : int;\r
+procedure zmemzero(destp : pBytef; len : uInt);\r
+procedure zcfree(opaque : voidpf; ptr : voidpf);\r
+function zcalloc (opaque : voidpf; items : uInt; size : uInt) : voidpf;\r
+\r
+implementation\r
+\r
+{$ifdef ver80}\r
+ {$define Delphi16}\r
+{$endif}\r
+{$ifdef ver70}\r
+ {$define HugeMem}\r
+{$endif}\r
+{$ifdef ver60}\r
+ {$define HugeMem}\r
+{$endif}\r
+\r
+{$IFDEF CALLDOS}\r
+uses\r
+ WinDos;\r
+{$ENDIF}\r
+{$IFDEF Delphi16}\r
+uses\r
+ WinTypes,\r
+ WinProcs;\r
+{$ENDIF}\r
+{$IFNDEF FPC}\r
+ {$IFDEF DPMI}\r
+ uses\r
+ WinAPI;\r
+ {$ENDIF}\r
+{$ENDIF}\r
+\r
+{$IFDEF CALLDOS}\r
+{ reduce your application memory footprint with $M before using this }\r
+function dosAlloc (Size : Longint) : Pointer;\r
+var\r
+ regs: TRegisters;\r
+begin\r
+ regs.bx := (Size + 15) div 16; { number of 16-bytes-paragraphs }\r
+ regs.ah := $48; { Allocate memory block }\r
+ msdos(regs);\r
+ if regs.Flags and FCarry <> 0 then\r
+ DosAlloc := NIL\r
+ else\r
+ DosAlloc := Ptr(regs.ax, 0);\r
+end;\r
+\r
+\r
+function dosFree(P : pointer) : boolean;\r
+var\r
+ regs: TRegisters;\r
+begin\r
+ dosFree := FALSE;\r
+ regs.bx := Seg(P^); { segment }\r
+ if Ofs(P) <> 0 then\r
+ exit;\r
+ regs.ah := $49; { Free memory block }\r
+ msdos(regs);\r
+ dosFree := (regs.Flags and FCarry = 0);\r
+end;\r
+{$ENDIF}\r
+\r
+type\r
+ LH = record\r
+ L, H : word;\r
+ end;\r
+\r
+{$IFDEF HugeMem}\r
+ {$define HEAP_LIST}\r
+{$endif}\r
+\r
+{$IFDEF HEAP_LIST} {--- to avoid Mark and Release --- }\r
+const\r
+ MaxAllocEntries = 50;\r
+type\r
+ TMemRec = record\r
+ orgvalue,\r
+ value : pointer;\r
+ size: longint;\r
+ end;\r
+const\r
+ allocatedCount : 0..MaxAllocEntries = 0;\r
+var\r
+ allocatedList : array[0..MaxAllocEntries-1] of TMemRec;\r
+\r
+ function NewAllocation(ptr0, ptr : pointer; memsize : longint) : boolean;\r
+ begin\r
+ if (allocatedCount < MaxAllocEntries) and (ptr0 <> NIL) then\r
+ begin\r
+ with allocatedList[allocatedCount] do\r
+ begin\r
+ orgvalue := ptr0;\r
+ value := ptr;\r
+ size := memsize;\r
+ end;\r
+ Inc(allocatedCount); { we don't check for duplicate }\r
+ NewAllocation := TRUE;\r
+ end\r
+ else\r
+ NewAllocation := FALSE;\r
+ end;\r
+{$ENDIF}\r
+\r
+{$IFDEF HugeMem}\r
+\r
+{ The code below is extremely version specific to the TP 6/7 heap manager!!}\r
+type\r
+ PFreeRec = ^TFreeRec;\r
+ TFreeRec = record\r
+ next: PFreeRec;\r
+ size: Pointer;\r
+ end;\r
+type\r
+ HugePtr = voidpf;\r
+\r
+\r
+ procedure IncPtr(var p:pointer;count:word);\r
+ { Increments pointer }\r
+ begin\r
+ inc(LH(p).L,count);\r
+ if LH(p).L < count then\r
+ inc(LH(p).H,SelectorInc); { $1000 }\r
+ end;\r
+\r
+ procedure DecPtr(var p:pointer;count:word);\r
+ { decrements pointer }\r
+ begin\r
+ if count > LH(p).L then\r
+ dec(LH(p).H,SelectorInc);\r
+ dec(LH(p).L,Count);\r
+ end;\r
+\r
+ procedure IncPtrLong(var p:pointer;count:longint);\r
+ { Increments pointer; assumes count > 0 }\r
+ begin\r
+ inc(LH(p).H,SelectorInc*LH(count).H);\r
+ inc(LH(p).L,LH(Count).L);\r
+ if LH(p).L < LH(count).L then\r
+ inc(LH(p).H,SelectorInc);\r
+ end;\r
+\r
+ procedure DecPtrLong(var p:pointer;count:longint);\r
+ { Decrements pointer; assumes count > 0 }\r
+ begin\r
+ if LH(count).L > LH(p).L then\r
+ dec(LH(p).H,SelectorInc);\r
+ dec(LH(p).L,LH(Count).L);\r
+ dec(LH(p).H,SelectorInc*LH(Count).H);\r
+ end;\r
+ { The next section is for real mode only }\r
+\r
+function Normalized(p : pointer) : pointer;\r
+var\r
+ count : word;\r
+begin\r
+ count := LH(p).L and $FFF0;\r
+ Normalized := Ptr(LH(p).H + (count shr 4), LH(p).L and $F);\r
+end;\r
+\r
+procedure FreeHuge(var p:HugePtr; size : longint);\r
+const\r
+ blocksize = $FFF0;\r
+var\r
+ block : word;\r
+begin\r
+ while size > 0 do\r
+ begin\r
+ { block := minimum(size, blocksize); }\r
+ if size > blocksize then\r
+ block := blocksize\r
+ else\r
+ block := size;\r
+\r
+ dec(size,block);\r
+ freemem(p,block);\r
+ IncPtr(p,block); { we may get ptr($xxxx, $fff8) and 31 bytes left }\r
+ p := Normalized(p); { to free, so we must normalize }\r
+ end;\r
+end;\r
+\r
+function FreeMemHuge(ptr : pointer) : boolean;\r
+var\r
+ i : integer; { -1..MaxAllocEntries }\r
+begin\r
+ FreeMemHuge := FALSE;\r
+ i := allocatedCount - 1;\r
+ while (i >= 0) do\r
+ begin\r
+ if (ptr = allocatedList[i].value) then\r
+ begin\r
+ with allocatedList[i] do\r
+ FreeHuge(orgvalue, size);\r
+\r
+ Move(allocatedList[i+1], allocatedList[i],\r
+ SizeOf(TMemRec)*(allocatedCount - 1 - i));\r
+ Dec(allocatedCount);\r
+ FreeMemHuge := TRUE;\r
+ break;\r
+ end;\r
+ Dec(i);\r
+ end;\r
+end;\r
+\r
+procedure GetMemHuge(var p:HugePtr;memsize:Longint);\r
+const\r
+ blocksize = $FFF0;\r
+var\r
+ size : longint;\r
+ prev,free : PFreeRec;\r
+ save,temp : pointer;\r
+ block : word;\r
+begin\r
+ p := NIL;\r
+ { Handle the easy cases first }\r
+ if memsize > maxavail then\r
+ exit\r
+ else\r
+ if memsize <= blocksize then\r
+ begin\r
+ getmem(p, memsize);\r
+ if not NewAllocation(p, p, memsize) then\r
+ begin\r
+ FreeMem(p, memsize);\r
+ p := NIL;\r
+ end;\r
+ end\r
+ else\r
+ begin\r
+ size := memsize + 15;\r
+\r
+ { Find the block that has enough space }\r
+ prev := PFreeRec(@freeList);\r
+ free := prev^.next;\r
+ while (free <> heapptr) and (ptr2int(free^.size) < size) do\r
+ begin\r
+ prev := free;\r
+ free := prev^.next;\r
+ end;\r
+\r
+ { Now free points to a region with enough space; make it the first one and\r
+ multiple allocations will be contiguous. }\r
+\r
+ save := freelist;\r
+ freelist := free;\r
+ { In TP 6, this works; check against other heap managers }\r
+ while size > 0 do\r
+ begin\r
+ { block := minimum(size, blocksize); }\r
+ if size > blocksize then\r
+ block := blocksize\r
+ else\r
+ block := size;\r
+ dec(size,block);\r
+ getmem(temp,block);\r
+ end;\r
+\r
+ { We've got what we want now; just sort things out and restore the\r
+ free list to normal }\r
+\r
+ p := free;\r
+ if prev^.next <> freelist then\r
+ begin\r
+ prev^.next := freelist;\r
+ freelist := save;\r
+ end;\r
+\r
+ if (p <> NIL) then\r
+ begin\r
+ { return pointer with 0 offset }\r
+ temp := p;\r
+ if Ofs(p^)<>0 Then\r
+ p := Ptr(Seg(p^)+1,0); { hack }\r
+ if not NewAllocation(temp, p, memsize + 15) then\r
+ begin\r
+ FreeHuge(temp, size);\r
+ p := NIL;\r
+ end;\r
+ end;\r
+\r
+ end;\r
+end;\r
+\r
+{$ENDIF}\r
+\r
+procedure zmemcpy(destp : pBytef; sourcep : pBytef; len : uInt);\r
+begin\r
+ Move(sourcep^, destp^, len);\r
+end;\r
+\r
+function zmemcmp(s1p, s2p : pBytef; len : uInt) : int;\r
+var\r
+ j : uInt;\r
+ source,\r
+ dest : pBytef;\r
+begin\r
+ source := s1p;\r
+ dest := s2p;\r
+ for j := 0 to pred(len) do\r
+ begin\r
+ if (source^ <> dest^) then\r
+ begin\r
+ zmemcmp := 2*Ord(source^ > dest^)-1;\r
+ exit;\r
+ end;\r
+ Inc(source);\r
+ Inc(dest);\r
+ end;\r
+ zmemcmp := 0;\r
+end;\r
+\r
+procedure zmemzero(destp : pBytef; len : uInt);\r
+begin\r
+ FillChar(destp^, len, 0);\r
+end;\r
+\r
+procedure zcfree(opaque : voidpf; ptr : voidpf);\r
+{$ifdef Delphi16}\r
+var\r
+ Handle : THandle;\r
+{$endif}\r
+{$IFDEF FPC}\r
+var\r
+ memsize : uint;\r
+{$ENDIF}\r
+begin\r
+ {$IFDEF DPMI}\r
+ {h :=} GlobalFreePtr(ptr);\r
+ {$ELSE}\r
+ {$IFDEF CALL_DOS}\r
+ dosFree(ptr);\r
+ {$ELSE}\r
+ {$ifdef HugeMem}\r
+ FreeMemHuge(ptr);\r
+ {$else}\r
+ {$ifdef Delphi16}\r
+ Handle := GlobalHandle(LH(ptr).H); { HiWord(LongInt(ptr)) }\r
+ GlobalUnLock(Handle);\r
+ GlobalFree(Handle);\r
+ {$else}\r
+ {$IFDEF FPC}\r
+ Dec(puIntf(ptr));\r
+ memsize := puIntf(ptr)^;\r
+ FreeMem(ptr, memsize+SizeOf(uInt));\r
+ {$ELSE}\r
+ FreeMem(ptr); { Delphi 2,3,4 }\r
+ {$ENDIF}\r
+ {$endif}\r
+ {$endif}\r
+ {$ENDIF}\r
+ {$ENDIF}\r
+end;\r
+\r
+function zcalloc (opaque : voidpf; items : uInt; size : uInt) : voidpf;\r
+var\r
+ p : voidpf;\r
+ memsize : uLong;\r
+{$ifdef Delphi16}\r
+ handle : THandle;\r
+{$endif}\r
+begin\r
+ memsize := uLong(items) * size;\r
+ {$IFDEF DPMI}\r
+ p := GlobalAllocPtr(gmem_moveable, memsize);\r
+ {$ELSE}\r
+ {$IFDEF CALLDOS}\r
+ p := dosAlloc(memsize);\r
+ {$ELSE}\r
+ {$ifdef HugeMem}\r
+ GetMemHuge(p, memsize);\r
+ {$else}\r
+ {$ifdef Delphi16}\r
+ Handle := GlobalAlloc(HeapAllocFlags, memsize);\r
+ p := GlobalLock(Handle);\r
+ {$else}\r
+ {$IFDEF FPC}\r
+ GetMem(p, memsize+SizeOf(uInt));\r
+ puIntf(p)^:= memsize;\r
+ Inc(puIntf(p));\r
+ {$ELSE}\r
+ GetMem(p, memsize); { Delphi: p := AllocMem(memsize); }\r
+ {$ENDIF}\r
+ {$endif}\r
+ {$endif}\r
+ {$ENDIF}\r
+ {$ENDIF}\r
+ zcalloc := p;\r
+end;\r
+\r
+end.\r
+\r
+\r
+{ edited from a SWAG posting:\r
+\r
+In Turbo Pascal 6, the heap is the memory allocated when using the Procedures 'New' and\r
+'GetMem'. The heap starts at the address location pointed to by 'Heaporg' and\r
+grows to higher addresses as more memory is allocated. The top of the heap,\r
+the first address of allocatable memory space above the allocated memory\r
+space, is pointed to by 'HeapPtr'.\r
+\r
+Memory is deallocated by the Procedures 'Dispose' and 'FreeMem'. As memory\r
+blocks are deallocated more memory becomes available, but..... When a block\r
+of memory, which is not the top-most block in the heap is deallocated, a gap\r
+in the heap will appear. to keep track of these gaps Turbo Pascal maintains\r
+a so called free list.\r
+\r
+The Function 'MaxAvail' holds the size of the largest contiguous free block\r
+_in_ the heap. The Function 'MemAvail' holds the sum of all free blocks in\r
+the heap.\r
+\r
+TP6.0 keeps track of the free blocks by writing a 'free list Record' to the\r
+first eight Bytes of the freed memory block! A (TP6.0) free-list Record\r
+contains two four Byte Pointers of which the first one points to the next\r
+free memory block, the second Pointer is not a Real Pointer but contains the\r
+size of the memory block.\r
+\r
+Summary\r
+\r
+TP6.0 maintains a linked list with block sizes and Pointers to the _next_\r
+free block. An extra heap Variable 'Heapend' designate the end of the heap.\r
+When 'HeapPtr' and 'FreeList' have the same value, the free list is empty.\r
+\r
+\r
+ TP6.0 Heapend\r
+ ÚÄÄÄÄÄÄÄÄÄ¿ <ÄÄÄÄ\r
+ ³ ³\r
+ ³ ³\r
+ ³ ³\r
+ ³ ³\r
+ ³ ³\r
+ ³ ³\r
+ ³ ³\r
+ ³ ³ HeapPtr\r
+ ÚÄ>ÃÄÄÄÄÄÄÄÄÄ´ <ÄÄÄÄ\r
+ ³ ³ ³\r
+ ³ ÃÄÄÄÄÄÄÄÄÄ´\r
+ ÀÄij Free ³\r
+ ÚÄ>ÃÄÄÄÄÄÄÄÄÄ´\r
+ ³ ³ ³\r
+ ³ ÃÄÄÄÄÄÄÄÄÄ´\r
+ ÀÄij Free ³ FreeList\r
+ ÃÄÄÄÄÄÄÄÄÄ´ <ÄÄÄÄ\r
+ ³ ³ Heaporg\r
+ ÃÄÄÄÄÄÄÄÄÄ´ <ÄÄÄÄ\r
+\r
+\r
+}\r
lcore.org gitweb / pngwrite.git / commitdiff