1{ 2} 3UNIT Unzip51g; 4{ 5Unzips deflated, imploded, shrunk and stored files 6 ** COMPATIBLE WITH 7 * Turbo Pascal v7.x (DOS) 8 * Borland Pascal v7.x (Dos, DPMI, and Windows) 9 * Delphi v1.x 10 * Delphi v2.x 11 * Delphi v3.x 12 * Virtual Pascal v2.0 (OS/2, Win32) 13 * Free Pascal Compiler (DOS, OS/2, Win32, Linux, FreeBSD, NetBSD) 14} 15 16{ 17 Original version (1.x): Christian Ghisler 18 C code by info-zip group, translated to pascal by Christian Ghisler 19 based on unz51g.zip; 20 Special thanks go to Mark Adler,who wrote the main inflate and 21 explode code, and did NOT copyright it!!! 22 23 v2.00: March 1998: Dr Abimbola Olowofoyeku (The African Chief) 24 Homepage: http://ourworld.compuserve.com/homepages/African_Chief 25 * modified to compile for Delphi v2.x and Delphi v3.x 26 27 v2.01: April 1998: Dr Abimbola Olowofoyeku (The African Chief) 28 * source files merged into a single source (this) file 29 * several high level functions added - i.e., 30 FileUnzip() 31 FileUnzipEx() 32 ViewZip() 33 UnzipSize() 34 SetUnzipReportProc() 35 SetUnzipQuestionProc() 36 ChfUnzip_Init() 37 * callbacks added 38 * modified to support Virtual Pascal v2.0 (Win32) 39 * Delphi component added (chfunzip.pas) 40 v2.01a: December 1998: Tomas Hajny, XHajT03@mbox.vol.cz 41 * extended to support other 32-bit compilers/platforms (OS/2, GO32, ...); 42 search for (* TH ... *) 43 v2.01b: December 1998: Peter Vreman 44 * modifications needed for Linux 45} 46 47INTERFACE 48 49{$IFDEF FPC} 50 {$DEFINE BIT32} 51{$ENDIF} 52 53{$IFDEF OS2} 54 {$DEFINE BIT32} 55{$ENDIF} 56 57{$IFDEF WIN32} 58 {$DEFINE BIT32} 59{$ENDIF} 60 61{$IFNDEF FPC} 62 {$F+} 63{$ENDIF} 64 65{$R-} {No range checking} 66 67USES 68 strings, 69 dos, 70 ziptypes; 71 72{**********************************************************************} 73{**********************************************************************} 74{****** HIGH LEVEL FUNCTIONS: BY THE AFRICAN CHIEF ********************} 75{**********************************************************************} 76{**********************************************************************} 77FUNCTION FileUnzip 78( SourceZipFile, TargetDirectory, FileSpecs : pChar; 79 Report : UnzipReportProc;Question : UnzipQuestionProc ) : integer; 80 81{ 82high level unzip 83usage: 84SourceZipFile: source zip file; 85TargetDirectory: target directory 86FileSpecs: "*.*", etc. 87Report: Report callback or Nil; 88Question: Question callback (for confirmation of whether to replace existing 89 files) or Nil; 90 91* REFER to ZIPTYPES.PAS for information on callback functions 92 93e.g., 94 Count := FileUnzip('test.zip', 'c:\temp', '*.*', MyReportProc, Nil); 95 96} 97 98FUNCTION FileUnzipEx ( SourceZipFile, TargetDirectory, FileSpecs : pChar ) : integer; 99{ 100high level unzip with no callback parameters; 101passes ZipReport & ZipQuestion internally, so you 102can use SetZipReportProc and SetZipQuestionProc before calling this; 103 104e.g., 105 Count := FileUnzipEx('test.zip', 'c:\temp', '*.*'); 106} 107 108FUNCTION ViewZip ( SourceZipFile, FileSpecs : pChar; Report : UnzipReportProc ) : integer; 109{ 110view contents of zip file 111usage: 112SourceZipFile: source zip file; 113FileSpecs: "*.*", etc. 114Report: callback procedure to process the reported contents of ZIP file; 115 116* REFER to ZIPTYPES.PAS for information on callback functions 117 118e.g., 119 ViewZip('test.zip', '*.*', MyReportProc); 120} 121 122FUNCTION SetUnZipReportProc ( aProc : UnzipReportProc ) : Pointer; 123{ 124sets the internal unzip report procedure to aproc 125Returns: pointer to the original report procedure 126(return value should normally be ignored) 127 128e.g., 129 SetUnZipReportProc(MyReportProc); 130} 131 132FUNCTION SetUnZipQuestionProc ( aProc : UnzipQuestionProc ) : Pointer; 133{ 134sets the internal unzip question procedure to aproc 135Returns: pointer to the original "question" procedure 136(return value should normally be ignored) 137 138e.g., 139SetUnZipQuestionProc(QueryFileExistProc); 140} 141 142FUNCTION UnzipSize ( SourceZipFile : pChar;VAR Compressed : Longint ) : longint; 143{ uncompressed and compressed zip size 144 usage: 145 SourceZipFile = the zip file 146 Compressed = the compressed size of the files in the archive 147 Returns: the uncompressed size of the ZIP archive 148 149e.g., 150 Var 151 Size,CSize:longint; 152 begin 153 Size := UnzipSize('test.zip', CSize); 154 end; 155} 156 157PROCEDURE ChfUnzip_Init; 158{ 159initialise or reinitialise the shared data: !!! use with care !!! 160} 161 162FUNCTION SetNoRecurseDirs ( DontRecurse : Boolean ) : Boolean; 163{ 164determine whether the UNZIP function should recreate 165the subdirectory structure; 166 DontRecurse = TRUE : don't recurse 167 DontRecurse = FALSE : recurse (default) 168} 169 170{**********************************************************************} 171{**********************************************************************} 172{************ LOW LEVEL FUNCTIONS: BY CHRISTIAN GHISLER ***************} 173{**********************************************************************} 174{**********************************************************************} 175FUNCTION GetSupportedMethods : longint; 176{Checks which pack methods are supported by the dll} 177{bit 8=1 -> Format 8 supported, etc.} 178 179FUNCTION UnzipFile ( in_name : pchar;out_name : pchar;offset : longint;hFileAction : word;cm_index : integer ) : integer; 180{usage: 181 in_name: name of zip file with full path 182 out_name: desired name for out file 183 offset: header position of desired file in zipfile 184 hFileAction: handle to dialog box showing advance of decompression (optional) 185 cm_index: notification code sent in a wm_command message to the dialog 186 to update percent-bar 187 Return value: one of the above unzip_xxx codes 188 189 Example for handling the cm_index message in a progress dialog: 190 191 unzipfile(......,cm_showpercent); 192 193 ... 194 195 procedure TFileActionDialog.wmcommand(var msg:tmessage); 196 var ppercent:^word; 197 begin 198 TDialog.WMCommand(msg); 199 if msg.wparam=cm_showpercent then begin 200 ppercent:=pointer(lparam); 201 if ppercent<>nil then begin 202 if (ppercent^>=0) and (ppercent^<=100) then 203 SetProgressBar(ppercent^); 204 if UserPressedAbort then 205 ppercent^:=$ffff 206 else 207 ppercent^:=0; 208 end; 209 end; 210 end; 211 end; 212} 213 214FUNCTION GetFirstInZip ( zipfilename : pchar;VAR zprec : tZipRec ) : integer; 215{ 216 Get first entry from ZIP file 217 e.g., 218 rc:=GetFirstInZip('test.zip', myZipRec); 219} 220 221FUNCTION GetNextInZip ( VAR Zprec : tZiprec ) : integer; 222{ 223 Get next entry from ZIP file 224 225 e.g., 226 rc:=GetNextInZip(myZipRec); 227} 228 229FUNCTION IsZip ( filename : pchar ) : boolean; 230{ 231 VERY simple test for zip file 232 233 e.g., 234 ItsaZipFile := IsZip('test.zip'); 235} 236 237PROCEDURE CloseZipFile ( VAR Zprec : tZiprec ); {Only free buffer, file only open in Getfirstinzip} 238{ 239 free ZIP buffers 240 241 e.g., 242 CloseZipFile(myZipRec); 243} 244 245IMPLEMENTATION 246 247VAR 248ZipReport : UnzipReportProc; {Global Status Report Callback} 249ZipQuestion : UnzipQuestionProc; {Global "Question" Callback} 250ZipRec : TReportRec; {Global ZIP record for callbacks} 251NoRecurseDirs : Boolean; {Global Recurse variable} 252 253{*************************************************************************} 254{$ifdef Delphi} 255PROCEDURE SetCurDir ( p : pChar ); 256BEGIN 257 Chdir ( strpas ( p ) ); 258END; 259 260FUNCTION DosError : integer; {Delphi DosError kludge} 261BEGIN 262 Result := Ioresult; 263END; 264 265FUNCTION SetFTime ( VAR f : File; CONST l : longint ) : integer; 266BEGIN 267 {$ifdef Win32}Result := {$endif}FileSetDate ( TFileRec ( f ) .Handle, l ); 268END; 269 270PROCEDURE CreateDir ( p : pchar ); 271BEGIN 272 mkdir ( strpas ( p ) ); 273END; 274 275{/////////////////////////////////////////////////////////} 276{$endif Delphi} 277 278{.$I z_global.pas} {global constants, types and variables} 279{Include file for unzip.pas: global constants, types and variables} 280 281{C code by info-zip group, translated to pascal by Christian Ghisler} 282{based on unz51g.zip} 283 284CONST {Error codes returned by huft_build} 285 huft_complete = 0; {Complete tree} 286 huft_incomplete = 1; {Incomplete tree <- sufficient in some cases!} 287 huft_error = 2; {bad tree constructed} 288 huft_outofmem = 3; {not enough memory} 289(* TH - use of the new BIT32 conditional (was WIN32 only previously) *) 290 MaxMax = {$ifdef BIT32}256 * 1024 {BIT32 = 256kb buffer} 291 {$else}Maxint -1{$endif}; {16-bit = 32kb buffer} 292 293CONST wsize = $8000; {Size of sliding dictionary} 294 INBUFSIZ = 1024 * 4; {Size of input buffer} 295 296CONST lbits : integer = 9; 297 dbits : integer = 6; 298 299CONST b_max = 16; 300 n_max = 288; 301 BMAX = 16; 302 303TYPE push = ^ush; 304 ush = word; 305 pbyte = ^byte; 306 pushlist = ^ushlist; 307 ushlist = ARRAY [ 0..maxmax ] of ush; {only pseudo-size!!} 308 pword = ^word; 309 pwordarr = ^twordarr; 310 twordarr = ARRAY [ 0..maxmax ] of word; 311 iobuf = ARRAY [ 0..inbufsiz -1 ] of byte; 312 313TYPE pphuft = ^phuft; 314 phuft = ^huft; 315 phuftlist = ^huftlist; 316 huft = PACKED RECORD 317 e, {# of extra bits} 318 b : byte; {# of bits in code} 319 v_n : ush; 320 v_t : phuftlist; {Linked List} 321 END; 322 huftlist = ARRAY [ 0..8190 ] of huft; 323 324TYPE li = PACKED RECORD 325 lo, hi : word; 326 END; 327 328{pkzip header in front of every file in archive} 329TYPE 330 plocalheader = ^tlocalheader; 331 tlocalheader = PACKED RECORD 332 signature : ARRAY [ 0..3 ] of char; {'PK'#1#2} 333 extract_ver, 334 bit_flag, 335 zip_type : word; 336 file_timedate : longint; 337 crc_32, 338 compress_size, 339 uncompress_size : longint; 340 filename_len, 341 extra_field_len : word; 342 END; 343 344VAR slide : pchar; {Sliding dictionary for unzipping} 345 inbuf : iobuf; {input buffer} 346 inpos, readpos : integer; {position in input buffer, position read from file} 347 348VAR w : longint; {Current Position in slide} 349 b : longint; {Bit Buffer} 350 k : byte; {Bits in bit buffer} 351 infile, {handle to zipfile} 352 outfile : file; {handle to extracted file} 353 compsize, {comressed size of file} 354 reachedsize, {number of bytes read from zipfile} 355 uncompsize : longint; {uncompressed size of file} 356 crc32val : cardinal; {crc calculated from data} 357 hufttype : word; {coding type=bit_flag from header} 358 totalabort, {User pressed abort button, set in showpercent!} 359 zipeof : boolean; {read over end of zip section for this file} 360 inuse : boolean; {is unit already in use -> don't call it again!!!} 361 362(***************************************************************************) 363{.$I z_tables.pas} {Tables for bit masking, huffman codes and CRC checking} 364 365{include file for unzip.pas: Tables for bit masking, huffman codes and CRC checking} 366 367{C code by info-zip group, translated to Pascal by Christian Ghisler} 368{based on unz51g.zip} 369 370{b and mask_bits[i] gets lower i bits out of i} 371CONST mask_bits : ARRAY [ 0..16 ] of word = 372 ( $0000, 373 $0001, $0003, $0007, $000f, $001f, $003f, $007f, $00ff, 374 $01ff, $03ff, $07ff, $0fff, $1fff, $3fff, $7fff, $ffff ); 375 376{ Tables for deflate from PKZIP's appnote.txt. } 377 378CONST border : ARRAY [ 0..18 ] of byte = { Order of the bit length code lengths } 379 ( 16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15 ); 380CONST cplens : ARRAY [ 0..30 ] of word = { Copy lengths for literal codes 257..285 } 381 ( 3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 15, 17, 19, 23, 27, 31, 382 35, 43, 51, 59, 67, 83, 99, 115, 131, 163, 195, 227, 258, 0, 0 ); 383 { note: see note #13 above about the 258 in this list.} 384CONST cplext : ARRAY [ 0..30 ] of word = { Extra bits for literal codes 257..285 } 385 ( 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 2, 2, 2, 2, 386 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 5, 5, 0, 99, 99 ); { 99==invalid } 387CONST cpdist : ARRAY [ 0..29 ] of word = { Copy offsets for distance codes 0..29 } 388 ( 1, 2, 3, 4, 5, 7, 9, 13, 17, 25, 33, 49, 65, 97, 129, 193, 389 257, 385, 513, 769, 1025, 1537, 2049, 3073, 4097, 6145, 390 8193, 12289, 16385, 24577 ); 391CONST cpdext : ARRAY [ 0..29 ] of word = { Extra bits for distance codes } 392 ( 0, 0, 0, 0, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6, 393 7, 7, 8, 8, 9, 9, 10, 10, 11, 11, 394 12, 12, 13, 13 ); 395 396{ Tables for explode } 397 398CONST cplen2 : ARRAY [ 0..63 ] of word = ( 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 399 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 400 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 401 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65 ); 402CONST cplen3 : ARRAY [ 0..63 ] of word = ( 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 403 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 404 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 405 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66 ); 406CONST extra : ARRAY [ 0..63 ] of word = ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 407 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 408 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 409 8 ); 410CONST cpdist4 : ARRAY [ 0..63 ] of word = ( 1, 65, 129, 193, 257, 321, 385, 449, 513, 577, 641, 705, 411 769, 833, 897, 961, 1025, 1089, 1153, 1217, 1281, 1345, 1409, 1473, 412 1537, 1601, 1665, 1729, 1793, 1857, 1921, 1985, 2049, 2113, 2177, 413 2241, 2305, 2369, 2433, 2497, 2561, 2625, 2689, 2753, 2817, 2881, 414 2945, 3009, 3073, 3137, 3201, 3265, 3329, 3393, 3457, 3521, 3585, 415 3649, 3713, 3777, 3841, 3905, 3969, 4033 ); 416CONST cpdist8 : ARRAY [ 0..63 ] of word = ( 1, 129, 257, 385, 513, 641, 769, 897, 1025, 1153, 1281, 417 1409, 1537, 1665, 1793, 1921, 2049, 2177, 2305, 2433, 2561, 2689, 418 2817, 2945, 3073, 3201, 3329, 3457, 3585, 3713, 3841, 3969, 4097, 419 4225, 4353, 4481, 4609, 4737, 4865, 4993, 5121, 5249, 5377, 5505, 420 5633, 5761, 5889, 6017, 6145, 6273, 6401, 6529, 6657, 6785, 6913, 421 7041, 7169, 7297, 7425, 7553, 7681, 7809, 7937, 8065 ); 422 423{************************************ CRC-Calculation ************************************} 424 425CONST crc_32_tab : ARRAY [ 0..255 ] of cardinal = 426( 427 $00000000, $77073096, $ee0e612c, $990951ba, $076dc419, 428 $706af48f, $e963a535, $9e6495a3, $0edb8832, $79dcb8a4, 429 $e0d5e91e, $97d2d988, $09b64c2b, $7eb17cbd, $e7b82d07, 430 $90bf1d91, $1db71064, $6ab020f2, $f3b97148, $84be41de, 431 $1adad47d, $6ddde4eb, $f4d4b551, $83d385c7, $136c9856, 432 $646ba8c0, $fd62f97a, $8a65c9ec, $14015c4f, $63066cd9, 433 $fa0f3d63, $8d080df5, $3b6e20c8, $4c69105e, $d56041e4, 434 $a2677172, $3c03e4d1, $4b04d447, $d20d85fd, $a50ab56b, 435 $35b5a8fa, $42b2986c, $dbbbc9d6, $acbcf940, $32d86ce3, 436 $45df5c75, $dcd60dcf, $abd13d59, $26d930ac, $51de003a, 437 $c8d75180, $bfd06116, $21b4f4b5, $56b3c423, $cfba9599, 438 $b8bda50f, $2802b89e, $5f058808, $c60cd9b2, $b10be924, 439 $2f6f7c87, $58684c11, $c1611dab, $b6662d3d, $76dc4190, 440 $01db7106, $98d220bc, $efd5102a, $71b18589, $06b6b51f, 441 $9fbfe4a5, $e8b8d433, $7807c9a2, $0f00f934, $9609a88e, 442 $e10e9818, $7f6a0dbb, $086d3d2d, $91646c97, $e6635c01, 443 $6b6b51f4, $1c6c6162, $856530d8, $f262004e, $6c0695ed, 444 $1b01a57b, $8208f4c1, $f50fc457, $65b0d9c6, $12b7e950, 445 $8bbeb8ea, $fcb9887c, $62dd1ddf, $15da2d49, $8cd37cf3, 446 $fbd44c65, $4db26158, $3ab551ce, $a3bc0074, $d4bb30e2, 447 $4adfa541, $3dd895d7, $a4d1c46d, $d3d6f4fb, $4369e96a, 448 $346ed9fc, $ad678846, $da60b8d0, $44042d73, $33031de5, 449 $aa0a4c5f, $dd0d7cc9, $5005713c, $270241aa, $be0b1010, 450 $c90c2086, $5768b525, $206f85b3, $b966d409, $ce61e49f, 451 $5edef90e, $29d9c998, $b0d09822, $c7d7a8b4, $59b33d17, 452 $2eb40d81, $b7bd5c3b, $c0ba6cad, $edb88320, $9abfb3b6, 453 $03b6e20c, $74b1d29a, $ead54739, $9dd277af, $04db2615, 454 $73dc1683, $e3630b12, $94643b84, $0d6d6a3e, $7a6a5aa8, 455 $e40ecf0b, $9309ff9d, $0a00ae27, $7d079eb1, $f00f9344, 456 $8708a3d2, $1e01f268, $6906c2fe, $f762575d, $806567cb, 457 $196c3671, $6e6b06e7, $fed41b76, $89d32be0, $10da7a5a, 458 $67dd4acc, $f9b9df6f, $8ebeeff9, $17b7be43, $60b08ed5, 459 $d6d6a3e8, $a1d1937e, $38d8c2c4, $4fdff252, $d1bb67f1, 460 $a6bc5767, $3fb506dd, $48b2364b, $d80d2bda, $af0a1b4c, 461 $36034af6, $41047a60, $df60efc3, $a867df55, $316e8eef, 462 $4669be79, $cb61b38c, $bc66831a, $256fd2a0, $5268e236, 463 $cc0c7795, $bb0b4703, $220216b9, $5505262f, $c5ba3bbe, 464 $b2bd0b28, $2bb45a92, $5cb36a04, $c2d7ffa7, $b5d0cf31, 465 $2cd99e8b, $5bdeae1d, $9b64c2b0, $ec63f226, $756aa39c, 466 $026d930a, $9c0906a9, $eb0e363f, $72076785, $05005713, 467 $95bf4a82, $e2b87a14, $7bb12bae, $0cb61b38, $92d28e9b, 468 $e5d5be0d, $7cdcefb7, $0bdbdf21, $86d3d2d4, $f1d4e242, 469 $68ddb3f8, $1fda836e, $81be16cd, $f6b9265b, $6fb077e1, 470 $18b74777, $88085ae6, $ff0f6a70, $66063bca, $11010b5c, 471 $8f659eff, $f862ae69, $616bffd3, $166ccf45, $a00ae278, 472 $d70dd2ee, $4e048354, $3903b3c2, $a7672661, $d06016f7, 473 $4969474d, $3e6e77db, $aed16a4a, $d9d65adc, $40df0b66, 474 $37d83bf0, $a9bcae53, $debb9ec5, $47b2cf7f, $30b5ffe9, 475 $bdbdf21c, $cabac28a, $53b39330, $24b4a3a6, $bad03605, 476 $cdd70693, $54de5729, $23d967bf, $b3667a2e, $c4614ab8, 477 $5d681b02, $2a6f2b94, $b40bbe37, $c30c8ea1, $5a05df1b, 478 $2d02ef8d ); { end crc_32_tab[] } 479(***************************************************************************) 480{.$I z_generl.pas} {General functions used by both inflate and explode} 481{include for unzip.pas: General functions used by both inflate and explode} 482 483{C code by info-zip group, translated to Pascal by Christian Ghisler} 484{based on unz51g.zip} 485 486{*********************************** CRC Checking ********************************} 487 488PROCEDURE UpdateCRC ( VAR s : iobuf;len : word ); 489VAR i : word; 490BEGIN 491{$ifndef assembler} 492 If len = 0 then exit; 493 FOR i := 0 TO Pred ( len ) DO BEGIN 494 { update running CRC calculation with contents of a buffer } 495 crc32val := crc_32_tab [ ( byte ( crc32val ) XOR s [ i ] ) AND $ff ] XOR ( crc32val SHR 8 ); 496 END; 497{$else} 498 ASM 499 les di, s 500 mov ax, li.lo ( crc32val ) 501 mov dx, li.hi ( crc32val ) 502 mov si, offset crc_32_tab {Segment remains DS!!!} 503 mov cx, len 504 OR cx, cx 505 jz @finished 506@again : 507 mov bl, al {byte(crcval)} 508 mov al, ah {shift DX:AX by 8 bits to the right} 509 mov ah, dl 510 mov dl, dh 511 XOR dh, dh 512 513 XOR bh, bh 514 XOR bl, es : [ di ] {xor s^} 515 inc di 516 SHL bx, 1 {Offset: Index*4} 517 SHL bx, 1 518 XOR ax, [ si + bx ] 519 XOR dx, [ si + bx + 2 ] 520 dec cx 521 jnz @again 522@finished : 523 mov li.lo ( crc32val ), ax 524 mov li.hi ( crc32val ), dx 525 END; 526{$endif} 527END; 528 529{************************** fill inbuf from infile *********************} 530 531PROCEDURE readbuf; 532BEGIN 533 IF reachedsize > compsize + 2 THEN BEGIN {+2: last code is smaller than requested!} 534 readpos := sizeof ( inbuf ); {Simulates reading -> no blocking} 535 zipeof := TRUE 536 END ELSE BEGIN 537 {$push} {$I-} 538 blockread ( infile, inbuf, sizeof ( inbuf ), readpos ); 539 {$pop} 540 IF ( ioresult <> 0 ) OR ( readpos = 0 ) THEN BEGIN {readpos=0: kein Fehler gemeldet!!!} 541 readpos := sizeof ( inbuf ); {Simulates reading -> CRC error} 542 zipeof := TRUE; 543 END; 544 inc ( reachedsize, readpos ); 545 dec ( readpos ); {Reason: index of inbuf starts at 0} 546 END; 547 inpos := 0; 548END; 549 550{**** read byte, only used by explode ****} 551 552PROCEDURE READBYTE ( VAR bt : byte ); 553BEGIN 554 IF inpos > readpos THEN readbuf; 555 bt := inbuf [ inpos ]; 556 inc ( inpos ); 557END; 558 559{*********** read at least n bits into the global variable b *************} 560 561PROCEDURE NEEDBITS ( n : byte ); 562VAR nb : longint; 563BEGIN 564{$ifndef assembler} 565 WHILE k < n DO BEGIN 566 IF inpos > readpos THEN readbuf; 567 nb := inbuf [ inpos ]; 568 inc ( inpos ); 569 b := b OR nb SHL k; 570 inc ( k, 8 ); 571 END; 572{$else} 573 ASM 574 mov si, offset inbuf 575 mov ch, n 576 mov cl, k 577 mov bx, inpos {bx=inpos} 578@again : 579 cmp cl, ch 580 JAE @finished {k>=n -> finished} 581 cmp bx, readpos 582 jg @readbuf 583@fullbuf : 584 mov al, [ si + bx ] {dx:ax=nb} 585 XOR ah, ah 586 XOR dx, dx 587 cmp cl, 8 {cl>=8 -> shift into DX or directly by 1 byte} 588 JAE @bigger8 589 SHL ax, cl {Normal shifting!} 590 jmp @continue 591@bigger8 : 592 mov di, cx {save cx} 593 mov ah, al {shift by 8} 594 XOR al, al 595 sub cl, 8 {8 bits shifted} 596@rotate : 597 OR cl, cl 598 jz @continue1 {all shifted -> finished} 599 SHL ah, 1 {al ist empty!} 600 rcl dx, 1 601 dec cl 602 jmp @rotate 603@continue1 : 604 mov cx, di 605@continue : 606 OR li.hi ( b ), dx {b=b or nb shl k} 607 OR li.lo ( b ), ax 608 inc bx {inpos} 609 add cl, 8 {inc k by 8 Bits} 610 jmp @again 611 612@readbuf : 613 push si 614 push cx 615 call readbuf {readbuf not critical, called only every 2000 bytes} 616 pop cx 617 pop si 618 mov bx, inpos {New inpos} 619 jmp @fullbuf 620 621@finished : 622 mov k, cl 623 mov inpos, bx 624 END; 625{$endif} 626END; 627 628{***************** dump n bits no longer needed from global variable b *************} 629 630PROCEDURE DUMPBITS ( n : byte ); 631BEGIN 632{$ifndef assembler} 633 b := b SHR n; 634 k := k -n; 635{$else} 636 ASM 637 mov cl, n 638 mov ax, li.lo ( b ) 639 mov dx, li.hi ( b ) 640 641 mov ch, cl 642 OR ch, ch 643 jz @finished 644@rotate : 645 SHR dx, 1 {Lower Bit in Carry} 646 rcr ax, 1 647 dec ch 648 jnz @rotate 649@finished : 650 mov li.lo ( b ), ax 651 mov li.hi ( b ), dx 652 sub k, cl 653 END; 654{$endif} 655END; 656 657{********************* Flush w bytes directly from slide to file ******************} 658FUNCTION flush ( w : word ) : boolean; 659VAR n : nword; {True wenn OK} 660b : boolean; 661BEGIN 662 {$push} {$I-} 663 blockwrite ( outfile, slide [ 0 ], w, n ); 664 {$pop} 665 b := ( n = w ) AND ( ioresult = 0 ); {True-> alles ok} 666 UpdateCRC ( iobuf ( pointer ( @slide [ 0 ] ) ^ ), w ); 667 {--} 668{$IFDEF FPC} 669 IF ( b = TRUE ) AND Assigned(ZipReport) {callback report for high level functions} 670{$ELSE} 671 IF ( b = TRUE ) AND ( @ZipReport <> NIL ) {callback report for high level functions} 672{$ENDIF} 673 THEN BEGIN 674 WITH ZipRec DO BEGIN 675 Status := file_unzipping; 676 ZipReport ( n, @ZipRec ); {report the actual bytes written} 677 END; 678 END; {report} 679 flush := b; 680END; 681 682{******************************* Break string into tokens ****************************} 683 684VAR 685 _Token : PChar; 686 687FUNCTION StrTok ( Source : PChar; Token : CHAR ) : PChar; 688 VAR P : PChar; 689BEGIN 690 IF Source <> NIL THEN _Token := Source; 691 IF _Token = NIL THEN BEGIN 692 strTok := NIL; 693 exit 694 END; 695 P := StrScan ( _Token, Token ); 696 StrTok := _Token; 697 IF P <> NIL THEN BEGIN 698 P^ := #0; 699 Inc ( P ); 700 END; 701 _Token := P; 702END; 703 704(***************************************************************************) 705{.$I z_huft.pas} {Huffman tree generating and destroying} 706{include for unzip.pas: Huffman tree generating and destroying} 707 708{C code by info-zip group, translated to Pascal by Christian Ghisler} 709{based on unz51g.zip} 710 711{*************** free huffman tables starting with table where t points to ************} 712 713PROCEDURE huft_free ( t : phuftlist ); 714 715VAR p, q : phuftlist; 716 z : integer; 717 718BEGIN 719 p := pointer ( t ); 720 WHILE p <> NIL DO BEGIN 721 dec ( ptrint ( p ), sizeof ( huft ) ); 722 q := p^ [ 0 ].v_t; 723 z := p^ [ 0 ].v_n; {Size in Bytes, required by TP ***} 724 freemem ( p, ( z + 1 ) * sizeof ( huft ) ); 725 p := q 726 END; 727END; 728 729{*********** build huffman table from code lengths given by array b^ *******************} 730 731FUNCTION huft_build ( b : pword;n : word;s : word;d, e : pushlist;t : pphuft;VAR m : integer ) : integer; 732VAR a : word; {counter for codes of length k} 733 c : ARRAY [ 0..b_max + 1 ] of word; {bit length count table} 734 f : word; {i repeats in table every f entries} 735 g, {max. code length} 736 h : integer; {table level} 737 i, {counter, current code} 738 j : word; {counter} 739 k : integer; {number of bits in current code} 740 p : pword; {pointer into c, b and v} 741 q : phuftlist; {points to current table} 742 r : huft; {table entry for structure assignment} 743 u : ARRAY [ 0..b_max ] of phuftlist;{table stack} 744 v : ARRAY [ 0..n_max ] of word; {values in order of bit length} 745 w : integer; {bits before this table} 746 x : ARRAY [ 0..b_max + 1 ] of word; {bit offsets, then code stack} 747 l : ARRAY [ -1..b_max + 1 ] of word; {l[h] bits in table of level h} 748 xp : ^word; {pointer into x} 749 y : integer; {number of dummy codes added} 750 z : word; {number of entries in current table} 751 tryagain : boolean; {bool for loop} 752 pt : phuft; {for test against bad input} 753 el : word; {length of eob code=code 256} 754 755BEGIN 756 IF n > 256 THEN el := pword ( longint ( b ) + 256 * sizeof ( word ) ) ^ 757 ELSE el := BMAX; 758 {generate counts for each bit length} 759 fillchar ( c, sizeof ( c ), #0 ); 760 p := b; i := n; {p points to array of word} 761 REPEAT 762 IF p^ > b_max THEN BEGIN 763 t^ := NIL; 764 m := 0; 765 huft_build := huft_error; 766 exit 767 END; 768 inc ( c [ p^ ] ); 769 inc ( ptrint ( p ), sizeof ( word ) ); {point to next item} 770 dec ( i ); 771 UNTIL i = 0; 772 IF c [ 0 ] = n THEN BEGIN 773 t^ := NIL; 774 m := 0; 775 huft_build := huft_complete; 776 exit 777 END; 778 779 {find minimum and maximum length, bound m by those} 780 j := 1; 781 WHILE ( j <= b_max ) AND ( c [ j ] = 0 ) DO inc ( j ); 782 k := j; 783 IF m < j THEN m := j; 784 i := b_max; 785 WHILE ( i > 0 ) AND ( c [ i ] = 0 ) DO dec ( i ); 786 g := i; 787 IF m > i THEN m := i; 788 789 {adjust last length count to fill out codes, if needed} 790 y := 1 SHL j; 791 WHILE j < i DO BEGIN 792 y := y -c [ j ]; 793 IF y < 0 THEN BEGIN 794 huft_build := huft_error; 795 exit 796 END; 797 y := y SHL 1; 798 inc ( j ); 799 END; 800 dec ( y, c [ i ] ); 801 IF y < 0 THEN BEGIN 802 huft_build := huft_error; 803 exit 804 END; 805 inc ( c [ i ], y ); 806 807 {generate starting offsets into the value table for each length} 808 x [ 1 ] := 0; 809 j := 0; 810 p := @c; inc ( ptrint ( p ), sizeof ( word ) ); 811 xp := @x;inc ( ptrint ( xp ), 2 * sizeof ( word ) ); 812 dec ( i ); 813 WHILE i <> 0 DO BEGIN 814 inc ( j, p^ ); 815 xp^ := j; 816 inc ( ptrint ( p ), 2 ); 817 inc ( ptrint ( xp ), 2 ); 818 dec ( i ); 819 END; 820 821 {make table of values in order of bit length} 822 p := b; i := 0; 823 REPEAT 824 j := p^; 825 inc ( ptrint ( p ), sizeof ( word ) ); 826 IF j <> 0 THEN BEGIN 827 v [ x [ j ] ] := i; 828 inc ( x [ j ] ); 829 END; 830 inc ( i ); 831 UNTIL i >= n; 832 833 {generate huffman codes and for each, make the table entries} 834 x [ 0 ] := 0; i := 0; 835 p := @v; 836 h := -1; 837 l [ -1 ] := 0; 838 w := 0; 839 u [ 0 ] := NIL; 840 q := NIL; 841 z := 0; 842 843 {go through the bit lengths (k already is bits in shortest code)} 844 FOR k := k TO g DO BEGIN 845 FOR a := c [ k ] DOWNTO 1 DO BEGIN 846 {here i is the huffman code of length k bits for value p^} 847 WHILE k > w + l [ h ] DO BEGIN 848 inc ( w, l [ h ] ); {Length of tables to this position} 849 inc ( h ); 850 z := g -w; 851 IF z > m THEN z := m; 852 j := k -w; 853 f := 1 SHL j; 854 IF f > a + 1 THEN BEGIN 855 dec ( f, a + 1 ); 856 xp := @c [ k ]; 857 inc ( j ); 858 tryagain := TRUE; 859 WHILE ( j < z ) AND tryagain DO BEGIN 860 f := f SHL 1; 861 inc ( ptrint ( xp ), sizeof ( word ) ); 862 IF f <= xp^ THEN tryagain := FALSE 863 ELSE BEGIN 864 dec ( f, xp^ ); 865 inc ( j ); 866 END; 867 END; 868 END; 869 IF ( w + j > el ) AND ( w < el ) THEN 870 j := el -w; {Make eob code end at table} 871 IF w = 0 THEN BEGIN 872 j := m; {*** Fix: main table always m bits!} 873 END; 874 z := 1 SHL j; 875 l [ h ] := j; 876 877 {allocate and link new table} 878 getmem ( q, ( z + 1 ) * sizeof ( huft ) ); 879 IF q = NIL THEN BEGIN 880 IF h <> 0 THEN huft_free ( pointer ( u [ 0 ] ) ); 881 huft_build := huft_outofmem; 882 exit 883 END; 884 fillchar ( q^, ( z + 1 ) * sizeof ( huft ), #0 ); 885 q^ [ 0 ].v_n := z; {Size of table, needed in freemem ***} 886 t^ := @q^ [ 1 ]; {first item starts at 1} 887 t := @q^ [ 0 ].v_t; 888 t^ := NIL; 889 q := @q^ [ 1 ]; {pointer(longint(q)+sizeof(huft));} {???} 890 u [ h ] := q; 891 {connect to last table, if there is one} 892 IF h <> 0 THEN BEGIN 893 x [ h ] := i; 894 r.b := l [ h -1 ]; 895 r.e := 16 + j; 896 r.v_t := q; 897 j := ( i AND ( ( 1 SHL w ) -1 ) ) SHR ( w -l [ h -1 ] ); 898 899 {test against bad input!} 900 pt := phuft ( longint ( u [ h -1 ] ) -sizeof ( huft ) ); 901 IF j > pt^.v_n THEN BEGIN 902 huft_free ( pointer ( u [ 0 ] ) ); 903 huft_build := huft_error; 904 exit 905 END; 906 907 pt := @u [ h -1 ]^ [ j ]; 908 pt^ := r; 909 END; 910 END; 911 912 {set up table entry in r} 913 r.b := word ( k -w ); 914 r.v_t := NIL; {Unused} {***********} 915 IF longint ( p ) >= longint ( @v [ n ] ) THEN r.e := 99 916 ELSE IF p^ < s THEN BEGIN 917 IF p^ < 256 THEN r.e := 16 ELSE r.e := 15; 918 r.v_n := p^; 919 inc ( ptrint ( p ), sizeof ( word ) ); 920 END ELSE BEGIN 921 IF ( d = NIL ) OR ( e = NIL ) THEN BEGIN 922 huft_free ( pointer ( u [ 0 ] ) ); 923 huft_build := huft_error; 924 exit 925 END; 926 r.e := word ( e^ [ p^ -s ] ); 927 r.v_n := d^ [ p^ -s ]; 928 inc ( ptrint ( p ), sizeof ( word ) ); 929 END; 930 931 {fill code like entries with r} 932 f := 1 SHL ( k -w ); 933 j := i SHR w; 934 WHILE j < z DO BEGIN 935 q^ [ j ] := r; 936 inc ( j, f ); 937 END; 938 939 {backwards increment the k-bit code i} 940 j := 1 SHL ( k -1 ); 941 WHILE ( i AND j ) <> 0 DO BEGIN 942 {i:=i^j;} 943 i := i XOR j; 944 j := j SHR 1; 945 END; 946 i := i XOR j; 947 948 {backup over finished tables} 949 WHILE ( ( i AND ( ( 1 SHL w ) -1 ) ) <> x [ h ] ) DO BEGIN 950 dec ( h ); 951 dec ( w, l [ h ] ); {Size of previous table!} 952 END; 953 END; 954 END; 955 IF ( y <> 0 ) AND ( g <> 1 ) THEN huft_build := huft_incomplete 956 ELSE huft_build := huft_complete; 957END; 958 959(***************************************************************************) 960{.$I z_inflat.pas} {Inflate deflated file} 961{include for unzip.pas: Inflate deflated file} 962 963{C code by info-zip group, translated to Pascal by Christian Ghisler} 964{based on unz51g.zip} 965 966FUNCTION inflate_codes ( tl, td : phuftlist;bl, bd : integer ) : integer; 967VAR 968 n, d, e1, {length and index for copy} 969 ml, md : longint; {masks for bl and bd bits} 970 t : phuft; {pointer to table entry} 971 e : byte; {table entry flag/number of extra bits} 972 973BEGIN 974 { inflate the coded data } 975 ml := mask_bits [ bl ]; {precompute masks for speed} 976 md := mask_bits [ bd ]; 977 WHILE NOT ( totalabort OR zipeof ) DO BEGIN 978 NEEDBITS ( bl ); 979 t := @tl^ [ b AND ml ]; 980 e := t^.e; 981 IF e > 16 THEN REPEAT {then it's a literal} 982 IF e = 99 THEN BEGIN 983 inflate_codes := unzip_ZipFileErr; 984 exit 985 END; 986 DUMPBITS ( t^.b ); 987 dec ( e, 16 ); 988 NEEDBITS ( e ); 989 t := @t^.v_t^ [ b AND mask_bits [ e ] ]; 990 e := t^.e; 991 UNTIL e <= 16; 992 DUMPBITS ( t^.b ); 993 IF e = 16 THEN BEGIN 994 slide [ w ] := char ( t^.v_n ); 995 inc ( w ); 996 IF w = WSIZE THEN BEGIN 997 IF NOT flush ( w ) THEN BEGIN 998 inflate_codes := unzip_WriteErr; 999 exit; 1000 END; 1001 w := 0 1002 END; 1003 END ELSE BEGIN {it's an EOB or a length} 1004 IF e = 15 THEN BEGIN {Ende} {exit if end of block} 1005 inflate_codes := unzip_Ok; 1006 exit; 1007 END; 1008 NEEDBITS ( e ); {get length of block to copy} 1009 n := t^.v_n + ( b AND mask_bits [ e ] ); 1010 DUMPBITS ( e ); 1011 1012 NEEDBITS ( bd ); {decode distance of block to copy} 1013 t := @td^ [ b AND md ]; 1014 e := t^.e; 1015 IF e > 16 THEN REPEAT 1016 IF e = 99 THEN BEGIN 1017 inflate_codes := unzip_ZipFileErr; 1018 exit 1019 END; 1020 DUMPBITS ( t^.b ); 1021 dec ( e, 16 ); 1022 NEEDBITS ( e ); 1023 t := @t^.v_t^ [ b AND mask_bits [ e ] ]; 1024 e := t^.e; 1025 UNTIL e <= 16; 1026 DUMPBITS ( t^.b ); 1027 NEEDBITS ( e ); 1028 d := w -t^.v_n -b AND mask_bits [ e ]; 1029 DUMPBITS ( e ); 1030 {do the copy} 1031 REPEAT 1032 d := d AND ( WSIZE -1 ); 1033 IF d > w THEN e1 := WSIZE -d 1034 ELSE e1 := WSIZE -w; 1035 IF e1 > n THEN e1 := n; 1036 dec ( n, e1 ); 1037 IF ( longint(w) -d >= e1 ) THEN BEGIN 1038 move ( slide [ d ], slide [ w ], e1 ); 1039 inc ( w, e1 ); 1040 inc ( d, e1 ); 1041 END ELSE REPEAT 1042 slide [ w ] := slide [ d ]; 1043 inc ( w ); 1044 inc ( d ); 1045 dec ( e1 ); 1046 UNTIL ( e1 = 0 ); 1047 IF w = WSIZE THEN BEGIN 1048 IF NOT flush ( w ) THEN BEGIN 1049 inflate_codes := unzip_WriteErr; 1050 exit; 1051 END; 1052 w := 0; 1053 END; 1054 UNTIL n = 0; 1055 END; 1056 END; 1057 IF totalabort THEN 1058 inflate_codes := unzip_userabort 1059 ELSE 1060 inflate_codes := unzip_readErr; 1061END; 1062 1063{**************************** "decompress" stored block **************************} 1064 1065FUNCTION inflate_stored : integer; 1066VAR n : word; {number of bytes in block} 1067 1068BEGIN 1069 {go to byte boundary} 1070 n := k AND 7; 1071 dumpbits ( n ); 1072 {get the length and its complement} 1073 NEEDBITS ( 16 ); 1074 n := b AND $ffff; 1075 DUMPBITS ( 16 ); 1076 NEEDBITS ( 16 ); 1077 IF ( n <> ( NOT b ) AND $ffff ) THEN BEGIN 1078 inflate_stored := unzip_zipFileErr; 1079 exit 1080 END; 1081 DUMPBITS ( 16 ); 1082 WHILE ( n > 0 ) AND NOT ( totalabort OR zipeof ) DO BEGIN {read and output the compressed data} 1083 dec ( n ); 1084 NEEDBITS ( 8 ); 1085 slide [ w ] := char ( b ); 1086 inc ( w ); 1087 IF w = WSIZE THEN BEGIN 1088 IF NOT flush ( w ) THEN BEGIN 1089 inflate_stored := unzip_WriteErr; 1090 exit 1091 END; 1092 w := 0; 1093 END; 1094 DUMPBITS ( 8 ); 1095 END; 1096 IF totalabort THEN inflate_stored := unzip_UserAbort 1097 ELSE IF zipeof THEN inflate_stored := unzip_readErr 1098 ELSE inflate_stored := unzip_Ok; 1099END; 1100 1101{**************************** decompress fixed block **************************} 1102 1103FUNCTION inflate_fixed : integer; 1104VAR i : integer; {temporary variable} 1105 tl, {literal/length code table} 1106 td : phuftlist; {distance code table} 1107 bl, bd : integer; {lookup bits for tl/bd} 1108 l : ARRAY [ 0..287 ] of word; {length list for huft_build} 1109 1110BEGIN 1111 {set up literal table} 1112 FOR i := 0 TO 143 DO l [ i ] := 8; 1113 FOR i := 144 TO 255 DO l [ i ] := 9; 1114 FOR i := 256 TO 279 DO l [ i ] := 7; 1115 FOR i := 280 TO 287 DO l [ i ] := 8; {make a complete, but wrong code set} 1116 bl := 7; 1117 i := huft_build ( pword ( @l ), 288, 257, pushlist ( @cplens ), pushlist ( @cplext ), @tl, bl ); 1118 IF i <> huft_complete THEN BEGIN 1119 inflate_fixed := i; 1120 exit 1121 END; 1122 FOR i := 0 TO 29 DO l [ i ] := 5; {make an incomplete code set} 1123 bd := 5; 1124 i := huft_build ( pword ( @l ), 30, 0, pushlist ( @cpdist ), pushlist ( @cpdext ), @td, bd ); 1125 IF i > huft_incomplete THEN BEGIN 1126 huft_free ( tl ); 1127 inflate_fixed := unzip_ZipFileErr; 1128 exit 1129 END; 1130 inflate_fixed := inflate_codes ( tl, td, bl, bd ); 1131 huft_free ( tl ); 1132 huft_free ( td ); 1133END; 1134 1135{**************************** decompress dynamic block **************************} 1136 1137FUNCTION inflate_dynamic : integer; 1138VAR i : integer; {temporary variables} 1139 j, 1140 l, {last length} 1141 m, {mask for bit length table} 1142 n : word; {number of lengths to get} 1143 tl, {literal/length code table} 1144 td : phuftlist; {distance code table} 1145 bl, bd : integer; {lookup bits for tl/bd} 1146 nb, nl, nd : word; {number of bit length/literal length/distance codes} 1147 ll : ARRAY [ 0..288 + 32 -1 ] of word; {literal/length and distance code lengths} 1148 1149BEGIN 1150 {read in table lengths} 1151 NEEDBITS ( 5 ); 1152 nl := 257 + word ( b ) AND $1f; 1153 DUMPBITS ( 5 ); 1154 NEEDBITS ( 5 ); 1155 nd := 1 + word ( b ) AND $1f; 1156 DUMPBITS ( 5 ); 1157 NEEDBITS ( 4 ); 1158 nb := 4 + word ( b ) AND $f; 1159 DUMPBITS ( 4 ); 1160 IF ( nl > 288 ) OR ( nd > 32 ) THEN BEGIN 1161 inflate_dynamic := 1; 1162 exit 1163 END; 1164 fillchar ( ll, sizeof ( ll ), #0 ); 1165 1166 {read in bit-length-code lengths} 1167 FOR j := 0 TO nb -1 DO BEGIN 1168 NEEDBITS ( 3 ); 1169 ll [ border [ j ] ] := b AND 7; 1170 DUMPBITS ( 3 ); 1171 END; 1172 FOR j := nb TO 18 DO ll [ border [ j ] ] := 0; 1173 1174 {build decoding table for trees--single level, 7 bit lookup} 1175 bl := 7; 1176 i := huft_build ( pword ( @ll ), 19, 19, NIL, NIL, @tl, bl ); 1177 IF i <> huft_complete THEN BEGIN 1178 IF i = huft_incomplete THEN huft_free ( tl ); {other errors: already freed} 1179 inflate_dynamic := unzip_ZipFileErr; 1180 exit 1181 END; 1182 1183 {read in literal and distance code lengths} 1184 n := nl + nd; 1185 m := mask_bits [ bl ]; 1186 i := 0; l := 0; 1187 WHILE word ( i ) < n DO BEGIN 1188 NEEDBITS ( bl ); 1189 td := @tl^ [ b AND m ]; 1190 j := phuft ( td ) ^.b; 1191 DUMPBITS ( j ); 1192 j := phuft ( td ) ^.v_n; 1193 IF j < 16 THEN BEGIN {length of code in bits (0..15)} 1194 l := j; {ave last length in l} 1195 ll [ i ] := l; 1196 inc ( i ) 1197 END ELSE IF j = 16 THEN BEGIN {repeat last length 3 to 6 times} 1198 NEEDBITS ( 2 ); 1199 j := 3 + b AND 3; 1200 DUMPBITS ( 2 ); 1201 IF i + j > n THEN BEGIN 1202 inflate_dynamic := 1; 1203 exit 1204 END; 1205 WHILE j > 0 DO BEGIN 1206 ll [ i ] := l; 1207 dec ( j ); 1208 inc ( i ); 1209 END; 1210 END ELSE IF j = 17 THEN BEGIN {3 to 10 zero length codes} 1211 NEEDBITS ( 3 ); 1212 j := 3 + b AND 7; 1213 DUMPBITS ( 3 ); 1214 IF i + j > n THEN BEGIN 1215 inflate_dynamic := 1; 1216 exit 1217 END; 1218 WHILE j > 0 DO BEGIN 1219 ll [ i ] := 0; 1220 inc ( i ); 1221 dec ( j ); 1222 END; 1223 l := 0; 1224 END ELSE BEGIN {j == 18: 11 to 138 zero length codes} 1225 NEEDBITS ( 7 ); 1226 j := 11 + b AND $7f; 1227 DUMPBITS ( 7 ); 1228 IF i + j > n THEN BEGIN 1229 inflate_dynamic := unzip_zipfileErr; 1230 exit 1231 END; 1232 WHILE j > 0 DO BEGIN 1233 ll [ i ] := 0; 1234 dec ( j ); 1235 inc ( i ); 1236 END; 1237 l := 0; 1238 END; 1239 END; 1240 huft_free ( tl ); {free decoding table for trees} 1241 1242 {build the decoding tables for literal/length and distance codes} 1243 bl := lbits; 1244 i := huft_build ( pword ( @ll ), nl, 257, pushlist ( @cplens ), pushlist ( @cplext ), @tl, bl ); 1245 IF i <> huft_complete THEN BEGIN 1246 IF i = huft_incomplete THEN huft_free ( tl ); 1247 inflate_dynamic := unzip_ZipFileErr; 1248 exit 1249 END; 1250 bd := dbits; 1251 i := huft_build ( pword ( @ll [ nl ] ), nd, 0, pushlist ( @cpdist ), pushlist ( @cpdext ), @td, bd ); 1252 IF i > huft_incomplete THEN BEGIN {pkzip bug workaround} 1253 IF i = huft_incomplete THEN huft_free ( td ); 1254 huft_free ( tl ); 1255 inflate_dynamic := unzip_ZipFileErr; 1256 exit 1257 END; 1258 {decompress until an end-of-block code} 1259 inflate_dynamic := inflate_codes ( tl, td, bl, bd ); 1260 huft_free ( tl ); 1261 huft_free ( td ); 1262END; 1263 1264{**************************** decompress a block ******************************} 1265 1266FUNCTION inflate_block ( VAR e : integer ) : integer; 1267VAR t : word; {block type} 1268 1269BEGIN 1270 NEEDBITS ( 1 ); 1271 e := b AND 1; 1272 DUMPBITS ( 1 ); 1273 1274 NEEDBITS ( 2 ); 1275 t := b AND 3; 1276 DUMPBITS ( 2 ); 1277 1278 CASE t of 1279 2 : inflate_block := inflate_dynamic; 1280 0 : inflate_block := inflate_stored; 1281 1 : inflate_block := inflate_fixed; 1282 ELSE 1283 inflate_block := unzip_ZipFileErr; {bad block type} 1284 END; 1285END; 1286 1287{**************************** decompress an inflated entry **************************} 1288 1289FUNCTION inflate : integer; 1290VAR e, {last block flag} 1291 r : integer; {result code} 1292 1293BEGIN 1294 inpos := 0; {Input buffer position} 1295 readpos := -1; {Nothing read} 1296 1297 {initialize window, bit buffer} 1298 w := 0; 1299 k := 0; 1300 b := 0; 1301 1302 {decompress until the last block} 1303 REPEAT 1304 r := inflate_block ( e ); 1305 IF r <> 0 THEN BEGIN 1306 inflate := r; 1307 exit 1308 END; 1309 UNTIL e <> 0; 1310 {flush out slide} 1311 IF NOT flush ( w ) THEN inflate := unzip_WriteErr 1312 ELSE inflate := unzip_Ok; 1313END; 1314(***************************************************************************) 1315{.$I z_copyst.pas} {Copy stored file} 1316{include for unzip.pas: Copy stored file} 1317 1318{C code by info-zip group, translated to Pascal by Christian Ghisler} 1319{based on unz51g.zip} 1320 1321{************************* copy stored file ************************************} 1322FUNCTION copystored : integer; 1323VAR readin : longint; 1324 outcnt : nword; 1325BEGIN 1326 WHILE ( reachedsize < compsize ) AND NOT totalabort DO BEGIN 1327 readin := compsize -reachedsize; 1328 IF readin > wsize THEN readin := wsize; 1329 {$push} {$I-} 1330 blockread ( infile, slide [ 0 ], readin, outcnt ); {Use slide as buffer} 1331 {$pop} 1332 IF ( outcnt <> readin ) OR ( ioresult <> 0 ) THEN BEGIN 1333 copystored := unzip_ReadErr; 1334 exit 1335 END; 1336 IF NOT flush ( outcnt ) THEN BEGIN {Flushoutput takes care of CRC too} 1337 copystored := unzip_WriteErr; 1338 exit 1339 END; 1340 inc ( reachedsize, outcnt ); 1341 END; 1342 IF NOT totalabort THEN 1343 copystored := unzip_Ok 1344 ELSE 1345 copystored := unzip_Userabort; 1346END; 1347(***************************************************************************) 1348{.$I z_explod.pas} {Explode imploded file} 1349{include for unzip.pas: Explode imploded file} 1350 1351{C code by info-zip group, translated to Pascal by Christian Ghisler} 1352{based on unz51g.zip} 1353 1354{************************************* explode ********************************} 1355 1356{*********************************** read in tree *****************************} 1357FUNCTION get_tree ( l : pword;n : word ) : integer; 1358VAR i, k, j, b : word; 1359 bytebuf : byte; 1360 1361BEGIN 1362 READBYTE ( bytebuf ); 1363 i := bytebuf; 1364 inc ( i ); 1365 k := 0; 1366 REPEAT 1367 READBYTE ( bytebuf ); 1368 j := bytebuf; 1369 b := ( j AND $F ) + 1; 1370 j := ( ( j AND $F0 ) SHR 4 ) + 1; 1371 IF ( k + j ) > n THEN BEGIN 1372 get_tree := 4; 1373 exit 1374 END; 1375 REPEAT 1376 l^ := b; 1377 inc ( ptrint ( l ), sizeof ( word ) ); 1378 inc ( k ); 1379 dec ( j ); 1380 UNTIL j = 0; 1381 dec ( i ); 1382 UNTIL i = 0; 1383 IF k <> n THEN get_tree := 4 ELSE get_tree := 0; 1384END; 1385 1386{******************exploding, method: 8k slide, 3 trees ***********************} 1387 1388FUNCTION explode_lit8 ( tb, tl, td : phuftlist;bb, bl, bd : integer ) : integer; 1389VAR s : longint; 1390 e : word; 1391 n, d : word; 1392 w : word; 1393 t : phuft; 1394 mb, ml, md : word; 1395 u : word; 1396 1397BEGIN 1398 b := 0; k := 0; w := 0; 1399 u := 1; 1400 mb := mask_bits [ bb ]; 1401 ml := mask_bits [ bl ]; 1402 md := mask_bits [ bd ]; 1403 s := uncompsize; 1404 WHILE ( s > 0 ) AND NOT ( totalabort OR zipeof ) DO BEGIN 1405 NEEDBITS ( 1 ); 1406 IF ( b AND 1 ) <> 0 THEN BEGIN {Litteral} 1407 DUMPBITS ( 1 ); 1408 dec ( s ); 1409 NEEDBITS ( bb ); 1410 t := @tb^ [ ( NOT b ) AND mb ]; 1411 e := t^.e; 1412 IF e > 16 THEN REPEAT 1413 IF e = 99 THEN BEGIN 1414 explode_lit8 := unzip_ZipFileErr; 1415 exit 1416 END; 1417 DUMPBITS ( t^.b ); 1418 dec ( e, 16 ); 1419 NEEDBITS ( e ); 1420 t := @t^.v_t^ [ ( NOT b ) AND mask_bits [ e ] ]; 1421 e := t^.e; 1422 UNTIL e <= 16; 1423 DUMPBITS ( t^.b ); 1424 slide [ w ] := char ( t^.v_n ); 1425 inc ( w ); 1426 IF w = WSIZE THEN BEGIN 1427 IF NOT flush ( w ) THEN BEGIN 1428 explode_lit8 := unzip_WriteErr; 1429 exit 1430 END; 1431 w := 0; u := 0; 1432 END; 1433 END ELSE BEGIN 1434 DUMPBITS ( 1 ); 1435 NEEDBITS ( 7 ); 1436 d := b AND $7F; 1437 DUMPBITS ( 7 ); 1438 NEEDBITS ( bd ); 1439 t := @td^ [ ( NOT b ) AND md ]; 1440 e := t^.e; 1441 IF e > 16 THEN REPEAT 1442 IF e = 99 THEN BEGIN 1443 explode_lit8 := unzip_ZipFileErr; 1444 exit 1445 END; 1446 DUMPBITS ( t^.b ); 1447 dec ( e, 16 ); 1448 NEEDBITS ( e ); 1449 t := @t^.v_t^ [ ( NOT b ) AND mask_bits [ e ] ]; 1450 e := t^.e; 1451 UNTIL e <= 16; 1452 DUMPBITS ( t^.b ); 1453 1454 d := w -d -t^.v_n; 1455 NEEDBITS ( bl ); 1456 t := @tl^ [ ( NOT b ) AND ml ]; 1457 e := t^.e; 1458 IF e > 16 THEN REPEAT 1459 IF e = 99 THEN BEGIN 1460 explode_lit8 := unzip_ZipFileErr; 1461 exit 1462 END; 1463 DUMPBITS ( t^.b ); 1464 dec ( e, 16 ); 1465 NEEDBITS ( e ); 1466 t := @t^.v_t^ [ ( NOT b ) AND mask_bits [ e ] ]; 1467 e := t^.e; 1468 UNTIL e <= 16; 1469 1470 DUMPBITS ( t^.b ); 1471 1472 n := t^.v_n; 1473 IF e <> 0 THEN BEGIN 1474 NEEDBITS ( 8 ); 1475 inc ( n, byte ( b ) AND $ff ); 1476 DUMPBITS ( 8 ); 1477 END; 1478 dec ( s, n ); 1479 REPEAT 1480 d := d AND pred ( WSIZE ); 1481 IF d > w THEN e := WSIZE -d ELSE e := WSIZE -w; 1482 IF e > n THEN e := n; 1483 dec ( n, e ); 1484 IF ( u <> 0 ) AND ( w <= d ) THEN BEGIN 1485 fillchar ( slide [ w ], e, #0 ); 1486 inc ( w, e ); 1487 inc ( d, e ); 1488 END ELSE IF ( w -d >= e ) THEN BEGIN 1489 move ( slide [ d ], slide [ w ], e ); 1490 inc ( w, e ); 1491 inc ( d, e ); 1492 END ELSE REPEAT 1493 slide [ w ] := slide [ d ]; 1494 inc ( w ); 1495 inc ( d ); 1496 dec ( e ); 1497 UNTIL e = 0; 1498 IF w = WSIZE THEN BEGIN 1499 IF NOT flush ( w ) THEN BEGIN 1500 explode_lit8 := unzip_WriteErr; 1501 exit 1502 END; 1503 w := 0; u := 0; 1504 END; 1505 UNTIL n = 0; 1506 END; 1507 END; 1508 IF totalabort THEN explode_lit8 := unzip_userabort 1509 ELSE 1510 IF NOT flush ( w ) THEN explode_lit8 := unzip_WriteErr 1511 ELSE 1512 IF zipeof THEN explode_lit8 := unzip_readErr 1513 ELSE 1514 explode_lit8 := unzip_Ok; 1515END; 1516 1517{******************exploding, method: 4k slide, 3 trees ***********************} 1518 1519FUNCTION explode_lit4 ( tb, tl, td : phuftlist;bb, bl, bd : integer ) : integer; 1520VAR s : longint; 1521 e : word; 1522 n, d : word; 1523 w : word; 1524 t : phuft; 1525 mb, ml, md : word; 1526 u : word; 1527 1528BEGIN 1529 b := 0; k := 0; w := 0; 1530 u := 1; 1531 mb := mask_bits [ bb ]; 1532 ml := mask_bits [ bl ]; 1533 md := mask_bits [ bd ]; 1534 s := uncompsize; 1535 WHILE ( s > 0 ) AND NOT ( totalabort OR zipeof ) DO BEGIN 1536 NEEDBITS ( 1 ); 1537 IF ( b AND 1 ) <> 0 THEN BEGIN {Litteral} 1538 DUMPBITS ( 1 ); 1539 dec ( s ); 1540 NEEDBITS ( bb ); 1541 t := @tb^ [ ( NOT b ) AND mb ]; 1542 e := t^.e; 1543 IF e > 16 THEN REPEAT 1544 IF e = 99 THEN BEGIN 1545 explode_lit4 := unzip_ZipFileErr; 1546 exit 1547 END; 1548 DUMPBITS ( t^.b ); 1549 dec ( e, 16 ); 1550 NEEDBITS ( e ); 1551 t := @t^.v_t^ [ ( NOT b ) AND mask_bits [ e ] ]; 1552 e := t^.e; 1553 UNTIL e <= 16; 1554 DUMPBITS ( t^.b ); 1555 slide [ w ] := char ( t^.v_n ); 1556 inc ( w ); 1557 IF w = WSIZE THEN BEGIN 1558 IF NOT flush ( w ) THEN BEGIN 1559 explode_lit4 := unzip_WriteErr; 1560 exit 1561 END; 1562 w := 0; u := 0; 1563 END; 1564 END ELSE BEGIN 1565 DUMPBITS ( 1 ); 1566 NEEDBITS ( 6 ); 1567 d := b AND $3F; 1568 DUMPBITS ( 6 ); 1569 NEEDBITS ( bd ); 1570 t := @td^ [ ( NOT b ) AND md ]; 1571 e := t^.e; 1572 IF e > 16 THEN REPEAT 1573 IF e = 99 THEN BEGIN 1574 explode_lit4 := unzip_ZipFileErr; 1575 exit 1576 END; 1577 DUMPBITS ( t^.b ); 1578 dec ( e, 16 ); 1579 NEEDBITS ( e ); 1580 t := @t^.v_t^ [ ( NOT b ) AND mask_bits [ e ] ]; 1581 e := t^.e; 1582 UNTIL e <= 16; 1583 DUMPBITS ( t^.b ); 1584 d := w -d -t^.v_n; 1585 NEEDBITS ( bl ); 1586 t := @tl^ [ ( NOT b ) AND ml ]; 1587 e := t^.e; 1588 IF e > 16 THEN REPEAT 1589 IF e = 99 THEN BEGIN 1590 explode_lit4 := unzip_ZipFileErr; 1591 exit 1592 END; 1593 DUMPBITS ( t^.b ); 1594 dec ( e, 16 ); 1595 NEEDBITS ( e ); 1596 t := @t^.v_t^ [ ( NOT b ) AND mask_bits [ e ] ]; 1597 e := t^.e; 1598 UNTIL e <= 16; 1599 1600 DUMPBITS ( t^.b ); 1601 n := t^.v_n; 1602 IF e <> 0 THEN BEGIN 1603 NEEDBITS ( 8 ); 1604 inc ( n, b AND $ff ); 1605 DUMPBITS ( 8 ); 1606 END; 1607 dec ( s, n ); 1608 REPEAT 1609 d := d AND pred ( WSIZE ); 1610 IF d > w THEN e := WSIZE -d ELSE e := WSIZE -w; 1611 IF e > n THEN e := n; 1612 dec ( n, e ); 1613 IF ( u <> 0 ) AND ( w <= d ) THEN BEGIN 1614 fillchar ( slide [ w ], e, #0 ); 1615 inc ( w, e ); 1616 inc ( d, e ); 1617 END ELSE IF ( w -d >= e ) THEN BEGIN 1618 move ( slide [ d ], slide [ w ], e ); 1619 inc ( w, e ); 1620 inc ( d, e ); 1621 END ELSE REPEAT 1622 slide [ w ] := slide [ d ]; 1623 inc ( w ); 1624 inc ( d ); 1625 dec ( e ); 1626 UNTIL e = 0; 1627 IF w = WSIZE THEN BEGIN 1628 IF NOT flush ( w ) THEN BEGIN 1629 explode_lit4 := unzip_WriteErr; 1630 exit 1631 END; 1632 w := 0; u := 0; 1633 END; 1634 UNTIL n = 0; 1635 END; 1636 END; 1637 IF totalabort THEN explode_lit4 := unzip_userabort 1638 ELSE 1639 IF NOT flush ( w ) THEN explode_lit4 := unzip_WriteErr 1640 ELSE 1641 IF zipeof THEN explode_lit4 := unzip_readErr 1642 ELSE explode_lit4 := unzip_Ok; 1643END; 1644 1645{******************exploding, method: 8k slide, 2 trees ***********************} 1646 1647FUNCTION explode_nolit8 ( tl, td : phuftlist;bl, bd : integer ) : integer; 1648VAR s : longint; 1649 e : word; 1650 n, d : word; 1651 w : word; 1652 t : phuft; 1653 ml, md : word; 1654 u : word; 1655 1656BEGIN 1657 b := 0; k := 0; w := 0; 1658 u := 1; 1659 ml := mask_bits [ bl ]; 1660 md := mask_bits [ bd ]; 1661 s := uncompsize; 1662 WHILE ( s > 0 ) AND NOT ( totalabort OR zipeof ) DO BEGIN 1663 NEEDBITS ( 1 ); 1664 IF ( b AND 1 ) <> 0 THEN BEGIN {Litteral} 1665 DUMPBITS ( 1 ); 1666 dec ( s ); 1667 NEEDBITS ( 8 ); 1668 slide [ w ] := char ( b ); 1669 inc ( w ); 1670 IF w = WSIZE THEN BEGIN 1671 IF NOT flush ( w ) THEN BEGIN 1672 explode_nolit8 := unzip_WriteErr; 1673 exit 1674 END; 1675 w := 0; u := 0; 1676 END; 1677 DUMPBITS ( 8 ); 1678 END ELSE BEGIN 1679 DUMPBITS ( 1 ); 1680 NEEDBITS ( 7 ); 1681 d := b AND $7F; 1682 DUMPBITS ( 7 ); 1683 NEEDBITS ( bd ); 1684 t := @td^ [ ( NOT b ) AND md ]; 1685 e := t^.e; 1686 IF e > 16 THEN REPEAT 1687 IF e = 99 THEN BEGIN 1688 explode_nolit8 := unzip_ZipFileErr; 1689 exit 1690 END; 1691 DUMPBITS ( t^.b ); 1692 dec ( e, 16 ); 1693 NEEDBITS ( e ); 1694 t := @t^.v_t^ [ ( NOT b ) AND mask_bits [ e ] ]; 1695 e := t^.e; 1696 UNTIL e <= 16; 1697 DUMPBITS ( t^.b ); 1698 1699 d := w -d -t^.v_n; 1700 NEEDBITS ( bl ); 1701 t := @tl^ [ ( NOT b ) AND ml ]; 1702 e := t^.e; 1703 IF e > 16 THEN REPEAT 1704 IF e = 99 THEN BEGIN 1705 explode_nolit8 := unzip_ZipFileErr; 1706 exit 1707 END; 1708 DUMPBITS ( t^.b ); 1709 dec ( e, 16 ); 1710 NEEDBITS ( e ); 1711 t := @t^.v_t^ [ ( NOT b ) AND mask_bits [ e ] ]; 1712 e := t^.e; 1713 UNTIL e <= 16; 1714 1715 DUMPBITS ( t^.b ); 1716 1717 n := t^.v_n; 1718 IF e <> 0 THEN BEGIN 1719 NEEDBITS ( 8 ); 1720 inc ( n, b AND $ff ); 1721 DUMPBITS ( 8 ); 1722 END; 1723 dec ( s, n ); 1724 REPEAT 1725 d := d AND pred ( WSIZE ); 1726 IF d > w THEN e := WSIZE -d ELSE e := WSIZE -w; 1727 IF e > n THEN e := n; 1728 dec ( n, e ); 1729 IF ( u <> 0 ) AND ( w <= d ) THEN BEGIN 1730 fillchar ( slide [ w ], e, #0 ); 1731 inc ( w, e ); 1732 inc ( d, e ); 1733 END ELSE IF ( w -d >= e ) THEN BEGIN 1734 move ( slide [ d ], slide [ w ], e ); 1735 inc ( w, e ); 1736 inc ( d, e ); 1737 END ELSE REPEAT 1738 slide [ w ] := slide [ d ]; 1739 inc ( w ); 1740 inc ( d ); 1741 dec ( e ); 1742 UNTIL e = 0; 1743 IF w = WSIZE THEN BEGIN 1744 IF NOT flush ( w ) THEN BEGIN 1745 explode_nolit8 := unzip_WriteErr; 1746 exit 1747 END; 1748 w := 0; u := 0; 1749 END; 1750 UNTIL n = 0; 1751 END; 1752 END; 1753 IF totalabort THEN explode_nolit8 := unzip_userabort 1754 ELSE 1755 IF NOT flush ( w ) THEN explode_nolit8 := unzip_WriteErr 1756 ELSE 1757 IF zipeof THEN explode_nolit8 := unzip_readErr 1758 ELSE explode_nolit8 := unzip_Ok; 1759END; 1760 1761{******************exploding, method: 4k slide, 2 trees ***********************} 1762 1763FUNCTION explode_nolit4 ( tl, td : phuftlist;bl, bd : integer ) : integer; 1764VAR s : longint; 1765 e : word; 1766 n, d : word; 1767 w : word; 1768 t : phuft; 1769 ml, md : word; 1770 u : word; 1771 1772BEGIN 1773 b := 0; k := 0; w := 0; 1774 u := 1; 1775 ml := mask_bits [ bl ]; 1776 md := mask_bits [ bd ]; 1777 s := uncompsize; 1778 WHILE ( s > 0 ) AND NOT ( totalabort OR zipeof ) DO BEGIN 1779 NEEDBITS ( 1 ); 1780 IF ( b AND 1 ) <> 0 THEN BEGIN {Litteral} 1781 DUMPBITS ( 1 ); 1782 dec ( s ); 1783 NEEDBITS ( 8 ); 1784 slide [ w ] := char ( b ); 1785 inc ( w ); 1786 IF w = WSIZE THEN BEGIN 1787 IF NOT flush ( w ) THEN BEGIN 1788 explode_nolit4 := unzip_WriteErr; 1789 exit 1790 END; 1791 w := 0; u := 0; 1792 END; 1793 DUMPBITS ( 8 ); 1794 END ELSE BEGIN 1795 DUMPBITS ( 1 ); 1796 NEEDBITS ( 6 ); 1797 d := b AND $3F; 1798 DUMPBITS ( 6 ); 1799 NEEDBITS ( bd ); 1800 t := @td^ [ ( NOT b ) AND md ]; 1801 e := t^.e; 1802 IF e > 16 THEN REPEAT 1803 IF e = 99 THEN BEGIN 1804 explode_nolit4 := unzip_ZipFileErr; 1805 exit 1806 END; 1807 DUMPBITS ( t^.b ); 1808 dec ( e, 16 ); 1809 NEEDBITS ( e ); 1810 t := @t^.v_t^ [ ( NOT b ) AND mask_bits [ e ] ]; 1811 e := t^.e; 1812 UNTIL e <= 16; 1813 DUMPBITS ( t^.b ); 1814 d := w -d -t^.v_n; 1815 NEEDBITS ( bl ); 1816 t := @tl^ [ ( NOT b ) AND ml ]; 1817 e := t^.e; 1818 IF e > 16 THEN REPEAT 1819 IF e = 99 THEN BEGIN 1820 explode_nolit4 := unzip_ZipFileErr; 1821 exit 1822 END; 1823 DUMPBITS ( t^.b ); 1824 dec ( e, 16 ); 1825 NEEDBITS ( e ); 1826 t := @t^.v_t^ [ ( NOT b ) AND mask_bits [ e ] ]; 1827 e := t^.e; 1828 UNTIL e <= 16; 1829 1830 DUMPBITS ( t^.b ); 1831 n := t^.v_n; 1832 IF e <> 0 THEN BEGIN 1833 NEEDBITS ( 8 ); 1834 inc ( n, b AND $ff ); 1835 DUMPBITS ( 8 ); 1836 END; 1837 dec ( s, n ); 1838 REPEAT 1839 d := d AND pred ( WSIZE ); 1840 IF d > w THEN e := WSIZE -d ELSE e := WSIZE -w; 1841 IF e > n THEN e := n; 1842 dec ( n, e ); 1843 IF ( u <> 0 ) AND ( w <= d ) THEN BEGIN 1844 fillchar ( slide [ w ], e, #0 ); 1845 inc ( w, e ); 1846 inc ( d, e ); 1847 END ELSE IF ( w -d >= e ) THEN BEGIN 1848 move ( slide [ d ], slide [ w ], e ); 1849 inc ( w, e ); 1850 inc ( d, e ); 1851 END ELSE REPEAT 1852 slide [ w ] := slide [ d ]; 1853 inc ( w ); 1854 inc ( d ); 1855 dec ( e ); 1856 UNTIL e = 0; 1857 IF w = WSIZE THEN BEGIN 1858 IF NOT flush ( w ) THEN BEGIN 1859 explode_nolit4 := unzip_WriteErr; 1860 exit 1861 END; 1862 w := 0; u := 0; 1863 END; 1864 UNTIL n = 0; 1865 END; 1866 END; 1867 IF totalabort THEN explode_nolit4 := unzip_userabort 1868 ELSE 1869 IF NOT flush ( w ) THEN explode_nolit4 := unzip_WriteErr 1870 ELSE 1871 IF zipeof THEN explode_nolit4 := unzip_readErr 1872 ELSE explode_nolit4 := unzip_Ok; 1873END; 1874 1875{****************************** explode *********************************} 1876 1877FUNCTION explode : integer; 1878VAR r : integer; 1879 tb, tl, td : phuftlist; 1880 bb, bl, bd : integer; 1881 l : ARRAY [ 0..255 ] of word; 1882 1883BEGIN 1884 inpos := 0; 1885 readpos := -1; {Nothing read in} 1886 bl := 7; 1887 IF compsize > 200000 THEN bd := 8 ELSE bd := 7; 1888 IF hufttype AND 4 <> 0 THEN BEGIN 1889 bb := 9; 1890 r := get_tree ( @l [ 0 ], 256 ); 1891 IF r <> 0 THEN BEGIN 1892 explode := unzip_ZipFileErr; 1893 exit 1894 END; 1895 r := huft_build ( @l, 256, 256, NIL, NIL, @tb, bb ); 1896 IF r <> 0 THEN BEGIN 1897 IF r = huft_incomplete THEN huft_free ( tb ); 1898 explode := unzip_ZipFileErr; 1899 exit 1900 END; 1901 r := get_tree ( @l [ 0 ], 64 ); 1902 IF r <> 0 THEN BEGIN 1903 huft_free ( tb ); 1904 explode := unzip_ZipFileErr; 1905 exit 1906 END; 1907 r := huft_build ( @l, 64, 0, pushlist ( @cplen3 ), pushlist ( @extra ), @tl, bl ); 1908 IF r <> 0 THEN BEGIN 1909 IF r = huft_incomplete THEN huft_free ( tl ); 1910 huft_free ( tb ); 1911 explode := unzip_ZipFileErr; 1912 exit 1913 END; 1914 r := get_tree ( @l [ 0 ], 64 ); 1915 IF r <> 0 THEN BEGIN 1916 huft_free ( tb ); 1917 huft_free ( tl ); 1918 explode := unzip_ZipFileErr; 1919 exit 1920 END; 1921 IF hufttype AND 2 <> 0 THEN BEGIN {8k} 1922 r := huft_build ( @l, 64, 0, pushlist ( @cpdist8 ), pushlist ( @extra ), @td, bd ); 1923 IF r <> 0 THEN BEGIN 1924 IF r = huft_incomplete THEN huft_free ( td ); 1925 huft_free ( tb ); 1926 huft_free ( tl ); 1927 explode := unzip_ZipFileErr; 1928 exit 1929 END; 1930 r := explode_lit8 ( tb, tl, td, bb, bl, bd ); 1931 END ELSE BEGIN 1932 r := huft_build ( @l, 64, 0, pushlist ( @cpdist4 ), pushlist ( @extra ), @td, bd ); 1933 IF r <> 0 THEN BEGIN 1934 IF r = huft_incomplete THEN huft_free ( td ); 1935 huft_free ( tb ); 1936 huft_free ( tl ); 1937 explode := unzip_ZipFileErr; 1938 exit 1939 END; 1940 r := explode_lit4 ( tb, tl, td, bb, bl, bd ); 1941 END; 1942 huft_free ( td ); 1943 huft_free ( tl ); 1944 huft_free ( tb ); 1945 END ELSE BEGIN {No literal tree} 1946 r := get_tree ( @l [ 0 ], 64 ); 1947 IF r <> 0 THEN BEGIN 1948 explode := unzip_ZipFileErr; 1949 exit 1950 END; 1951 r := huft_build ( @l, 64, 0, pushlist ( @cplen2 ), pushlist ( @extra ), @tl, bl ); 1952 IF r <> 0 THEN BEGIN 1953 IF r = huft_incomplete THEN huft_free ( tl ); 1954 explode := unzip_ZipFileErr; 1955 exit 1956 END; 1957 1958 r := get_tree ( @l [ 0 ], 64 ); 1959 IF r <> 0 THEN BEGIN 1960 huft_free ( tl ); 1961 explode := unzip_ZipFileErr; 1962 exit 1963 END; 1964 IF hufttype AND 2 <> 0 THEN BEGIN {8k} 1965 r := huft_build ( @l, 64, 0, pushlist ( @cpdist8 ), pushlist ( @extra ), @td, bd ); 1966 IF r <> 0 THEN BEGIN 1967 IF r = huft_incomplete THEN huft_free ( td ); 1968 huft_free ( tl ); 1969 explode := unzip_ZipFileErr; 1970 exit 1971 END; 1972 r := explode_nolit8 ( tl, td, bl, bd ); 1973 END ELSE BEGIN 1974 r := huft_build ( @l, 64, 0, pushlist ( @cpdist4 ), pushlist ( @extra ), @td, bd ); 1975 IF r <> 0 THEN BEGIN 1976 IF r = huft_incomplete THEN huft_free ( td ); 1977 huft_free ( tl ); 1978 explode := unzip_ZipFileErr; 1979 exit 1980 END; 1981 r := explode_nolit4 ( tl, td, bl, bd ); 1982 END; 1983 huft_free ( td ); 1984 huft_free ( tl ); 1985 END; 1986 explode := r; 1987END; 1988(***************************************************************************) 1989{.$I z_shrunk.pas} {Unshrink function} 1990{*************************** unshrink **********************************} 1991{Written and NOT copyrighted by Christian Ghisler. 1992 I have rewritten unshrink because the original 1993 function was copyrighted by Mr. Smith of Info-zip 1994 This funtion here is now completely FREE!!!! 1995 The only right I claim on this code is that 1996 noone else claims a copyright on it!} 1997 1998 1999CONST max_code = 8192; 2000 max_stack = 8192; 2001 initial_code_size = 9; 2002 final_code_size = 13; 2003 write_max = wsize -3 * ( max_code -256 ) -max_stack -2; {Rest of slide=write buffer} 2004 {=766 bytes} 2005 2006TYPE prev = ARRAY [ 257..max_code ] of integer; 2007 pprev = ^prev; 2008 cds = ARRAY [ 257..max_code ] of char; 2009 pcds = ^cds; 2010 stacktype = ARRAY [ 0..max_stack ] of char; 2011 pstacktype = ^stacktype; 2012 writebuftype = ARRAY [ 0..write_max ] of char; {write buffer} 2013 pwritebuftype = ^writebuftype; 2014 2015VAR previous_code : pprev; {previous code trie} 2016 actual_code : pcds; {actual code trie} 2017 stack : pstacktype; {Stack for output} 2018 writebuf : pwritebuftype; {Write buffer} 2019 next_free, {Next free code in trie} 2020 write_ptr : integer; {Pointer to output buffer} 2021 2022FUNCTION unshrink_flush : boolean; 2023VAR 2024n : nword; 2025b : boolean; 2026BEGIN 2027 {$push} {$I-} 2028 blockwrite ( outfile, writebuf^ [ 0 ], write_ptr, n ); 2029 {$pop} 2030 b := ( n = write_ptr ) AND ( ioresult = 0 ); {True-> alles ok} 2031 UpdateCRC ( iobuf ( pointer ( @writebuf^ [ 0 ] ) ^ ), write_ptr ); 2032 {--} 2033{$IFDEF FPC} 2034 IF ( b = TRUE ) AND Assigned(ZipReport) {callback report for high level functions} 2035{$ELSE} 2036 IF ( b = TRUE ) AND ( @ZipReport <> NIL ) {callback report for high level functions} 2037{$ENDIF} 2038 THEN BEGIN 2039 WITH ZipRec DO BEGIN 2040 Status := file_unzipping; 2041 ZipReport ( n, @ZipRec ); {report the actual bytes written} 2042 END; 2043 END; {report} 2044 unshrink_flush := b; 2045END; 2046 2047FUNCTION write_char ( c : char ) : boolean; 2048BEGIN 2049 writebuf^ [ write_ptr ] := c; 2050 inc ( write_ptr ); 2051 IF write_ptr > write_max THEN BEGIN 2052 write_char := unshrink_flush; 2053 write_ptr := 0; 2054 END ELSE write_char := TRUE; 2055END; 2056 2057PROCEDURE ClearLeafNodes; 2058VAR pc, {previous code} 2059 i, {index} 2060 act_max_code : integer; {max code to be searched for leaf nodes} 2061 previous : pprev; {previous code trie} 2062 2063BEGIN 2064 previous := previous_code; 2065 act_max_code := next_free -1; 2066 FOR i := 257 TO act_max_code DO 2067 previous^ [ i ] := previous^ [ i ] OR $8000; 2068 FOR i := 257 TO act_max_code DO BEGIN 2069 pc := previous^ [ i ] AND NOT $8000; 2070 IF pc > 256 THEN 2071 previous^ [ pc ] := previous^ [ pc ] AND ( NOT $8000 ); 2072 END; 2073 {Build new free list} 2074 pc := -1; 2075 next_free := -1; 2076 FOR i := 257 TO act_max_code DO 2077 IF previous^ [ i ] AND $C000 <> 0 THEN BEGIN {Either free before or marked now} 2078 IF pc <> -1 THEN previous^ [ pc ] := -i {Link last item to this item} 2079 ELSE next_free := i; 2080 pc := i; 2081 END; 2082 IF pc <> -1 THEN 2083 previous^ [ pc ] := -act_max_code -1; 2084END; 2085 2086 2087FUNCTION unshrink : integer; 2088 2089VAR incode : integer; {code read in} 2090 lastincode : integer; {last code read in} 2091 lastoutcode : char; {last code emitted} 2092 code_size : byte; {Actual code size} 2093 stack_ptr, {Stackpointer} 2094 new_code, {Save new code read} 2095 code_mask, {mask for coding} 2096 i : integer; {Index} 2097 bits_to_read : longint; 2098 2099BEGIN 2100 IF compsize = maxlongint THEN BEGIN {Compressed Size was not in header!} 2101 unshrink := unzip_NotSupported; 2102 exit 2103 END; 2104 inpos := 0; {Input buffer position} 2105 readpos := -1; {Nothing read} 2106 2107 {initialize window, bit buffer} 2108 w := 0; 2109 k := 0; 2110 b := 0; 2111 2112 {Initialize pointers for various buffers} 2113 previous_code := @slide [ 0 ]; 2114 actual_code := @slide [ sizeof ( prev ) ]; 2115 stack := @slide [ sizeof ( prev ) + sizeof ( cds ) ]; 2116 writebuf := @slide [ sizeof ( prev ) + sizeof ( cds ) + sizeof ( stacktype ) ]; 2117 fillchar ( slide^, wsize, #0 ); 2118 2119 {initialize free codes list} 2120 FOR i := 257 TO max_code DO 2121 previous_code^ [ i ] := - ( i + 1 ); 2122 next_free := 257; 2123 stack_ptr := max_stack; 2124 write_ptr := 0; 2125 code_size := initial_code_size; 2126 code_mask := mask_bits [ code_size ]; 2127 2128 NEEDBITS ( code_size ); 2129 incode := b AND code_mask; 2130 DUMPBITS ( code_size ); 2131 2132 lastincode := incode; 2133 lastoutcode := char ( incode ); 2134 IF NOT write_char ( lastoutcode ) THEN BEGIN 2135 unshrink := unzip_writeErr; 2136 exit 2137 END; 2138 2139 bits_to_read := 8 * compsize -code_size; {Bits to be read} 2140 2141 WHILE NOT totalabort AND ( bits_to_read >= code_size ) DO BEGIN 2142 NEEDBITS ( code_size ); 2143 incode := b AND code_mask; 2144 DUMPBITS ( code_size ); 2145 dec ( bits_to_read, code_size ); 2146 IF incode = 256 THEN BEGIN {Special code} 2147 NEEDBITS ( code_size ); 2148 incode := b AND code_mask; 2149 DUMPBITS ( code_size ); 2150 dec ( bits_to_read, code_size ); 2151 CASE incode of 2152 1 : BEGIN 2153 inc ( code_size ); 2154 IF code_size > final_code_size THEN BEGIN 2155 unshrink := unzip_ZipFileErr; 2156 exit 2157 END; 2158 code_mask := mask_bits [ code_size ]; 2159 END; 2160 2 : BEGIN 2161 ClearLeafNodes; 2162 END; 2163 ELSE 2164 unshrink := unzip_ZipFileErr; 2165 exit 2166 END; 2167 END ELSE BEGIN 2168 new_code := incode; 2169 IF incode < 256 THEN BEGIN {Simple char} 2170 lastoutcode := char ( incode ); 2171 IF NOT write_char ( lastoutcode ) THEN BEGIN 2172 unshrink := unzip_writeErr; 2173 exit 2174 END; 2175 END ELSE BEGIN 2176 IF previous_code^ [ incode ] < 0 THEN BEGIN 2177 stack^ [ stack_ptr ] := lastoutcode; 2178 dec ( stack_ptr ); 2179 incode := lastincode; 2180 END; 2181 WHILE incode > 256 DO BEGIN 2182 stack^ [ stack_ptr ] := actual_code^ [ incode ]; 2183 dec ( stack_ptr ); 2184 incode := previous_code^ [ incode ]; 2185 END; 2186 lastoutcode := char ( incode ); 2187 IF NOT write_char ( lastoutcode ) THEN BEGIN 2188 unshrink := unzip_writeErr; 2189 exit 2190 END; 2191 FOR i := stack_ptr + 1 TO max_stack DO 2192 IF NOT write_char ( stack^ [ i ] ) THEN BEGIN 2193 unshrink := unzip_writeErr; 2194 exit 2195 END; 2196 stack_ptr := max_stack; 2197 END; 2198 incode := next_free; 2199 IF incode <= max_code THEN BEGIN 2200 next_free := -previous_code^ [ incode ]; {Next node in free list} 2201 previous_code^ [ incode ] := lastincode; 2202 actual_code^ [ incode ] := lastoutcode; 2203 END; 2204 lastincode := new_code; 2205 END; 2206 END; 2207 IF totalabort THEN 2208 unshrink := unzip_UserAbort 2209 ELSE IF unshrink_flush THEN 2210 unshrink := unzip_ok 2211 ELSE 2212 unshrink := unzip_WriteErr; 2213END; 2214(***************************************************************************) 2215{***************************************************************************} 2216FUNCTION GetSupportedMethods : longint; 2217BEGIN 2218 GetSupportedMethods := 1 + ( 1 SHL 1 ) + ( 1 SHL 6 ) + ( 1 SHL 8 ); 2219 {stored, shrunk, imploded and deflated} 2220END; 2221 2222{******************** main low level function: unzipfile ********************} 2223{written and not copyrighted by Christian Ghisler} 2224FUNCTION unzipfile ( in_name : pchar;out_name : pchar;offset : longint; 2225 hFileAction : word;cm_index : integer ) : integer; 2226VAR err : integer; 2227 header : plocalheader; 2228 buf : ARRAY [ 0..tfSize+1 ] of char; 2229{$ifndef unix} 2230 buf0 : ARRAY [ 0..3 ] of char; 2231{$endif} 2232 storefilemode, 2233 timedate : longint; 2234 originalcrc : cardinal; {crc from zip-header} 2235 ziptype, aResult : integer; 2236 p, p1 : pchar; 2237 isadir : boolean; 2238 oldcurdir : string [ 80 ]; 2239 2240BEGIN 2241 getmem ( slide, wsize ); 2242 fillchar ( slide [ 0 ], wsize, #0 ); 2243 assign ( infile, strpas(in_name) ); 2244 storefilemode := filemode; 2245 filemode := 0; 2246 {$push} {$I-} 2247 reset ( infile, 1 ); 2248 {$pop} 2249 filemode := storefilemode; 2250 IF ioresult <> 0 THEN BEGIN 2251 freemem ( slide, wsize ); 2252 unzipfile := unzip_ReadErr; 2253 inuse := FALSE; 2254 exit 2255 END; 2256 {$push} {$I-} 2257 seek ( infile, offset ); {seek to header position} 2258 {$pop} 2259 IF ioresult <> 0 THEN BEGIN 2260 freemem ( slide, wsize ); 2261 close ( infile ); 2262 unzipfile := unzip_ZipFileErr; 2263 inuse := FALSE; 2264 exit 2265 END; 2266 header := @inbuf; 2267 {$push} {$I-} 2268 blockread ( infile, header^, sizeof ( header^ ) ); {read in local header} 2269 {$pop} 2270 IF ioresult <> 0 THEN BEGIN 2271 freemem ( slide, wsize ); 2272 close ( infile ); 2273 unzipfile := unzip_ZipFileErr; 2274 inuse := FALSE; 2275 exit 2276 END; 2277 2278 IF strlcomp ( header^.signature, 'PK'#3#4, 4 ) <> 0 THEN BEGIN 2279 freemem ( slide, wsize ); 2280 close ( infile ); 2281 unzipfile := unzip_ZipFileErr; 2282 inuse := FALSE; 2283 exit 2284 END; 2285 2286 {calculate offset of data} 2287 offset := offset + header^.filename_len + header^.extra_field_len + sizeof ( tlocalheader ); 2288 timedate := header^.file_timedate; 2289 IF ( hufttype AND 8 ) = 0 THEN BEGIN {Size and crc at the beginning} 2290 compsize := header^.compress_size; 2291 uncompsize := header^.uncompress_size; 2292 originalcrc := header^.crc_32; 2293 END ELSE BEGIN 2294 compsize := maxlongint; {Don't get a sudden zipeof!} 2295 uncompsize := maxlongint; 2296 originalcrc := 0 2297 END; 2298 ziptype := header^.zip_type; {0=stored, 6=imploded, 8=deflated} 2299 IF ( 1 SHL ziptype ) AND GetSupportedMethods = 0 THEN BEGIN {Not Supported!!!} 2300 freemem ( slide, wsize ); 2301 close ( infile ); 2302 unzipfile := unzip_NotSupported; 2303 inuse := FALSE; 2304 exit; 2305 END; 2306 hufttype := header^.bit_flag; 2307 IF ( hufttype AND 1 ) <> 0 THEN BEGIN {encrypted} 2308 freemem ( slide, wsize ); 2309 close ( infile ); 2310 unzipfile := unzip_Encrypted; 2311 inuse := FALSE; 2312 exit; 2313 END; 2314 2315 reachedsize := 0; 2316 seek ( infile, offset ); 2317 2318 assign ( outfile, strpas(out_name) ); 2319 {$push} {$I-} 2320 rewrite ( outfile, 1 ); 2321 {$pop} 2322 err := ioresult; 2323 {create directories not yet in path} 2324 isadir := ( out_name [ strlen ( out_name ) -1 ] in ['/','\'] ); 2325 IF ( err = 3 ) OR isadir THEN BEGIN {path not found} 2326 {$push} {$I-} 2327 getdir ( 0, oldcurdir ); 2328 {$pop} 2329 err := ioresult; 2330 strcopy ( buf, out_name ); 2331 p1 := strrscan ( buf, DirSep ); 2332 IF p1 <> NIL THEN inc ( p1 ); {pointer to filename} 2333 p := strtok ( buf, DirSep ); 2334{$ifndef unix} 2335 IF ( p <> NIL ) AND ( p [ 1 ] = ':' ) THEN BEGIN 2336 strcopy ( buf0, 'c:\' ); {set drive} 2337 buf0 [ 0 ] := p [ 0 ]; 2338 {$push} {$I-} 2339 chdir ( buf0 ); 2340 {$pop} 2341 err := ioresult; 2342 p := strtok ( NIL, '\' ); 2343 END; 2344{$endif} 2345 WHILE ( p <> NIL ) AND ( p <> p1 ) DO BEGIN 2346 {$push} {$I-} 2347 chdir ( strpas ( p ) ); 2348 {$pop} 2349 err := ioresult; 2350 IF err <> 0 THEN BEGIN 2351 {$push} {$I-} 2352 mkdir ( strpas ( p ) ); 2353 {$pop} 2354 err := ioresult; 2355 IF err = 0 THEN 2356 {$push} {$I-} 2357 chdir ( strpas ( p ) ); 2358 {$pop} 2359 err := ioresult; 2360 END; 2361 IF err = 0 THEN 2362 p := strtok ( NIL, DirSep ) 2363 ELSE 2364 p := NIL; 2365 END; 2366 {$push} {$I-} 2367 chdir ( oldcurdir ); 2368 {$pop} 2369 err := ioresult; 2370 IF isadir THEN BEGIN 2371 freemem ( slide, wsize ); 2372 unzipfile := unzip_Ok; {A directory -> ok} 2373 close ( infile ); 2374 inuse := FALSE; 2375 exit; 2376 END; 2377 {$push} {$I-} 2378 rewrite ( outfile, 1 ); 2379 {$pop} 2380 err := ioresult; 2381 END; 2382 2383 IF err <> 0 THEN BEGIN 2384 freemem ( slide, wsize ); 2385 unzipfile := unzip_WriteErr; 2386 close ( infile ); 2387 inuse := FALSE; 2388 exit 2389 END; 2390 2391 totalabort := FALSE; 2392 zipeof := FALSE; 2393 2394 crc32val := $FFFFFFFF; 2395 2396 {Unzip correct type} 2397 CASE ziptype of 2398 0 : aResult := copystored; 2399 1 : aResult := unshrink; 2400 6 : aResult := explode; 2401 8 : aResult := inflate; 2402 ELSE 2403 aResult := unzip_NotSupported; 2404 END; 2405 unzipfile := aResult; 2406 2407 IF ( aResult = unzip_ok ) AND ( ( hufttype AND 8 ) <> 0 ) THEN BEGIN {CRC at the end} 2408 dumpbits ( k AND 7 ); 2409 needbits ( 16 ); 2410 originalcrc := b AND $FFFF; 2411 dumpbits ( 16 ); 2412 needbits ( 16 ); 2413 originalcrc := originalcrc OR LongWord(( b AND $FFFF ) SHL 16); 2414 dumpbits ( 16 ); 2415 2416 IF originalcrc = $08074b50 THEN BEGIN 2417 { skiping possible $08074b50 data descriptor signature. see PKWARE APPNOTE.txt } 2418 needbits ( 16 ); 2419 originalcrc := b AND $FFFF; 2420 dumpbits ( 16 ); 2421 needbits ( 16 ); 2422 originalcrc := originalcrc OR LongWord(( b AND $FFFF ) SHL 16); 2423 dumpbits ( 16 ); 2424 END; 2425 END; 2426 2427 close ( infile ); 2428 close ( outfile ); 2429 crc32val := NOT ( crc32val ); {one's complement} 2430 IF aResult <> 0 THEN BEGIN 2431 erase ( outfile ); 2432 END ELSE IF ( originalcrc <> crc32val ) THEN BEGIN 2433 unzipfile := unzip_CRCErr; 2434 erase ( outfile ); 2435 END ELSE BEGIN 2436 filemode := 2; 2437 reset ( outfile ); 2438 filemode := storefilemode; 2439 setftime ( outfile, timedate ); {set zipped time and date of oufile} 2440 close ( outfile ); 2441 END; 2442 freemem ( slide, wsize ); 2443 inuse := FALSE; 2444END; 2445{***************************************************************************} 2446{***************************************************************************} 2447{***************************************************************************} 2448{ other functions; zipread.pas } 2449CONST mainheader : pchar = 'PK'#5#6; 2450 maxbufsize = 64000; {Can be as low as 500 Bytes; however, } 2451 {this would lead to extensive disk reading!} 2452 {If one entry (including Extra field) is bigger} 2453 {than maxbufsize, you cannot read it :-( } 2454 2455TYPE 2456 pheader = ^theader; 2457 pmainheader = ^tmainheader; 2458 tmainheader = PACKED RECORD 2459 signature : ARRAY [ 0..3 ] of char; {'PK'#5#6} 2460 thisdisk, 2461 centralstartdisk, 2462 entries_this_disk, 2463 entries_central_dir : word; 2464 headsize, 2465 headstart : longint; 2466 comment_len : longint; 2467 unknown : word; 2468 END; 2469 theader = PACKED RECORD 2470 signature : ARRAY [ 0..3 ] of char; {'PK'#1#2} 2471 OSversion, {Operating system version} 2472 OSmadeby : byte; {MSDOS (FAT): 0} 2473 extract_ver, 2474 bit_flag, 2475 zip_type : word; 2476 file_timedate : longint; 2477 crc_32, 2478 compress_size, 2479 uncompress_size : longint; 2480 filename_len, 2481 extra_field_len, 2482 file_comment_len, 2483 disk_number_start, 2484 internal_attr : word; 2485 external_attr : ARRAY [ 0..3 ] of byte; 2486 offset_local_header : longint; 2487 END; 2488 2489{*********** Fill out tZipRec structure with next entry *************} 2490 2491FUNCTION filloutRec ( VAR zprec : tZipRec ) : integer; 2492VAR p : pchar; 2493 incr : longint; 2494 header : pheader; 2495 offs : word; 2496 old : char; 2497 f : file; 2498 extra, err : nword; 2499 2500BEGIN 2501 WITH zprec DO BEGIN 2502 header := pheader ( @buf^ [ localstart ] ); 2503 IF ( bufsize = maxbufsize ) THEN BEGIN {Caution: header bigger than 64k!} 2504 extra := sizeof ( file ); 2505 IF ( ( localstart + sizeof ( theader ) ) > bufsize ) OR 2506 ( localstart + header^.filename_len + header^.extra_field_len + 2507 header^.file_comment_len + sizeof ( theader ) > bufsize ) 2508 THEN BEGIN {Read over end of header} 2509 move ( buf^ [ bufsize + 1 ], f, extra ); {Restore file} 2510 move ( buf^ [ localstart ], buf^ [ 0 ], bufsize -localstart ); {Move end to beginning in buffer} 2511 {$push} {$I-} 2512 blockread ( f, buf^ [ bufsize -localstart ], localstart, err ); {Read in full central dir, up to maxbufsize Bytes} 2513 {$pop} 2514 IF ( ioresult <> 0 ) OR ( err + localstart < sizeof ( theader ) ) THEN BEGIN 2515 filloutrec := unzip_nomoreitems; 2516 exit 2517 END; 2518 move ( f, buf^ [ bufsize + 1 ], extra ); {Save changed file info!} 2519 localstart := 0; 2520 header := pheader ( @buf^ [ localstart ] ); 2521 END; 2522 END; 2523 IF ( localstart + 4 <= bufsize ) AND {Here is the ONLY correct finish!} 2524 ( strlcomp ( header^.signature, mainheader, 4 ) = 0 ) THEN BEGIN {Main header} 2525 filloutrec := unzip_nomoreitems; 2526 exit 2527 END; 2528 IF ( localstart + sizeof ( header ) > bufsize ) OR 2529 ( localstart + header^.filename_len + header^.extra_field_len + 2530 header^.file_comment_len + sizeof ( theader ) > bufsize ) OR 2531 ( strlcomp ( header^.signature, 'PK'#1#2, 4 ) <> 0 ) THEN BEGIN 2532 filloutrec := unzip_nomoreitems; 2533 exit 2534 END; 2535 size := header^.uncompress_size; 2536 compressSize := header^.compress_size; 2537 IF header^.osmadeby = 0 THEN 2538 attr := header^.external_attr [ 0 ] 2539 ELSE 2540 attr := 0; 2541 time := header^.file_timedate; 2542 headeroffset := header^.offset_local_header; {Other header size} 2543 Packmethod := header^.zip_type; 2544 offs := localstart + header^.filename_len + sizeof ( header^ ); 2545 old := buf^ [ offs ]; 2546 buf^ [ offs ] := #0; {Repair signature of next block!} 2547 strlcopy ( filename, pchar ( @buf^ [ localstart + sizeof ( header^ ) ] ), sizeof ( filename ) -1 ); 2548 buf^ [ offs ] := old; 2549{$ifndef unix} 2550 REPEAT {Convert slash to backslash!} 2551 p := strscan ( filename, '/' ); 2552 IF p <> NIL THEN p [ 0 ] := '\'; 2553 UNTIL p = NIL; 2554{$else} 2555 REPEAT {Convert backslash to slash!} 2556 p := strscan ( filename, '\' ); 2557 IF p <> NIL THEN p [ 0 ] := '/'; 2558 UNTIL p = NIL; 2559{$endif} 2560 incr := header^.filename_len + header^.extra_field_len + 2561 header^.file_comment_len + sizeof ( header^ ); 2562 IF incr <= 0 THEN BEGIN 2563 filloutrec := unzip_InternalError; 2564 exit 2565 END; 2566 localstart := localstart + incr; 2567 filloutrec := unzip_ok; 2568 END; 2569END; 2570 2571{**************** Get first entry from ZIP file ********************} 2572FUNCTION GetFirstInZip ( zipfilename : pchar;VAR zprec : tZipRec ) : integer; 2573VAR bufstart, headerstart, start : longint; 2574 err, i : integer; 2575 mainh : pmainheader; 2576 f : file; 2577 extra : word; {Extra bytes for saving File!} 2578 2579BEGIN 2580 WITH zprec DO BEGIN 2581 assign ( f, strpas(zipfilename)); 2582 filemode := 0; {Others may read or write}; 2583 {$push} {$I-} 2584 reset ( f, 1 ); 2585 {$pop} 2586 IF ioresult <> 0 THEN BEGIN 2587 GetFirstInZip := unzip_FileError; 2588 exit 2589 END; 2590 size := filesize ( f ); 2591 IF size = 0 THEN BEGIN 2592 GetFirstInZip := unzip_FileError; 2593 {$push} {$I-} 2594 close ( f ); 2595 {$pop} 2596 exit 2597 END; 2598 bufsize := 4096; {in 4k-blocks} 2599 IF size > bufsize THEN BEGIN 2600 bufstart := size -bufsize; 2601 END ELSE BEGIN 2602 bufstart := 0; 2603 bufsize := size; 2604 END; 2605 getmem ( buf, bufsize + 1 ); {#0 at the end of filemname} 2606 2607 {Search from back of file to central directory start} 2608 start := -1; {Nothing found} 2609 REPEAT 2610 {$push} {$I-} 2611 seek ( f, bufstart ); 2612 {$pop} 2613 IF ioresult <> 0 THEN BEGIN 2614 GetFirstInZip := unzip_FileError; 2615 freeMem ( buf, bufsize + 1 ); 2616 buf := NIL; 2617 {$push} {$I-} 2618 close ( f ); 2619 {$pop} 2620 exit 2621 END; 2622 {$push} {$I-} 2623 blockread ( f, buf^, bufsize, err ); 2624 {$pop} 2625 IF ( ioresult <> 0 ) OR ( err <> bufsize ) THEN BEGIN 2626 GetFirstInZip := unzip_FileError; 2627 freeMem ( buf, bufsize + 1 ); 2628 buf := NIL; 2629 {$push} {$I-} 2630 close ( f ); 2631 {$pop} 2632 exit 2633 END; 2634 2635 IF bufstart = 0 THEN start := maxlongint;{Break} 2636 2637 FOR i := bufsize -22 DOWNTO 0 DO BEGIN {Search buffer backwards} 2638 IF ( buf^ [ i ] = 'P' ) AND ( buf^ [ i + 1 ] = 'K' ) AND ( buf^ [ i + 2 ] = #5 ) AND ( buf^ [ i + 3 ] = #6 ) 2639 THEN BEGIN {Header found!!!} 2640 start := bufstart + i; 2641 break; 2642 END; 2643 END; 2644 2645 IF start = -1 THEN BEGIN {Nothing found yet} 2646 dec ( bufstart, bufsize -22 ); {Full header in buffer!} 2647 IF bufstart < 0 THEN bufstart := 0; 2648 END; 2649 UNTIL start >= 0; 2650 IF ( start = maxlongint ) THEN BEGIN {Nothing found} 2651 GetFirstInZip := unzip_FileError; 2652 freeMem ( buf, bufsize + 1 ); 2653 buf := NIL; 2654 {$push} {$I-} 2655 close ( f ); 2656 {$pop} 2657 exit 2658 END; 2659 mainh := pmainheader ( @buf^ [ start -bufstart ] ); 2660 headerstart := mainh^.headstart; 2661 localstart := 0; 2662 freeMem ( buf, bufsize + 1 ); 2663 IF ( localstart + sizeof ( theader ) > start ) THEN BEGIN 2664 buf := NIL; 2665 GetFirstInZip := unzip_InternalError; 2666 {$push} {$I-} 2667 close ( f ); 2668 {$pop} 2669 exit 2670 END; 2671 bufstart := headerstart; 2672 start := start -headerstart + 4; {size for central dir,Including main header signature} 2673 IF start >= maxbufsize THEN BEGIN 2674 bufsize := maxbufsize; {Max buffer size, limit of around 1000 items!} 2675 extra := sizeof ( file ) {Save file information for later reading!} 2676 END ELSE BEGIN 2677 bufsize := start; 2678 extra := 0 2679 END; 2680 getmem ( buf, bufsize + 1 + extra ); 2681 {$push} {$I-} 2682 seek ( f, bufstart ); 2683 {$pop} 2684 IF ioresult <> 0 THEN BEGIN 2685 GetFirstInZip := unzip_FileError; 2686 freeMem ( buf, bufsize + 1 + extra ); 2687 buf := NIL; 2688 {$push} {$I-} 2689 close ( f ); 2690 {$pop} 2691 exit 2692 END; 2693 {$push} {$I-} 2694 blockread ( f, buf^, bufsize, err ); {Read in full central dir, up to maxbufsize Bytes} 2695 {$pop} 2696 IF ioresult <> 0 THEN BEGIN 2697 GetFirstInZip := unzip_FileError; 2698 freeMem ( buf, bufsize + 1 + extra ); 2699 buf := NIL; 2700 {$push} {$I-} 2701 close ( f ); 2702 {$pop} 2703 exit 2704 END; 2705 IF extra = 0 THEN 2706 {$push} {$I-} close ( f ) {$pop} 2707 ELSE move ( f, buf^ [ bufsize + 1 ], extra ); {Save file info!} 2708 err := filloutRec ( zprec ); 2709 IF err <> unzip_ok THEN BEGIN 2710 CloseZipFile ( zprec ); 2711 GetFirstInZip := err; 2712 exit 2713 END; 2714 GetFirstInZip := err; 2715 END; 2716END; 2717 2718{**************** Get next entry from ZIP file ********************} 2719FUNCTION GetNextInZip ( VAR Zprec : tZiprec ) : integer; 2720VAR err : integer; 2721BEGIN 2722 WITH zprec DO BEGIN 2723 IF ( buf <> NIL ) THEN BEGIN {Main Header at the end} 2724 err := filloutRec ( zprec ); 2725 IF err <> unzip_ok THEN BEGIN 2726 CloseZipFile ( ZPRec ); 2727 END; 2728 GetNextInZip := err; 2729 END ELSE GetNextInZip := unzip_NoMoreItems; 2730 END 2731END; 2732 2733{**************** VERY simple test for zip file ********************} 2734FUNCTION isZip ( filename : pchar ) : boolean; 2735VAR 2736 myname : tdirtype; 2737 l, err : integer; 2738 f : file; 2739 buf : ARRAY [ 0..4 ] of char; 2740 oldcurdir : string{$ifndef BIT32} [ 80 ]{$endif}; 2741 2742BEGIN 2743 filemode := 0; 2744 {$push} {$I-} 2745 getdir ( 0, oldcurdir ); 2746 {$pop} 2747 err := ioresult; 2748 isZip := FALSE; 2749 IF ( strscan ( filename, '.' ) <> NIL ) 2750 AND ( strpos ( filename, '.exe' ) = NIL ) THEN BEGIN 2751 strcopy ( myname, filename ); 2752 l := strlen ( myname ); 2753 IF myname [ l -1 ] = DirSep THEN myname [ l -1 ] := #0; 2754 {$push} {$I-} 2755 chdir ( Strpas ( myname ) ); 2756 {$pop} 2757 IF ioresult <> 0 THEN BEGIN 2758 assign ( f, Strpas ( myname ) ); 2759 filemode := 0; {Others may read or write}; 2760 {$push} {$I-} 2761 reset ( f, 1 ); 2762 {$pop} 2763 IF ioresult = 0 THEN BEGIN 2764 {$push} {$I-} 2765 blockread ( f, buf, 4, err ); 2766 {$pop} 2767 IF ( ioresult = 0 ) THEN BEGIN 2768 IF ( err = 4 ) AND ( buf [ 0 ] = 'P' ) AND ( buf [ 1 ] = 'K' ) 2769 AND ( buf [ 2 ] = #3 ) AND ( buf [ 3 ] = #4 ) THEN isZip := TRUE 2770 END; 2771 {$push} {$I-} 2772 close ( f ); 2773 {$pop} 2774 err := ioresult; {only clears ioresult variable} 2775 END; 2776 END; 2777 END; 2778 {$push} {$I-} 2779 chdir ( oldcurdir ); 2780 {$pop} 2781 err := ioresult; 2782END; 2783 2784{**************** free ZIP buffers ********************} 2785PROCEDURE CloseZipFile ( VAR Zprec : tZiprec ); {Only free buffer, file only open in Getfirstinzip} 2786VAR 2787 f : file; 2788 extra : word; 2789BEGIN 2790 WITH zprec DO BEGIN 2791 IF buf <> NIL THEN BEGIN 2792 IF ( bufsize = maxbufsize ) THEN BEGIN {Caution: header bigger than 64k!} 2793 extra := sizeof ( file ); 2794 move ( buf^ [ bufsize + 1 ], f, extra ); {Restore file} 2795 {$push} {$I-} 2796 close ( f ); 2797 {$pop} 2798 IF ioresult <> 0 THEN ; 2799 END ELSE extra := 0; 2800 freemem ( buf, bufsize + 1 + extra ); 2801 buf := NIL 2802 END; 2803 END 2804END; 2805{***************************************************************************} 2806{***************************************************************************} 2807{********** routines by the African Chief **********************************} 2808{***************************************************************************} 2809{***************************************************************************} 2810{$ifndef Delphi} 2811FUNCTION FileExists ( CONST fname : string ) : boolean; {simple fileexist function} 2812VAR 2813f : file; 2814i : byte; 2815BEGIN 2816 i := filemode; 2817 filemode := 0; 2818 assign ( f, fname ); 2819 {$push} {$I-} 2820 Reset ( f, 1 ); 2821 filemode := i; 2822 FileExists := ioresult = 0; 2823 Close ( f ); IF ioresult <> 0 THEN; 2824 {$pop} 2825END; 2826{$endif Delphi} 2827 2828PROCEDURE DummyReport ( Retcode : longint;Rec : pReportRec ); 2829{dummy report procedure} 2830BEGIN 2831END; 2832 2833FUNCTION DummyQuestion( Rec : pReportRec ) : Boolean; 2834{dummy question procedure} 2835begin 2836 DummyQuestion:=true; 2837end; 2838 2839FUNCTION Matches ( s : String;CONST main : string ) : Boolean; 2840{rudimentary matching function; 2841 accepts only '', '*.*', 'XXX.*' or '*.XXX' 2842} 2843FUNCTION extensiononly ( CONST s : string ) : string;{return just the extension} 2844VAR i : integer; 2845BEGIN 2846 extensiononly := ''; 2847 i := pos ( '.', s ); 2848 IF i = 0 THEN exit; 2849 extensiononly := copy ( s, succ ( i ), length ( s ) ); 2850END; 2851 2852FUNCTION nameonly ( CONST s : string ) : string;{return just the name} 2853VAR i : integer; 2854BEGIN 2855 nameonly := s; 2856 i := pos ( '.', s ); 2857 IF i = 0 THEN exit; 2858 nameonly := copy ( s, 1, pred ( i ) ); 2859END; 2860{!!!!!} 2861VAR 2862b : boolean; 2863i : integer; 2864BEGIN 2865 Matches := TRUE; 2866 IF ( s = '' ) OR ( s = AllFiles ) THEN exit; {'' or '*.*' = all files match} 2867 s := upper ( s ); 2868 b := copy ( s, 1, 2 ) = '*.'; {e.g., *.PAS} 2869 IF b THEN BEGIN 2870 delete ( s, 1, 2 ); 2871 Matches := s = extensiononly ( upper ( main ) ); 2872 END ELSE BEGIN 2873 i := length ( s ); 2874 b := s [ i ] = '*'; {e.g. TEST.*} 2875 IF b THEN BEGIN 2876 IF s [ pred ( i ) ] = '.' THEN delete ( s, pred ( i ), 2 ); 2877 i := length ( s ); 2878 IF s [ i ] in [ '*', '?' ] THEN dec ( i );{e.g. TEST*.*} 2879 Matches := Copy ( s, 1, i ) = Copy ( nameonly ( upper ( main ) ), 1, i ); 2880 END ELSE Matches := s = upper ( main ); 2881 END; 2882END; { Matches } 2883{****************************************************} 2884FUNCTION FileUnzip ( SourceZipFile, TargetDirectory, FileSpecs : pChar; 2885 Report : UnzipReportProc;Question : UnzipQuestionProc ) : integer; 2886VAR 2887 rc : integer; 2888 r : tziprec; 2889 buf, 2890 thename, 2891 target : ARRAY [ 0..tFSize ] of char; 2892 Count : integer; 2893 rSize, cSize : longint; 2894 s : string [ 255 ]; 2895 2896BEGIN 2897{$IFDEF FPC} 2898 IF not assigned(Report) THEN 2899 Report := @DummyReport; 2900 IF not assigned(Question) THEN 2901 Question := @DummyQuestion; 2902{$ELSE} 2903 IF @Report = nil THEN 2904 Report := DummyReport; 2905 IF @Question = nil THEN 2906 Question := DummyQuestion; 2907{$ENDIF} 2908 2909 Count := 0; 2910 rSize := 0; 2911 cSize := 0; 2912 FileUnzip := unzip_MissingParameter; 2913 IF ( StrPas ( SourceZipFile ) = '' ) OR ( StrPas ( TargetDirectory ) = '' ) THEN Exit; 2914 2915 Strcopy ( thename, SourceZipFile ); 2916 Strcopy ( target, TargetDirectory ); 2917 IF ( target [ 0 ] <> #0 ) AND ( target [ strlen ( target ) -1 ] <> DirSep ) 2918 THEN strcat ( target, DirSep ); 2919 FileUnzip := unzip_NotZipFile; 2920 IF NOT iszip ( thename ) THEN exit; 2921 2922 FillChar ( ZipRec, Sizeof ( ZipRec ), #0 ); 2923 2924 WITH ZipRec DO BEGIN 2925 IsaDir := FALSE; 2926 strcopy ( FileName, thename ); 2927 Size := UnZipSize ( SourceZipFile, CompressSize ); 2928 IF Size = 0 THEN ratio := 0 ELSE 2929 Ratio := 100 -Round ( ( CompressSize / Size ) * 100 ); 2930 Status := unzip_starting; 2931 Report ( Status, @ZipRec ); 2932 END; {start of ZIP file} 2933 2934 ZipReport := Report; 2935 2936 rc := getfirstinzip ( thename, r ); 2937 WHILE ( rc = unzip_ok ) 2938 DO BEGIN 2939 IF ( Matches ( StrPas ( FileSpecs ), Strpas ( R.FileName ) ) ) 2940 THEN BEGIN 2941 Inc ( rSize, r.Size ); 2942 Inc ( cSize, r.CompressSize ); 2943 2944 strcopy ( buf, target ); 2945 IF NoRecurseDirs { no recursion } 2946 THEN BEGIN 2947 s := StripPath ( Strpas ( r.filename ) ) + #0; 2948 Strcat ( buf, @s [ 1 ] ); 2949 END ELSE strcat ( buf, r.filename ); 2950 2951 2952 WITH ZipRec DO BEGIN { report start of file } 2953 s := StrPas ( Buf ); 2954 IsaDir := s [ length ( s ) ] = DirSep; 2955 Time := r.Time; 2956 Size := r.Size; 2957 CompressSize := r.CompressSize; 2958 strcopy ( FileName, buf ); 2959 PackMethod := r.PackMethod; 2960 Attr := r.Attr; 2961 IF Size = 0 THEN ratio := 0 ELSE 2962 Ratio := 100 -Round ( ( CompressSize /Size ) * 100 ); 2963 Status := file_starting; 2964 IF ( IsaDir ) AND ( NoRecurseDirs ) 2965 THEN {} ELSE 2966 ZipReport ( Status, @ZipRec ); 2967 END; { start of file } 2968 2969 IF ( FileExists ( StrPas ( buf ) ) ) 2970 AND ( Question ( @ZipRec ) = FALSE ) 2971 THEN BEGIN 2972 rc := unzip_ok; { we are okay } 2973 WITH ZipRec DO BEGIN 2974 Status := file_unzipping; 2975 PackMethod := 9; { skipped } 2976 ZipReport ( Size, @ZipRec ); { report uncompressed size } 2977 END; 2978 END ELSE BEGIN 2979 rc := unzipfile ( thename, buf, r.headeroffset, 0, 2980 27 ); {Escape interrupts} 2981 END; 2982 2983 IF rc = unzip_ok 2984 THEN BEGIN 2985 Inc ( Count ); 2986 WITH ZipRec DO BEGIN { report end of file } 2987 Status := file_completed; 2988 IF ( IsaDir ) AND ( NoRecurseDirs ) 2989 THEN {} ELSE 2990 ZipReport ( Status, @ZipRec ); 2991 END; { end of file } 2992 END ELSE BEGIN 2993 ZipRec.Status := file_failure; {error} 2994 CASE rc of 2995 unzip_CRCErr, 2996 unzip_WriteErr, 2997 unzip_Encrypted, 2998 unzip_NotSupported : ZipReport ( rc, @ZipRec ); 2999 3000 unzip_ReadErr, unzip_Userabort, 3001 unzip_FileError, unzip_InternalError, 3002 unzip_InUse, unzip_ZipFileErr : 3003 BEGIN 3004 ZipRec.Status := unzip_SeriousError; 3005 FileUnzip := unzip_SeriousError; {Serious error, force abort} 3006 ZipReport ( unzip_SeriousError, @ZipRec ); 3007 closezipfile ( r ); 3008 ZipReport := NIL; 3009 ZipQuestion := NIL; 3010 exit; 3011 END; 3012 END; {case rc} 3013 Continue; 3014 {rc:=getnextinzip(r);} 3015 END; {else} 3016 END; { if Matches } 3017 rc := getnextinzip ( r ); 3018 END; {while } 3019 3020 closezipfile ( r ); {Free memory used for central directory info} 3021 3022 WITH ZipRec DO BEGIN { report end of ZIP file } 3023 Time := -1; 3024 Attr := -1; 3025 PackMethod := 0; 3026 Size := rSize; 3027 CompressSize := cSize; 3028 strcopy ( FileName, thename ); 3029 IF Size = 0 THEN ratio := 0 ELSE 3030 Ratio := 100 -Round ( ( CompressSize /Size ) * 100 ); 3031 Status := unzip_completed; 3032 ZipReport ( Status, @ZipRec ); 3033 END; { end of ZIP file } 3034 3035 ZipReport := NIL; 3036 ZipQuestion := NIL; 3037 FileUnzip := Count; 3038END; { FileUnzip } 3039{***************************************************************************} 3040FUNCTION FileUnzipEx ( SourceZipFile, TargetDirectory, FileSpecs : pChar ) : integer; 3041BEGIN 3042 FileUnzipEx := 3043 FileUnzip ( SourceZipFile, TargetDirectory, FileSpecs, ZipReport, ZipQuestion ); 3044END; { FileUnzipEx } 3045{***************************************************************************} 3046FUNCTION Viewzip ( SourceZipFile, FileSpecs : pChar; Report : UnzipReportProc ) : integer; 3047VAR 3048 rc : integer; 3049 r : tziprec; 3050 thename : ARRAY [ 0..tFSize ] of char; 3051 Count : integer; 3052 rSize, cSize : longint; 3053 3054BEGIN 3055 Count := 0; 3056 rSize := 0; 3057 cSize := 0; 3058 Viewzip := unzip_MissingParameter; 3059{$IFDEF FPC} 3060 IF ( StrPas ( SourceZipFile ) = '' ) or 3061 not assigned(Report) THEN 3062 exit; 3063{$ELSE} 3064 IF ( StrPas ( SourceZipFile ) = '' ) OR ( @Report = NIL ) THEN Exit; 3065{$ENDIF} 3066 3067 Strcopy ( thename, SourceZipFile ); 3068 ViewZip := unzip_NotZipFile; 3069 IF NOT iszip ( thename ) THEN exit; 3070 FillChar ( ZipRec, Sizeof ( ZipRec ), #0 ); 3071 3072 rc := getfirstinzip ( thename, r ); 3073 WHILE ( rc = unzip_ok ) 3074 DO BEGIN 3075 IF ( Matches ( StrPas ( FileSpecs ), Strpas ( R.FileName ) ) ) THEN BEGIN 3076 Inc ( rSize, r.Size ); 3077 Inc ( cSize, r.CompressSize ); 3078 WITH ZipRec DO BEGIN 3079 Time := r.Time; 3080 Size := r.Size; 3081 CompressSize := r.CompressSize; 3082 strcopy ( FileName, r.Filename ); 3083 PackMethod := r.PackMethod; 3084 Attr := r.Attr; 3085 IF Size = 0 THEN ratio := 0 ELSE 3086 Ratio := 100 -Round ( ( CompressSize /Size ) * 100 ); 3087 END; 3088 Inc ( Count ); 3089 Report ( rc, @ZipRec ); 3090 END; {matches} 3091 rc := getnextinzip ( r ); 3092 END; {while } 3093 closezipfile ( r ); 3094 3095 WITH ZipRec DO BEGIN 3096 Time := -1; 3097 Attr := -1; 3098 PackMethod := 0; 3099 Size := rSize; 3100 CompressSize := cSize; 3101 strcopy ( FileName, thename ); 3102 IF Size = 0 THEN ratio := 0 ELSE 3103 Ratio := 100 -Round ( ( CompressSize /Size ) * 100 ); 3104 END; 3105 Report ( Count, @ZipRec ); 3106 ViewZip := Count; 3107END; { ViewZip } 3108{***************************************************************************} 3109FUNCTION UnZipSize ( SourceZipFile : pChar;VAR Compressed : Longint ) : longint; 3110VAR 3111 rc : integer; 3112 r : tziprec; 3113 thename : ARRAY [ 0..tFSize ] of char; 3114 Count : longint; 3115 f : file; 3116 3117BEGIN 3118 Compressed := 0; 3119 UnZipSize := 0; 3120 IF ( StrPas ( SourceZipFile ) = '' ) THEN Exit; 3121 System.Assign ( f, StrPas ( SourceZipFile ) ); 3122 count := filemode; 3123 filemode := 0; 3124 {$push} {$I-} 3125 Reset ( f, 1 ); 3126 filemode := count; 3127 IF ioresult <> 0 THEN exit; 3128 Count := filesize ( f ); 3129 close ( f ); 3130 UnZipSize := count; 3131 Compressed := count; 3132 Strcopy ( thename, SourceZipFile ); 3133 IF NOT iszip ( thename ) THEN exit; 3134 Count := 0; 3135 Compressed := 0; 3136 rc := getfirstinzip ( thename, r ); 3137 WHILE ( rc = unzip_ok ) 3138 DO BEGIN 3139 Inc ( Count, r.Size ); 3140 Inc ( Compressed, r.CompressSize ); 3141 rc := getnextinzip ( r ); 3142 END; {while } 3143 closezipfile ( r ); 3144 UnZipSize := Count; 3145END; { UnZipSize } 3146{***************************************************************************} 3147FUNCTION SetUnZipReportProc ( aProc : UnzipReportProc ) : Pointer; 3148BEGIN 3149{$IFDEF FPC} 3150 SetUnZipReportProc := ZipReport; {save and return original} 3151{$ELSE} 3152 SetUnZipReportProc := @ZipReport; {save and return original} 3153{$ENDIF} 3154 ZipReport := aProc; 3155END; { SetUnZipReportProc } 3156{***************************************************************************} 3157FUNCTION SetUnZipQuestionProc ( aProc : UnzipQuestionProc ) : Pointer; 3158BEGIN 3159{$IFDEF FPC} 3160 SetUnZipQuestionProc := ZipQuestion; {save and return original} 3161{$ELSE} 3162 SetUnZipQuestionProc := @ZipQuestion; {save and return original} 3163{$ENDIF} 3164 ZipQuestion := aProc; 3165END; { SetUnZipQuestionProc } 3166{***************************************************************************} 3167FUNCTION SetNoRecurseDirs ( DontRecurse : Boolean ) : Boolean; 3168BEGIN 3169 SetNoRecurseDirs := NoRecurseDirs; 3170 NoRecurseDirs := DontRecurse; 3171END; { SetNoRecurseDirs } 3172{***************************************************************************} 3173{***************************************************************************} 3174PROCEDURE ChfUnzip_Init; 3175BEGIN 3176 slide := NIL; {unused} 3177 if inuse then; { to remove warning } 3178 SetUnZipReportProc ( NIL ); 3179 SetUnZipQuestionProc ( NIL ); 3180 SetNoRecurseDirs ( FALSE ); 3181END; 3182{***************************************************************************} 3183{***************************************************************************} 3184{***************************************************************************} 3185BEGIN 3186 ChfUnzip_Init; 3187END. 3188