eric
/
Renegade-1.19
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
Renegade-1.19/DEZIP.PAS

1193 lines
38 KiB
Plaintext
Raw Normal View History

02-04
2013-02-04 15:56:58 -08:00
Program DeZip;
{ DeZip v1.5 (C) Copyright 1989 by R. P. Byrne }
{ }
{ This is a "bare-bones" program to extract files from ZIP archives. }
{ By "bare-bones", I mean that there is no facility included to do anything }
{ but extraction (ie. no echo to console, no send to printer, etc.). }
{ If relative pathnames are stored in the Zip file, make sure all of the }
{ required directories exist on your system before attempting an }
{ extraction. }
{$M 10240, 0, 0} { Stack, Min. Heap, Max. Heap}
{$F+} { Force far calls }
Uses
Dos,
Crt,
MemAlloc,
StrProcs;
Const
COPYRIGHT = 'DeZip (C) Copyright 1989 by R. P. Byrne';
VERSION = 'Version 1.5 - Compiled on March 11, 1989';
{ Stuff needed generically by all uncompression methods }
Const
MAXNAMES = 20;
Var
InFileSpecs : Array[1..MAXNAMES] of String; { Input file specifications }
MaxSpecs : Word; { Total number of entries in InFileSpecs array }
OutPath : String; { Output path specification }
TenPercent : LongInt;
{ Define ZIP file header types }
Const
LOCAL_FILE_HEADER_SIGNATURE = $04034B50;
Type
Local_File_Header_Type = Record
{ Signature : LongInt; }
Extract_Version_Reqd : Word;
Bit_Flag : Word;
Compress_Method : Word;
Last_Mod_Time : Word;
Last_Mod_Date : Word;
Crc32 : LongInt;
Compressed_Size : LongInt;
Uncompressed_Size : LongInt;
Filename_Length : Word;
Extra_Field_Length : Word;
end;
Const
CENTRAL_FILE_HEADER_SIGNATURE = $02014B50;
Type
Central_File_Header_Type = Record
{ Signature : LongInt; }
MadeBy_Version : Word;
Extract_Version_Reqd : Word;
Bit_Flag : Word;
Compress_Method : Word;
Last_Mod_Time : Word;
Last_Mod_Date : Word;
Crc32 : LongInt;
Compressed_Size : LongInt;
Uncompressed_Size : LongInt;
Filename_Length : Word;
Extra_Field_Length : Word;
File_Comment_Length : Word;
Starting_Disk_Num : Word;
Internal_Attributes : Word;
External_Attributes : LongInt;
Local_Header_Offset : LongInt;
End;
Const
END_OF_CENTRAL_DIR_SIGNATURE = $06054B50;
Type
End_of_Central_Dir_Type = Record
{ Signature : LongInt; }
Disk_Number : Word;
Central_Dir_Start_Disk : Word;
Entries_This_Disk : Word;
Total_Entries : Word;
Central_Dir_Size : LongInt;
Start_Disk_Offset : LongInt;
ZipFile_Comment_Length : Word;
end;
Const
CRC_32_TAB : Array[0..255] of LongInt = (
$00000000, $77073096, $ee0e612c, $990951ba, $076dc419, $706af48f, $e963a535, $9e6495a3,
$0edb8832, $79dcb8a4, $e0d5e91e, $97d2d988, $09b64c2b, $7eb17cbd, $e7b82d07, $90bf1d91,
$1db71064, $6ab020f2, $f3b97148, $84be41de, $1adad47d, $6ddde4eb, $f4d4b551, $83d385c7,
$136c9856, $646ba8c0, $fd62f97a, $8a65c9ec, $14015c4f, $63066cd9, $fa0f3d63, $8d080df5,
$3b6e20c8, $4c69105e, $d56041e4, $a2677172, $3c03e4d1, $4b04d447, $d20d85fd, $a50ab56b,
$35b5a8fa, $42b2986c, $dbbbc9d6, $acbcf940, $32d86ce3, $45df5c75, $dcd60dcf, $abd13d59,
$26d930ac, $51de003a, $c8d75180, $bfd06116, $21b4f4b5, $56b3c423, $cfba9599, $b8bda50f,
$2802b89e, $5f058808, $c60cd9b2, $b10be924, $2f6f7c87, $58684c11, $c1611dab, $b6662d3d,
$76dc4190, $01db7106, $98d220bc, $efd5102a, $71b18589, $06b6b51f, $9fbfe4a5, $e8b8d433,
$7807c9a2, $0f00f934, $9609a88e, $e10e9818, $7f6a0dbb, $086d3d2d, $91646c97, $e6635c01,
$6b6b51f4, $1c6c6162, $856530d8, $f262004e, $6c0695ed, $1b01a57b, $8208f4c1, $f50fc457,
$65b0d9c6, $12b7e950, $8bbeb8ea, $fcb9887c, $62dd1ddf, $15da2d49, $8cd37cf3, $fbd44c65,
$4db26158, $3ab551ce, $a3bc0074, $d4bb30e2, $4adfa541, $3dd895d7, $a4d1c46d, $d3d6f4fb,
$4369e96a, $346ed9fc, $ad678846, $da60b8d0, $44042d73, $33031de5, $aa0a4c5f, $dd0d7cc9,
$5005713c, $270241aa, $be0b1010, $c90c2086, $5768b525, $206f85b3, $b966d409, $ce61e49f,
$5edef90e, $29d9c998, $b0d09822, $c7d7a8b4, $59b33d17, $2eb40d81, $b7bd5c3b, $c0ba6cad,
$edb88320, $9abfb3b6, $03b6e20c, $74b1d29a, $ead54739, $9dd277af, $04db2615, $73dc1683,
$e3630b12, $94643b84, $0d6d6a3e, $7a6a5aa8, $e40ecf0b, $9309ff9d, $0a00ae27, $7d079eb1,
$f00f9344, $8708a3d2, $1e01f268, $6906c2fe, $f762575d, $806567cb, $196c3671, $6e6b06e7,
$fed41b76, $89d32be0, $10da7a5a, $67dd4acc, $f9b9df6f, $8ebeeff9, $17b7be43, $60b08ed5,
$d6d6a3e8, $a1d1937e, $38d8c2c4, $4fdff252, $d1bb67f1, $a6bc5767, $3fb506dd, $48b2364b,
$d80d2bda, $af0a1b4c, $36034af6, $41047a60, $df60efc3, $a867df55, $316e8eef, $4669be79,
$cb61b38c, $bc66831a, $256fd2a0, $5268e236, $cc0c7795, $bb0b4703, $220216b9, $5505262f,
$c5ba3bbe, $b2bd0b28, $2bb45a92, $5cb36a04, $c2d7ffa7, $b5d0cf31, $2cd99e8b, $5bdeae1d,
$9b64c2b0, $ec63f226, $756aa39c, $026d930a, $9c0906a9, $eb0e363f, $72076785, $05005713,
$95bf4a82, $e2b87a14, $7bb12bae, $0cb61b38, $92d28e9b, $e5d5be0d, $7cdcefb7, $0bdbdf21,
$86d3d2d4, $f1d4e242, $68ddb3f8, $1fda836e, $81be16cd, $f6b9265b, $6fb077e1, $18b74777,
$88085ae6, $ff0f6a70, $66063bca, $11010b5c, $8f659eff, $f862ae69, $616bffd3, $166ccf45,
$a00ae278, $d70dd2ee, $4e048354, $3903b3c2, $a7672661, $d06016f7, $4969474d, $3e6e77db,
$aed16a4a, $d9d65adc, $40df0b66, $37d83bf0, $a9bcae53, $debb9ec5, $47b2cf7f, $30b5ffe9,
$bdbdf21c, $cabac28a, $53b39330, $24b4a3a6, $bad03605, $cdd70693, $54de5729, $23d967bf,
$b3667a2e, $c4614ab8, $5d681b02, $2a6f2b94, $b40bbe37, $c30c8ea1, $5a05df1b, $2d02ef8d
);
Const
BUFSIZE = 8192; { Size of buffers for I/O }
Type
BufPtr = ^BufType;
BufType = Array[1..BUFSIZE] of Byte;
Var
ZipName : String; { Name of Zip file to be processed }
ZipFile : File; { Zip file variable }
EndFile : Boolean; { End of file indicator for ZipFile }
ZipBuf : BufPtr; { Input buffer for ZipFile }
ZipPtr : Word; { Index for ZipFile input buffer }
ZipCount : Word; { Count of bytes in ZipFile input buffer }
ExtFile : File; { Output file variable }
ExtBuf : BufPtr; { Output buffer for ExtFile }
ExtPtr : Word; { Index for ExtFile output buffer }
ExtCount : LongInt; { Count of characters written to output }
LocalHdr : Local_File_Header_Type; { Storage for a local file hdr }
Hdr_FileName : String;
Hdr_ExtraField : String;
Hdr_Comment : String;
Crc32Val : LongInt; { Running CRC (32 bit) value }
Bytes_To_Go : LongInt; { Bytes left to process in compressed file }
{ Stuff needed for unSHRINKing }
Const
MINCODESIZE = 9;
MAXCODESIZE = 13;
SPECIAL = 256;
FIRSTFREE = 257;
LZW_TABLE_SIZE = (1 SHL MAXCODESIZE) - 1; { 0..8191 }
LZW_STACK_SIZE = (1 SHL MAXCODESIZE) - 1; { 0..8191 }
Type
LZW_Table_Rec = Record
Prefix : Integer;
Suffix : Byte;
ChildCount : Word; { If ChildCount = 0 then leaf node }
end;
LZW_Table_Ptr = ^LZW_Table_Type;
LZW_Table_Type = Array[0..LZW_TABLE_SIZE] of LZW_Table_Rec;
FreeListPtr = ^FreeListArray;
FreeListArray = Array[FIRSTFREE..LZW_TABLE_SIZE] of Word;
StackPtr = ^StackType;
StackType = Array[0..LZW_STACK_SIZE] of Word;
Var
LZW_Table : LZW_Table_Ptr; { Code table for LZW decoding }
FreeList : FreeListPtr; { List of free table entries }
NextFree : Word; { Index for free list array }
{ FreeList^[NextFree] always contains the }
{ index of the next available entry in }
{ the LZW Prefix:Suffix table (LZW_Table^) }
LZW_Stack : StackPtr; { A stack used to build decoded strings }
StackIdx : Word; { Stack array index variable }
{ StackIdx always points to the next }
{ available entry in the stack }
SaveByte : Byte; { Our input code buffer - 1 byte long }
BitsLeft : Byte; { Unprocessed bits in the input code buffer }
FirstCh : Boolean; { Flag indicating first char being processed }
{ Stuff needed for unREDUCEing }
Type
FollowerSet = Record
SetSize : Word;
FSet : Array[0..31] of Byte;
end;
FollowerPtr = ^FollowerArray;
FollowerArray = Array[0..255] of FollowerSet;
StreamPtr = ^StreamArray;
StreamArray = Array[0..4095] of Byte;
Var
Followers : FollowerPtr;
Stream : StreamPtr; { The output stream }
StreamIdx : Word; { Always points to next pos. to be filled }
State : Byte;
Len : Word;
V : Byte;
{ --------------------------------------------------------------------------- }
Procedure Abort(Msg : String);
Begin
Writeln;
Writeln(Msg);
Writeln('Returning to DOS');
Writeln;
Halt;
end {Abort};
{ --------------------------------------------------------------------------- }
Procedure Syntax;
Begin
Writeln('Usage: DeZip ZipFileName [OutPathSpec] [FileSpec [...]]');
Writeln;
Writeln('Optional file specifications may contain DOS ');
Writeln('wildcard characters.');
Writeln;
Writeln('If no filespecs are entered, *.* is assumed.');
Writeln;
Halt;
End;
{ --------------------------------------------------------------------------- }
Function HexLInt(L : LongInt) : String;
Type
HexType = Array [0..15] of Char;
Const
HexChar : HexType = ('0','1','2','3','4','5','6','7',
'8','9','A','B','C','D','E','F');
Begin
HexLInt := HexChar[(L AND $F0000000) SHR 28] +
HexChar[(L AND $0F000000) SHR 24] +
HexChar[(L AND $00F00000) SHR 20] +
HexChar[(L AND $000F0000) SHR 16] +
HexChar[(L AND $0000F000) SHR 12] +
HexChar[(L AND $00000F00) SHR 8] +
HexChar[(L AND $000000F0) SHR 4] +
HexChar[(L AND $0000000F) ] +
'h';
end {HexLInt};
{ --------------------------------------------------------------------------- }
Function IO_Test : Boolean;
Var
ErrorCode : Word;
CodeStr : String;
Ok : Boolean;
Begin
Ok := TRUE;
ErrorCode := IOResult;
If ErrorCode <> 0 then begin
Ok := FALSE;
Case ErrorCode of
2 : Writeln('File Not Found');
3 : Writeln('Path Not Found');
5 : Writeln('Access Denied');
101 : Writeln('Disk Full');
else Writeln('I/O Error # ', ErrorCode);
end {Case};
end {if};
IO_Test := Ok;
end {IO_Test};
{ --------------------------------------------------------------------------- }
Procedure Load_Parms;
Var
I : Word;
Name : String;
DosDTA : SearchRec;
Begin
I := ParamCount;
If I < 1 then
Syntax;
ZipName := ParamStr(1);
For I := 1 to Length(ZipName) do
ZipName[I] := UpCase(ZipName[I]);
If Pos('.', ZipName) = 0 then
ZipName := ZipName + '.ZIP';
MaxSpecs := 0;
OutPath := '';
I := 1;
While I < ParamCount do begin
Inc(I);
Name := ParamStr(I);
If Name[length(Name)] = '\' then
Delete(Name, length(Name), 1);
FindFirst(Name, DIRECTORY, DosDTA); { outpath spec? }
If DosError = 0 then begin
If (DosDTA.Attr AND DIRECTORY) <> 0 then begin { yup }
OutPath := Name;
If OutPath[Length(OutPath)] <> '\' then
OutPath := OutPath + '\';
end {then}
else begin
If MaxSpecs < MAXNAMES then begin
Inc(MaxSpecs);
InFileSpecs[MaxSpecs] := Name;
end {if};
end {if};
end {then}
else begin
If MaxSpecs < MAXNAMES then begin
Inc(MaxSpecs);
InFileSpecs[MaxSpecs] := Name;
end {if};
end {if}
end {while};
If MaxSpecs = 0 then begin
MaxSpecs := 1;
InFileSpecs[1] := '*.*';
end {if};
end {Load_Parms};
{ --------------------------------------------------------------------------- }
Procedure Initialize;
Var
Code : Integer;
Begin
Code := Malloc(ZipBuf, SizeOf(ZipBuf^)) OR
Malloc(ExtBuf, SizeOf(ExtBuf^));
If Code <> 0 then
Abort('Not enough memory available to allocate I/O buffers!');
end {Initialize};
{ --------------------------------------------------------------------------- }
{ Converted to Turbo Pascal (tm) V4.0 March, 1988 by J.R.Louvau }
{ COPYRIGHT (C) 1986 Gary S. Brown. You may use this program, or }
{ code or tables extracted from it, as desired without restriction. }
{ }
{ First, the polynomial itself and its table of feedback terms. The }
{ polynomial is }
{ X^32+X^26+X^23+X^22+X^16+X^12+X^11+X^10+X^8+X^7+X^5+X^4+X^2+X^1+X^0 }
{ }
{ Note that we take it "backwards" and put the highest-order term in }
{ the lowest-order bit. The X^32 term is "implied"; the LSB is the }
{ X^31 term, etc. The X^0 term (usually shown as "+1") results in }
{ the MSB being 1. }
{ }
{ Note that the usual hardware shift register implementation, which }
{ is what we're using (we're merely optimizing it by doing eight-bit }
{ chunks at a time) shifts bits into the lowest-order term. In our }
{ implementation, that means shifting towards the right. Why do we }
{ do it this way? Because the calculated CRC must be transmitted in }
{ order from highest-order term to lowest-order term. UARTs transmit }
{ characters in order from LSB to MSB. By storing the CRC this way, }
{ we hand it to the UART in the order low-byte to high-byte; the UART }
{ sends each low-bit to hight-bit; and the result is transmission bit }
{ by bit from highest- to lowest-order term without requiring any bit }
{ shuffling on our part. Reception works similarly. }
{ }
{ The feedback terms table consists of 256, 32-bit entries. Notes: }
{ }
{ The table can be generated at runtime if desired; code to do so }
{ is shown later. It might not be obvious, but the feedback }
{ terms simply represent the results of eight shift/xor opera- }
{ tions for all combinations of data and CRC register values. }
{ }
{ The values must be right-shifted by eight bits by the "updcrc" }
{ logic; the shift must be unsigned (bring in zeroes). On some }
{ hardware you could probably optimize the shift in assembler by }
{ using byte-swap instructions. }
{ polynomial $edb88320 }
{ }
Function UpdC32(Octet: Byte; Crc: LongInt) : LongInt;
Var
L : LongInt;
W : Array[1..4] of Byte Absolute L;
Begin
UpdC32 := CRC_32_TAB[Byte(Crc XOR LongInt(Octet))] XOR ((Crc SHR 8) AND $00FFFFFF);
end {UpdC32};
{ --------------------------------------------------------------------------- }
Procedure Read_Zip_Block;
Begin
BlockRead(ZipFile, ZipBuf^, BUFSIZE, ZipCount);
If ZipCount = 0 then
EndFile := TRUE;
ZipPtr := 1;
End {Read_Zip_Block};
{ --------------------------------------------------------------------------- }
Procedure Write_Ext_Block;
Begin
If ExtPtr > 1 then begin
BlockWrite(ExtFile, ExtBuf^, Pred(ExtPtr));
If NOT IO_Test then
Halt;
ExtPtr := 1;
end {if};
End {Write_Ext_Block};
{ --------------------------------------------------------------------------- }
Procedure Open_Zip;
Begin
Assign(ZipFile, ZipName);
FileMode := 64; { Read Only / Deny None }
{$I-} Reset(ZipFile, 1) {$I+};
If NOT IO_Test then
Halt;
EndFile := FALSE;
Read_Zip_Block;
End {Open_Zip};
{ --------------------------------------------------------------------------- }
Function Open_Ext : Boolean;
Begin
Assign(ExtFile, OutPath + Hdr_FileName);
FileMode := 66; { Read & Write / Deny None }
{$I-} Rewrite(ExtFile, 1) {$I+};
If NOT IO_Test then
Open_Ext := FALSE
else begin
ExtPtr := 1;
Open_Ext := TRUE;
end {if};
end {Open_Ext};
{ --------------------------------------------------------------------------- }
Function Get_Zip : Integer;
Begin
If ZipPtr > ZipCount then
Read_Zip_Block;
If EndFile then
Get_Zip := -1
else begin
Get_Zip := ZipBuf^[ZipPtr];
Inc(ZipPtr);
end {if};
end {Get_Zip};
{ --------------------------------------------------------------------------- }
Procedure Put_Ext(C : Byte);
Begin
Crc32Val := UpdC32(C, Crc32Val);
ExtBuf^[ExtPtr] := C;
Inc(ExtPtr);
Inc(ExtCount);
If ExtPtr > BUFSIZE then
Write_Ext_Block;
end {Put_Ext};
{ --------------------------------------------------------------------------- }
Procedure Close_Zip;
Begin
{$I-} Close(Zipfile) {$I+};
If IO_Test then ;
end {Close_Zip};
{ --------------------------------------------------------------------------- }
Procedure Close_Ext;
Type
TimeDateRec = Record
Time : Word;
Date : Word;
end {record};
Var
TimeDate : TimeDateRec;
TimeDateStamp : LongInt Absolute TimeDate;
Begin
Write_Ext_Block;
TimeDate.Time := LocalHdr.Last_Mod_Time;
TimeDate.Date := LocalHdr.Last_Mod_Date;
SetFTime(ExtFile, TimeDateStamp);
{$I-} Close(ExtFile) {$I+};
If IO_Test then ;
GotoXY(1, WhereY);
Write(ExtCount);
GotoXY(1, WhereY);
end {Close_Ext};
{ --------------------------------------------------------------------------- }
Procedure FSkip(Offset : LongInt);
Var
Rec : LongInt;
Begin
If (Offset + ZipPtr) <= ZipCount then
Inc(ZipPtr, Offset)
else begin
Rec := FilePos(ZipFile) + (Offset - (ZipCount - ZipPtr) - 1);
{$I-} Seek(ZipFile, Rec) {$I+};
If NOT IO_Test then
Halt;
Read_Zip_Block;
end {if};
end {FSkip};
{ --------------------------------------------------------------------------- }
Procedure FRead(Var Buf; RecLen : Word);
Var
I : Word;
B : Array[1..MaxInt] of Byte Absolute Buf;
Begin
For I := 1 to RecLen do
B[I] := Get_Zip;
end {FRead};
{ --------------------------------------------------------------------------- }
Function Read_Local_Hdr : Boolean;
Var
Sig : LongInt;
Begin
If EndFile then
Read_Local_Hdr := FALSE
else begin
FRead(Sig, SizeOf(Sig));
If Sig = CENTRAL_FILE_HEADER_SIGNATURE then begin
Read_Local_Hdr := FALSE;
EndFile := TRUE;
end {then}
else begin
If Sig <> LOCAL_FILE_HEADER_SIGNATURE then
Abort('Missing or invalid local file header in ' + ZipName);
FRead(LocalHdr, SizeOf(LocalHdr));
With LocalHdr do begin
If FileName_Length > 255 then
Abort('Filename of compressed file exceeds 255 characters!');
FRead(Hdr_FileName[1], FileName_Length);
Hdr_FileName[0] := Chr(FileName_Length);
If Extra_Field_Length > 255 then
Abort('Extra field of compressed file exceeds 255 characters!');
FRead(Hdr_ExtraField[1], Extra_Field_Length);
Hdr_ExtraField[0] := Chr(Extra_Field_Length);
end {with};
Read_Local_Hdr := TRUE;
end {if};
end {if};
end {Read_Local_Hdr};
{ --------------------------------------------------------------------------- }
Function Get_Compressed : Integer;
Var
PctDone : Integer;
Begin
If Bytes_To_Go = 0 then
Get_Compressed := -1
else begin
Get_Compressed := Get_Zip;
If Bytes_To_Go mod TenPercent = 0 then begin
PctDone := 100 - Round( 100 * (Bytes_To_Go / LocalHdr.Compressed_Size));
GotoXY(WhereX - 4, WhereY);
Write(PctDone:3, '%');
end {if};
Dec(Bytes_To_Go);
end {if};
end {Get_Compressed};
{ --------------------------------------------------------------------------- }
Function LZW_Init : Boolean;
Var
RC : Word;
I : Word;
Label
Exit;
Begin
{ Initialize LZW Table }
RC := Malloc(LZW_Table, SizeOf(LZW_Table^));
If RC <> 0 then begin
LZW_Init := FALSE;
Goto Exit;
end {if};
For I := 0 to LZW_TABLE_SIZE do begin
With LZW_Table^[I] do begin
Prefix := -1;
If I < 256 then
Suffix := I
else
Suffix := 0;
ChildCount := 0;
end {with};
end {for};
RC := Malloc(FreeList, SizeOf(FreeList^));
If RC <> 0 then begin
LZW_Init := FALSE;
Goto Exit;
end {if};
For I := FIRSTFREE to LZW_TABLE_SIZE do
FreeList^[I] := I;
NextFree := FIRSTFREE;
{ Initialize the LZW Character Stack }
RC := Malloc(LZW_Stack, SizeOf(LZW_Stack^));
If RC <> 0 then begin
LZW_Init := FALSE;
Goto Exit;
end {if};
StackIdx := 0;
LZW_Init := TRUE;
Exit:
end {LZW_Init};
{ --------------------------------------------------------------------------- }
Procedure LZW_Cleanup;
Var
Code : Word;
Begin
Code := Dalloc(LZW_Table);
Code := Dalloc(FreeList);
Code := Dalloc(LZW_Stack);
end {LZW_Cleanup};
{ --------------------------------------------------------------------------- }
Procedure Clear_LZW_Table;
Var
I : Word;
Begin
StackIdx := 0;
For I := FIRSTFREE to LZW_TABLE_SIZE do begin { Find all leaf nodes }
If LZW_Table^[I].ChildCount = 0 then begin
LZW_Stack^[StackIdx] := I; { and put each on stack }
Inc(StackIdx);
end {if};
end {for};
NextFree := Succ(LZW_TABLE_SIZE);
While StackIdx > 0 do begin { clear all leaf nodes }
Dec(StackIdx);
I := LZW_Stack^[StackIdx];
With LZW_Table^[I] do begin
If LZW_Table^[I].Prefix <> -1 then
Dec(LZW_Table^[Prefix].ChildCount);
Prefix := -1;
Suffix := 0;
ChildCount := 0;
end {with};
Dec(NextFree); { add cleared nodes to freelist }
FreeList^[NextFree] := I;
end {while};
End {Clear_LZW_Table};
{ --------------------------------------------------------------------------- }
Procedure Add_To_LZW_Table(Prefix : Integer; Suffix : Byte);
Var
I : Word;
Begin
If NextFree <= LZW_TABLE_SIZE then begin
I := FreeList^[NextFree];
Inc(NextFree);
LZW_Table^[I].Prefix := Prefix;
LZW_Table^[I].Suffix := Suffix;
Inc(LZW_Table^[Prefix].ChildCount);
end {if};
End {Add_To_LZW_Table};
{ --------------------------------------------------------------------------- }
Function Get_Code(CodeSize : Byte) : Integer;
Const
Mask : Array[1..8] of Byte = ($01, $03, $07, $0F, $1F, $3F, $7F, $FF);
TmpInt : Integer = 0;
Var
BitsNeeded : Byte;
HowMany : Byte;
HoldCode : Integer;
Label
Exit;
Begin
If FirstCh then begin { If first time through ... }
TmpInt := Get_Compressed; { ... then prime the code buffer }
If TmpInt = -1 then begin { If EOF on fill attempt ... }
Get_Code := -1; { ... then return EOF indicator ... }
Goto Exit; { ... and return to caller. }
end {if};
SaveByte := TmpInt;
BitsLeft := 8; { there's now 8 bits in our buffer }
FirstCh := FALSE;
end {if};
BitsNeeded := CodeSize;
HoldCode := 0;
While (BitsNeeded > 0) And (TmpInt <> -1) do begin
If BitsNeeded >= BitsLeft
then HowMany := BitsLeft { HowMany <-- Min(BitsLeft, BitsNeeded) }
else HowMany := BitsNeeded;
HoldCode := HoldCode OR ((SaveByte AND Mask[HowMany]) SHL (CodeSize - BitsNeeded));
SaveByte := SaveByte SHR HowMany;
Dec(BitsNeeded, HowMany);
Dec(BitsLeft, HowMany);
If BitsLeft <= 0 then begin { If no bits left in buffer ... }
TmpInt := Get_Compressed; { ... then attempt to get 8 more. }
If TmpInt = -1 then
Goto Exit;
SaveByte := TmpInt;
BitsLeft := 8;
end {if};
end {while};
Exit:
If (BitsNeeded = 0) then { If we got what we came for ... }
Get_Code := HoldCode { ... then return it }
else
Get_Code := -1; { ... Otherwise, return EOF }
end {Get_Code};
{ --------------------------------------------------------------------------- }
Procedure UnShrink;
Var
Ch : Char;
CodeSize : Byte; { Current size (in bits) of codes coming in }
CurrCode : Integer;
SaveCode : Integer;
PrevCode : Integer;
BaseChar : Byte;
Label
Exit;
Begin
CodeSize := MINCODESIZE; { Start with the smallest code size }
PrevCode := Get_Code(CodeSize); { Get first code from file }
If PrevCode = -1 then { If EOF already, then ... }
Goto Exit; { ... just exit without further ado }
BaseChar := PrevCode;
Put_Ext(BaseChar); { Unpack the first character }
CurrCode := Get_Code(CodeSize); { Get next code to prime the while loop }
While CurrCode <> -1 do begin { Repeat for all compressed bytes }
If CurrCode = SPECIAL then begin { If we've got a "special" code ... }
CurrCode := Get_Code(CodeSize);
Case CurrCode of
1 : Begin { ... and if followed by a 1 ... }
Inc(CodeSize); { ... then increase code size }
end {1};
2 : Begin { ... and if followed by a 2 ... }
Clear_LZW_Table; { ... clear leaf nodes in the table }
end {2};
else begin { ... if neither 1 or 2, discard }
Writeln;
Writeln('Encountered code 256 not followed by 1 or 2!');
Writeln;
Write('Press a key to continue ...');
Ch := ReadKey;
DelLine;
GotoXY(1, WhereY);
end {else};
end {case};
end {then}
else begin { Not a "special" code }
SaveCode := CurrCode; { Save this code someplace safe... }
If CurrCode > LZW_TABLE_SIZE then
Abort('Invalid code encountered!');
If (CurrCode >= FIRSTFREE) and (LZW_Table^[CurrCode].Prefix = -1) then begin
If StackIdx > LZW_STACK_SIZE then begin
Write_Ext_Block;
Writeln;
Writeln('Stack Overflow (', StackIdx, ')!');
Halt;
end {if};
LZW_Stack^[StackIdx] := BaseChar;
Inc(StackIdx);
CurrCode := PrevCode;
end {if};
While CurrCode >= FIRSTFREE do begin
If StackIdx > LZW_STACK_SIZE then begin
Write_Ext_Block;
Writeln;
Writeln('Stack Overflow (', StackIdx, ')!');
Halt;
end {if};
LZW_Stack^[StackIdx] := LZW_Table^[CurrCode].Suffix;
Inc(StackIdx);
CurrCode := LZW_Table^[CurrCode].Prefix;
end {while};
BaseChar := LZW_Table^[CurrCode].Suffix; { Get last character ... }
Put_Ext(BaseChar);
While (StackIdx > 0) do begin
Dec(StackIdx);
Put_Ext(LZW_Stack^[StackIdx]);
end {while}; { ... until there are none left }
Add_to_LZW_Table(PrevCode, BaseChar); { Add new entry to table }
PrevCode := SaveCode;
end {if};
CurrCode := Get_Code(CodeSize); { Get next code from input stream }
end {while};
Exit:
end {UnShrink};
{ --------------------------------------------------------------------------- }
Function Init_UnReduce : Boolean;
Var
Code : Word;
Label
Exit;
Begin
Code := Malloc(Followers, SizeOf(Followers^));
If Code <> 0 then begin
Init_UnReduce := FALSE;
Goto Exit;
end {if};
Code := Malloc(Stream, SizeOf(Stream^));
If Code <> 0 then begin
Init_UnReduce := FALSE;
Goto Exit;
end {if};
Init_UnReduce := TRUE;
Exit:
end {Init_UnReduce};
{ --------------------------------------------------------------------------- }
Procedure Cleanup_UnReduce;
Var
Code : Word;
Begin
Code := Dalloc(Followers);
Code := Dalloc(Stream);
end {Cleanup_UnReduce};
{ --------------------------------------------------------------------------- }
Function D(X, Y : Byte) : Word;
Var
tmp : LongInt;
Begin
X := X SHR (8 - Pred(LocalHdr.Compress_Method));
Tmp := X * 256;
D := Tmp + Y + 1;
end {D};
{ --------------------------------------------------------------------------- }
Function F(X : Word) : Byte;
Const
TestVal : Array[1..4] of Byte = (127, 63, 31, 15);
Begin
If X = TestVal[Pred(LocalHdr.Compress_Method)] then
F := 2
else
F := 3;
end {F};
{ --------------------------------------------------------------------------- }
Function L(X : Byte) : Byte;
Const
Mask : Array[1..4] of Byte = ($7F, $3F, $1F, $0F);
Begin
L := X AND Mask[Pred(LocalHdr.Compress_Method)];
end {L};
{ --------------------------------------------------------------------------- }
Procedure StreamOut(C : Byte);
Begin
Put_Ext(C);
Stream^[StreamIdx] := C;
StreamIdx := Succ(StreamIdx) MOD 4096;
end {StreamOut};
{ --------------------------------------------------------------------------- }
Procedure ScrnchInit;
Begin
State := 0;
For StreamIdx := 0 to 4095 do
Stream^[StreamIdx] := 0;
StreamIdx := 0;
end {ScrnchInit};
{ --------------------------------------------------------------------------- }
Procedure UnScrnch(C : Byte);
Const
DLE = $90;
Var
S : Integer;
Count : Word;
OneByte : Byte;
Tmp1 : LongInt;
Begin
Case State of
0 : begin
If C = DLE then
State := 1
else
StreamOut(C);
end {0};
1 : begin
If C = 0 then begin
StreamOut(DLE);
State := 0;
end {then}
else begin
V := C;
Len := L(V);
State := F(Len);
end {if};
end {1};
2 : begin
Inc(Len, C);
State := 3;
end {2};
3 : begin
Tmp1 := D(V, C);
S := StreamIdx - Tmp1;
If S < 0 then
S := S + 4096;
Count := Len + 3;
While Count > 0 do begin
OneByte := Stream^[S];
StreamOut(OneByte);
S := Succ(S) MOD 4096;
Dec(Count);
end {while};
State := 0;
end {3};
end {case};
end {UnScrnch};
{ --------------------------------------------------------------------------- }
Function MinBits(Val : Byte) : Byte;
Begin
Dec(Val);
Case Val of
0..1 : MinBits := 1;
2..3 : MinBits := 2;
4..7 : MinBits := 3;
8..15 : MinBits := 4;
16..31 : MinBits := 5;
else MinBits := 6;
end {case};
end {MinBits};
{ --------------------------------------------------------------------------- }
Procedure UnReduce;
Var
LastChar : Byte;
N : Byte;
I, J : Word;
Code : Integer;
Ch : Char;
Begin
For I := 255 downto 0 do begin { Load follower sets }
N := Get_Code(6); { Get size of 1st set }
Followers^[I].SetSize := N;
If N > 0 then
For J := 0 to Pred(N) do
Followers^[I].FSet[J] := Get_Code(8);
end {for};
ScrnchInit;
LastChar := 0;
Repeat
If Followers^[LastChar].SetSize = 0 then begin
Code := Get_Code(8);
UnScrnch(Code);
LastChar := Code;
end {then}
else begin
Code := Get_Code(1);
If Code <> 0 then begin
Code := Get_Code(8);
UnScrnch(Code);
LastChar := Code;
end {then}
else begin
I := MinBits(Followers^[LastChar].SetSize);
Code := Get_Code(I);
UnScrnch(Followers^[LastChar].FSet[Code]);
LastChar := Followers^[LastChar].FSet[Code];
end {if};
end {if};
Until (ExtCount = LocalHdr.Uncompressed_Size);
Code := Dalloc(Followers);
end {UnReduce};
{ --------------------------------------------------------------------------- }
Procedure UnZip;
Var
C : Integer;
Begin
Crc32Val := $FFFFFFFF;
Bytes_To_Go := LocalHdr.Compressed_Size;
FirstCh := TRUE;
ExtCount := 0;
TenPercent := LocalHdr.Compressed_Size DIV 10;
Case LocalHdr.Compress_Method of
0 : Begin
While Bytes_to_go > 0 do
Put_Ext(Get_Compressed);
end {0 = Stored};
1 : Begin
If LZW_Init then
UnShrink
else begin
Writeln('Not enough memory available to unshrink!');
Writeln('Skipping ', Hdr_FileName, ' ...');
FSkip(LocalHdr.Compressed_Size);
Crc32Val := NOT LocalHdr.Crc32;
end {if};
LZW_Cleanup;
end {1 = shrunk};
2..5 : Begin
If Init_UnReduce then
UnReduce
else begin
Writeln('Not enough memory available to unreduce!');
Writeln('Skipping ', Hdr_FileName, ' ...');
FSkip(LocalHdr.Compressed_Size);
Crc32Val := NOT LocalHdr.Crc32;
end {if};
Cleanup_UnReduce;
end {2..5};
else Begin
Writeln('Unknown compression method used on ', Hdr_FileName);
Writeln('Skipping ', Hdr_FileName, ' ...');
FSkip(LocalHdr.Compressed_Size);
Crc32Val := NOT LocalHdr.Crc32;
end {else};
end {case};
Crc32Val := NOT Crc32Val;
If Crc32Val <> LocalHdr.Crc32 then begin
Writeln;
Writeln('WARNING: File ', OutPath + Hdr_FileName, ' fails CRC check!');
Writeln(' Stored CRC = ', HexLInt(LocalHdr.Crc32),
' Calculated CRC = ', HexLInt(Crc32Val));
end {if};
end {UnZip};
{ --------------------------------------------------------------------------- }
Procedure Extract_File;
Var
YesNo : Char;
DosDTA : SearchRec;
Label
Exit;
Begin
FindFirst(OutPath + Hdr_FileName, ANYFILE, DosDTA);
If DosError = 0 then begin
Write('WARNING: ', OutPath + Hdr_FileName, ' already exists. Overwrite (Y/N)? ');
YesNo := ReadKey;
Writeln(YesNo);
If UpCase(YesNo) <> 'Y' then begin
FSkip(LocalHdr.Compressed_Size);
Goto Exit;
end {if};
end {if};
If Open_Ext then begin
Write('Extracting: ', OutPath + Hdr_FileName, ' ... ');
UnZip;
GotoXY(WhereX - 4, WhereY);
ClrEol;
Writeln(' done');
Close_Ext;
end {then}
else begin
Writeln('Could not open output file ', OutPath + Hdr_FileName, '! Skipping to next file ...');
FSkip(LocalHdr.Compressed_Size);
end {If};
Exit:
end {Extract_File};
{ --------------------------------------------------------------------------- }
Procedure Extract_Zip;
Var
Match : Boolean;
I : Word;
Begin
Open_Zip;
While Read_Local_Hdr do begin
Match := FALSE;
I := 1;
Repeat
If SameFile(InFileSpecs[I], Hdr_FileName) then
Match := TRUE;
Inc(I);
Until Match or (I > MaxSpecs);
If Match then
Extract_File
else
FSkip(LocalHdr.Compressed_Size);
end {while};
Close_Zip;
GotoXY(1, WhereY);
ClrEOL;
end;
{ --------------------------------------------------------------------------- }
Begin
Assign(Output, '');
Rewrite(Output);
Writeln;
Writeln(COPYRIGHT);
Writeln(VERSION);
Writeln;
Load_Parms; { get command line parameters }
Initialize; { one-time initialization }
Extract_Zip; { de-arc the file }
end.