Source file : unzip-decompress.adb
-- UnZip.Decompress
--------------------
-- Internal to the UnZip package. See root package (UnZip) for details & credits.
-- Legal licensing note:
-- Copyright (c) 2007 .. 2024 Gautier de Montmollin
-- SWITZERLAND
-- Permission is hereby granted, free of charge, to any person obtaining a copy
-- of this software and associated documentation files (the "Software"), to deal
-- in the Software without restriction, including without limitation the rights
-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-- copies of the Software, and to permit persons to whom the Software is
-- furnished to do so, subject to the following conditions:
-- The above copyright notice and this permission notice shall be included in
-- all copies or substantial portions of the Software.
-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
-- THE SOFTWARE.
-- NB: this is the MIT License, as found on the site
-- http://www.opensource.org/licenses/mit-license.php
with Zip.CRC_Crypto, UnZip.Decompress.Huffman, BZip2.Decoding, LZMA.Decoding;
with Ada.Exceptions, Ada.Streams.Stream_IO, Ada.Text_IO, Interfaces;
package body UnZip.Decompress is
procedure Decompress_Data
(zip_file : in out Zip_Streams.Root_Zipstream_Type'Class;
-- zip_file must be open and its index is meant
-- to point to the beginning of compressed data
format : in Zip.PKZip_method;
write_mode : in Write_Mode_Type;
output_file_name : in String; -- relevant only if mode = write_to_file
output_memory_access : out p_Stream_Element_Array; -- \ = write_to_memory
output_stream_access : in p_Stream; -- \ = write_to_stream
feedback : in Zip.Feedback_Proc;
explode_literal_tree : in Boolean; -- relevant for the "explode" format
explode_slide_8KB_LZMA_EOS : in Boolean; -- relevant for the "explode" and "LZMA" formats
data_descriptor_after_data : in Boolean;
is_encrypted : in Boolean;
password : in out Ada.Strings.Unbounded.Unbounded_String;
get_new_password : in Get_Password_Proc; -- if null, initial pwd must fit
hint : in out Zip.Headers.Local_File_Header)
is
-- Disable AdaControl rule for detecting global variables, they have become local here.
--## RULE OFF Directly_Accessed_Globals
--
-- I/O Buffers: Size of input buffer
inbuf_size : constant := 16#8000#; -- (orig: 16#1000# B = 4 KiB)
-- I/O Buffers: Size of sliding dictionary and output buffer
wsize : constant := 16#10000#; -- (orig: 16#8000# B = 32 KiB)
----------------------------------------------------------------------------
-- Specifications of UnZ_* packages (remain of Info Zip's code structure) --
----------------------------------------------------------------------------
use Ada.Exceptions, Interfaces;
package UnZ_Glob is -- Not global anymore, since local to Decompress_data :-)
-- I/O Buffers: Sliding dictionary for unzipping, and output buffer as well
slide : Zip.Byte_Buffer (0 .. wsize);
slide_index : Integer := 0; -- Current Position in slide
-- I/O Buffers: Input buffer
inbuf : Zip.Byte_Buffer (0 .. inbuf_size - 1);
inpos, readpos : Integer; -- pos. in input buffer, pos. read from file
compsize, -- compressed size of file
reachedsize, -- number of bytes read from zipfile
uncompsize, -- uncompressed size of file
effective_writes : Zip.Zip_64_Data_Size_Type;
-- ^ count of effective bytes written or tested, for feedback only
percents_done : Natural;
crc32val : Unsigned_32; -- crc calculated from data
uncompressed_index : Ada.Streams.Stream_Element_Offset;
end UnZ_Glob;
Zip_EOF : Boolean; -- read over end of zip section for this file
LZ77_dump : Ada.Text_IO.File_Type;
package UnZ_IO is
out_bin_file : Ada.Streams.Stream_IO.File_Type;
out_txt_file : Ada.Text_IO.File_Type;
last_char : Character := ' ';
procedure Init_Buffers;
procedure Read_Byte_no_Decrypt (bt : out Zip.Byte);
pragma Inline (Read_Byte_no_Decrypt);
function Read_Byte_Decrypted return Unsigned_8; -- NB: reading goes on a while even if
pragma Inline (Read_Byte_Decrypted); -- Zip_EOF is set: just gives garbage
package Bit_buffer is
procedure Init;
-- Read at least n bits into the bit buffer, returns the n first bits
function Read (n : Natural) return Integer;
pragma Inline (Read);
function Read_U32 (n : Natural) return Unsigned_32;
pragma Inline (Read_U32);
-- Inverts (NOT operator) the result before masking by n bits
function Read_inverted (n : Natural) return Integer;
pragma Inline (Read_inverted);
-- Dump n bits no longer needed from the bit buffer
procedure Dump (n : Natural);
pragma Inline (Dump);
procedure Dump_to_byte_boundary;
function Read_and_dump (n : Natural) return Integer;
pragma Inline (Read_and_dump);
function Read_and_dump_U32 (n : Natural) return Unsigned_32;
pragma Inline (Read_and_dump_U32);
end Bit_buffer;
procedure Flush (x : Natural); -- directly from slide to output stream
procedure Flush_if_full (W : in out Integer; unflushed : in out Boolean);
pragma Inline (Flush_if_full);
procedure Flush_if_full (W : in out Integer);
pragma Inline (Flush_if_full);
procedure Copy (distance, copy_length : Natural; index : in out Natural);
pragma Inline (Copy);
procedure Copy_or_zero (
distance, length : Natural;
index : in out Natural;
unflushed : in out Boolean);
pragma Inline (Copy_or_zero);
procedure Delete_output; -- an error has occured (bad compressed data)
end UnZ_IO;
package UnZ_Meth is
procedure Copy_stored;
procedure Unshrink;
subtype Reduction_factor is Integer range 1 .. 4;
procedure Unreduce (factor : Reduction_factor);
procedure Explode (literal_tree, slide_8_KB : Boolean);
deflate_e_mode : Boolean := False;
procedure Inflate;
procedure Bunzip2; -- Nov-2009
procedure LZMA_Decode; -- Jun-2014
end UnZ_Meth;
procedure Process_feedback (new_bytes : Zip.Zip_64_Data_Size_Type) is
pragma Inline (Process_feedback);
new_percents_done : Natural;
user_aborting : Boolean;
use Zip;
begin
if feedback = null or UnZ_Glob.uncompsize = 0 then
return; -- no feedback proc. or cannot calculate percentage
end if;
UnZ_Glob.effective_writes := UnZ_Glob.effective_writes + new_bytes;
new_percents_done := Natural (
(100.0 * Float (UnZ_Glob.effective_writes)) / Float (UnZ_Glob.uncompsize)
);
if new_percents_done > UnZ_Glob.percents_done then
feedback (
percents_done => new_percents_done,
entry_skipped => False,
user_abort => user_aborting
);
if user_aborting then
raise User_abort;
end if;
UnZ_Glob.percents_done := new_percents_done;
end if;
end Process_feedback;
use Zip.CRC_Crypto;
local_crypto_pack : Crypto_pack;
------------------------------
-- Bodies of UnZ_* packages --
------------------------------
package body UnZ_IO is
procedure Init_Buffers is
begin
UnZ_Glob.inpos := 0; -- Input buffer position
UnZ_Glob.readpos := -1; -- Nothing read
UnZ_Glob.slide_index := 0;
UnZ_Glob.reachedsize := 0;
UnZ_Glob.effective_writes := 0;
UnZ_Glob.percents_done := 0;
Zip_EOF := False;
Zip.CRC_Crypto.Init (UnZ_Glob.crc32val);
Bit_buffer.Init;
end Init_Buffers;
procedure Process_compressed_end_reached is
begin
if Zip_EOF then -- We came already here once
raise Zip.Archive_corrupted with
"Decoding went past compressed data size plus one buffer length";
-- Avoid infinite loop on data with exactly buffer's length and no end marker
else
UnZ_Glob.readpos := UnZ_Glob.inbuf'Length;
-- Simulates reading -> no blocking.
-- The buffer is full of "random" data.
-- A correct compressed stream will hit its own end-of-compressed-stream.
-- On a corrupted data we will get a wrong code or a CRC error on the way.
Zip_EOF := True;
end if;
end Process_compressed_end_reached;
procedure Read_buffer is
begin
if full_trace then
Ada.Text_IO.Put ("[Read_buffer...");
end if;
if UnZ_Glob.reachedsize > UnZ_Glob.compsize + 2 then
-- +2: last code is smaller than requested!
Process_compressed_end_reached;
else
begin
Zip.Block_Read (
stream => zip_file,
buffer => UnZ_Glob.inbuf,
actually_read => UnZ_Glob.readpos
);
exception
when others => -- I/O error
Process_compressed_end_reached;
end;
if UnZ_Glob.readpos = 0 then -- No byte at all was read
Process_compressed_end_reached;
end if;
UnZ_Glob.reachedsize :=
UnZ_Glob.reachedsize + Zip.Zip_64_Data_Size_Type (UnZ_Glob.readpos);
UnZ_Glob.readpos := UnZ_Glob.readpos - 1; -- Reason: index of inbuf starts at 0
end if;
UnZ_Glob.inpos := 0;
if full_trace then
Ada.Text_IO.Put_Line ("finished]");
end if;
end Read_buffer;
procedure Read_Byte_no_Decrypt (bt : out Zip.Byte) is
begin
if UnZ_Glob.inpos > UnZ_Glob.readpos then
Read_buffer;
end if;
bt := UnZ_Glob.inbuf (UnZ_Glob.inpos);
UnZ_Glob.inpos := UnZ_Glob.inpos + 1;
end Read_Byte_no_Decrypt;
function Read_Byte_Decrypted return Unsigned_8 is
bt : Zip.Byte;
begin
Read_Byte_no_Decrypt (bt);
Decode (local_crypto_pack, bt);
return bt;
end Read_Byte_Decrypted;
package body Bit_buffer is
B : Unsigned_32;
K : Integer;
procedure Init is
begin
B := 0;
K := 0;
end Init;
procedure Need (n : Natural) is
pragma Inline (Need);
begin
while K < n loop
B := B or Shift_Left (Unsigned_32 (Read_Byte_Decrypted), K);
K := K + 8;
end loop;
end Need;
procedure Dump (n : Natural) is
begin
B := Shift_Right (B, n);
K := K - n;
end Dump;
procedure Dump_to_byte_boundary is
begin
Dump (K mod 8);
end Dump_to_byte_boundary;
function Read_U32 (n : Natural) return Unsigned_32 is
begin
Need (n);
return B and (Shift_Left (1, n) - 1);
end Read_U32;
function Read_inverted (n : Natural) return Integer is
begin
Need (n);
return Integer ((not B) and (Shift_Left (1, n) - 1));
end Read_inverted;
function Read (n : Natural) return Integer is
begin
return Integer (Read_U32 (n));
end Read;
function Read_and_dump (n : Natural) return Integer is
res : Integer;
begin
res := Read (n);
Dump (n);
return res;
end Read_and_dump;
function Read_and_dump_U32 (n : Natural) return Unsigned_32 is
res : Unsigned_32;
begin
res := Read_U32 (n);
Dump (n);
return res;
end Read_and_dump_U32;
end Bit_buffer;
procedure Flush (x : Natural) is
use Zip, Ada.Streams;
begin
if full_trace then
Ada.Text_IO.Put ("[Flush...");
end if;
begin
case write_mode is
when write_to_binary_file =>
Block_Write (Ada.Streams.Stream_IO.Stream (out_bin_file).all, UnZ_Glob.slide (0 .. x - 1));
when write_to_text_file =>
Write_as_Text
(UnZ_IO.out_txt_file, UnZ_Glob.slide (0 .. x - 1), UnZ_IO.last_char);
when write_to_memory =>
for i in 0 .. x - 1 loop
output_memory_access (UnZ_Glob.uncompressed_index) :=
Ada.Streams.Stream_Element (UnZ_Glob.slide (i));
UnZ_Glob.uncompressed_index := UnZ_Glob.uncompressed_index + 1;
end loop;
when write_to_stream =>
Block_Write (output_stream_access.all, UnZ_Glob.slide (0 .. x - 1));
when just_test =>
null;
end case;
exception
when others =>
raise UnZip.Write_Error;
end;
Zip.CRC_Crypto.Update (UnZ_Glob.crc32val, UnZ_Glob.slide (0 .. x - 1));
Process_feedback (Zip_64_Data_Size_Type (x));
if full_trace then
Ada.Text_IO.Put_Line ("finished]");
end if;
end Flush;
procedure Flush_if_full (W : in out Integer; unflushed : in out Boolean) is
begin
if W = wsize then
Flush (wsize);
W := 0;
unflushed := False;
end if;
end Flush_if_full;
procedure Flush_if_full (W : in out Integer) is
begin
if W = wsize then
Flush (wsize);
W := 0;
end if;
end Flush_if_full;
----------------------------------------------------
-- Reproduction of sequences in the output slide. --
----------------------------------------------------
-- Internal:
procedure Adjust_to_Slide (
source : in out Integer;
remain : in out Natural;
part : out Integer;
index : Integer)
is
pragma Inline (Adjust_to_Slide);
begin
source := source mod wsize;
-- source and index are now in 0 .. WSize-1
if source > index then
part := wsize - source;
else
part := wsize - index;
end if;
-- NB: part is in 1..WSize (part cannot be 0)
if part > remain then
part := remain;
end if;
-- Now part <= remain
remain := remain - part;
-- NB: remain cannot be < 0
end Adjust_to_Slide;
procedure Copy_range (source, index : in out Natural; amount : Positive) is
pragma Inline (Copy_range);
begin
if full_trace then
Ada.Text_IO.Put (
"(Copy_range: source=" & Integer'Image (source) &
" index=" & Integer'Image (index) &
" amount=" & Integer'Image (amount));
end if;
if abs (index - source) < amount then
if full_trace and then source < index then
Ada.Text_IO.Put (
"; replicates" &
Integer'Image (amount) & " /" & Integer'Image (index - source) &
" )"
);
-- ...times the range source..index-1
end if;
-- if source >= index, the effect of copy is just like the non-overlapping case
for count in reverse 1 .. amount loop
UnZ_Glob.slide (index) := UnZ_Glob.slide (source);
index := index + 1;
source := source + 1;
end loop;
else -- non-overlapping -> copy slice
UnZ_Glob.slide (index .. index + amount - 1) :=
UnZ_Glob.slide (source .. source + amount - 1);
index := index + amount;
source := source + amount;
end if;
if full_trace then
Ada.Text_IO.Put (')');
end if;
end Copy_range;
-- The copying routines:
procedure Copy (distance, copy_length : Natural; index : in out Natural) is
source, part, remain : Integer;
begin
if some_trace then
Ada.Text_IO.Put_Line (LZ77_dump, "DLE" & Integer'Image (distance) & Integer'Image (copy_length));
end if;
source := index - distance;
remain := copy_length;
loop
Adjust_to_Slide (source, remain, part, index);
Copy_range (source, index, part);
Flush_if_full (index);
exit when remain = 0;
end loop;
end Copy;
procedure Copy_or_zero (
distance, length : Natural;
index : in out Natural;
unflushed : in out Boolean)
is
source, part, remain : Integer;
begin
source := index - distance;
remain := length;
loop
Adjust_to_Slide (source, remain, part, index);
if unflushed and then index <= source then
UnZ_Glob.slide (index .. index + part - 1) := (others => 0);
index := index + part;
source := source + part;
else
Copy_range (source, index, part);
end if;
Flush_if_full (index, unflushed);
exit when remain = 0;
end loop;
end Copy_or_zero;
procedure Delete_output is -- an error has occured (bad compressed data)
begin
if no_trace then -- if there is a trace, we are debugging
case write_mode is -- and want to keep the malformed file
when write_to_binary_file =>
Ada.Streams.Stream_IO.Delete (UnZ_IO.out_bin_file);
when write_to_text_file =>
Ada.Text_IO.Delete (UnZ_IO.out_txt_file);
when write_to_memory | write_to_stream | just_test =>
null; -- Nothing to delete!
end case;
end if;
end Delete_output;
end UnZ_IO;
procedure Init_Decryption (password_for_keys : String; crc_check : Unsigned_32) is
c : Zip.Byte := 0;
t : Unsigned_32;
begin
-- Step 1 - Initializing the encryption keys
Init_Keys (local_crypto_pack, password_for_keys);
-- Step 2 - Decrypting the encryption header. 11 bytes are random,
-- just to shuffle the keys, 1 byte is from the CRC value.
Set_Mode (local_crypto_pack, encrypted);
for i in 1 .. 12 loop
UnZ_IO.Read_Byte_no_Decrypt (c);
Decode (local_crypto_pack, c);
end loop;
t := Zip_Streams.Calendar.Convert (hint.file_timedate);
-- Last byte used to check password; 1/256 probability of success with any password!
if c /= Zip.Byte (Shift_Right (crc_check, 24)) and not
-- Dec. 2012. This is a feature of Info-Zip (crypt.c), not of PKWARE.
-- Since CRC is only known at the end of a one-way stream
-- compression, and cannot be written back, they are using a byte of
-- the time stamp instead. This is NOT documented in PKWARE's appnote.txt v.6.3.3.
(data_descriptor_after_data and c = Zip.Byte (Shift_Right (t, 8) and 16#FF#))
then
raise UnZip.Wrong_password;
end if;
end Init_Decryption;
package body UnZ_Meth is
--------[ Method: Unshrink ]--------
-- Original in Pascal written by Christian Ghisler.
Initial_Code_Size : constant := 9;
Maximum_Code_Size : constant := 13;
Max_Code : constant := 2 ** Maximum_Code_Size;
Max_Stack : constant := 2 ** Maximum_Code_Size;
-- Rest of slide=write buffer =766 bytes
Write_Max : constant := wsize - 3 * (Max_Code - 256) - Max_Stack - 2;
Next_Free : Integer; -- Next free code in trie
Write_Ptr : Integer; -- Pointer to output buffer
Writebuf : Zip.Byte_Buffer (0 .. Write_Max); -- Write buffer
procedure Unshrink_Flush is
use Zip, Ada.Streams, Ada.Streams.Stream_IO;
begin
if full_trace then
Ada.Text_IO.Put ("[Unshrink_Flush]");
end if;
begin
case write_mode is
when write_to_binary_file =>
Block_Write (Stream (UnZ_IO.out_bin_file).all, Writebuf (0 .. Write_Ptr - 1));
when write_to_text_file =>
Zip.Write_as_Text (UnZ_IO.out_txt_file, Writebuf (0 .. Write_Ptr - 1), UnZ_IO.last_char);
when write_to_memory =>
for I in 0 .. Write_Ptr - 1 loop
output_memory_access (UnZ_Glob.uncompressed_index) :=
Stream_Element (Writebuf (I));
UnZ_Glob.uncompressed_index := UnZ_Glob.uncompressed_index + 1;
end loop;
when write_to_stream =>
Block_Write (output_stream_access.all, Writebuf (0 .. Write_Ptr - 1));
when just_test =>
null;
end case;
exception
when others =>
raise UnZip.Write_Error;
end;
Zip.CRC_Crypto.Update (UnZ_Glob.crc32val, Writebuf (0 .. Write_Ptr - 1));
Process_feedback (Zip_64_Data_Size_Type (Write_Ptr));
end Unshrink_Flush;
procedure UD_Write_Byte (B : Zip.Byte) is
begin
Writebuf (Write_Ptr) := B;
Write_Ptr := Write_Ptr + 1;
if Write_Ptr > Write_Max then
Unshrink_Flush;
Write_Ptr := 0;
end if;
end UD_Write_Byte;
procedure Unshrink is
S : Zip.Zip_64_Data_Size_Type := UnZ_Glob.uncompsize;
Last_Incode : Integer;
Last_Outcode : Zip.Byte;
Code_Size : Integer := Initial_Code_Size; -- Actual code size [9 .. 13]
Actual_Max_Code : Integer; -- Max code to be searched for leaf nodes
First_Entry : constant := 257;
Previous_Code : array (First_Entry .. Max_Code) of Integer;
Stored_Literal : array (First_Entry .. Max_Code) of Zip.Byte;
procedure Clear_Leaf_Nodes is
Is_Leaf : array (First_Entry .. Max_Code) of Boolean := (others => True);
Pc : Integer; -- Previous code
begin
if full_trace then
Ada.Text_IO.Put ("[Clear leaf nodes @ pos" &
Zip.Zip_64_Data_Size_Type'Image (UnZ_Glob.uncompsize - S) &
"; old Next_Free =" & Integer'Image (Next_Free));
end if;
for I in First_Entry .. Actual_Max_Code loop
Pc := Previous_Code (I);
if Pc > 256 then
-- Pc is in a tree as well
Is_Leaf (Pc) := False;
end if;
end loop;
-- Build new free list
Pc := -1;
Next_Free := -1;
for I in First_Entry .. Actual_Max_Code loop
-- Either free before, or marked now as leaf
if Previous_Code (I) < 0 or Is_Leaf (I) then
-- Link last item to this item
if Pc = -1 then
Next_Free := I;
else
-- Next free node from Pc is I.
Previous_Code (Pc) := -I;
end if;
Pc := I;
end if;
end loop;
if Pc /= -1 then
-- Last (old or new) free node points to the first "never used".
Previous_Code (Pc) := -(Actual_Max_Code + 1);
end if;
if Next_Free = -1 then
-- Unlikely but possible case:
-- - no previously free or leaf node found, or
-- - table clearing is ordered when the table is still empty.
Next_Free := Actual_Max_Code + 1;
end if;
if full_trace then
Ada.Text_IO.Put ("; new Next_Free =" & Integer'Image (Next_Free) & ']');
end if;
end Clear_Leaf_Nodes;
procedure Attempt_Table_Increase is
Candidate : constant Integer := Next_Free;
begin
if Candidate > Max_Code then
-- This case is supported by PKZip's LZW variant.
-- Table clearing is done only on a special command.
if some_trace then
Ada.Text_IO.Put ("[Table is full]");
end if;
else
if Candidate not in Previous_Code'Range then
raise Zip.Archive_corrupted with "Wrong LZW (Shrink) index";
end if;
Next_Free := -Previous_Code (Candidate);
Actual_Max_Code := Integer'Max (Actual_Max_Code, Next_Free - 1);
-- Next node in free list
Previous_Code (Candidate) := Last_Incode;
Stored_Literal (Candidate) := Last_Outcode;
end if;
end Attempt_Table_Increase;
Incode : Integer; -- Code read in
New_Code : Integer; -- Save new normal code read
Stack : Zip.Byte_Buffer (0 .. Max_Stack); -- Stack for output
Stack_Ptr : Integer := Max_Stack;
-- PKZip's Shrink is a variant of the LZW algorithm in that the
-- compressor controls the code increase and the table clearing.
-- See appnote.txt, section 5.1.
Special_Code : constant := 256;
Code_for_increasing_code_size : constant := 1;
Code_for_clearing_table : constant := 2;
procedure Read_Code is
pragma Inline (Read_Code);
begin
Incode := UnZ_IO.Bit_buffer.Read_and_dump (Code_Size);
end Read_Code;
begin
-- Initialize free codes list
for I in Previous_Code'Range loop
Previous_Code (I) := -(I + 1);
end loop;
--
Stored_Literal := (others => 0);
Stack := (others => 0);
Writebuf := (others => 0);
if UnZ_Glob.compsize = Zip.Zip_64_Data_Size_Type'Last then
-- Compressed Size was not in header!
raise UnZip.Not_supported;
elsif UnZ_Glob.uncompsize = 0 then
return; -- compression of a 0-file with Shrink.pas
end if;
Next_Free := First_Entry;
Actual_Max_Code := First_Entry - 1;
Write_Ptr := 0;
Read_Code;
Last_Incode := Incode;
if Incode not in 0 .. 255 then
raise Zip.Archive_corrupted with "Wrong LZW (Shrink) 1st byte; must be a literal";
end if;
Last_Outcode := Zip.Byte (Incode);
UD_Write_Byte (Last_Outcode);
S := S - 1;
Main_Unshrink_Loop :
while S > 0 and then not Zip_EOF loop
Read_Code;
if Incode = Special_Code then -- Code = 256
Read_Code;
case Incode is
when Code_for_increasing_code_size =>
Code_Size := Code_Size + 1;
if some_trace then
Ada.Text_IO.Put (
"[Increment LZW code size to" & Integer'Image (Code_Size) &
" bits @ pos" & Zip.Zip_64_Data_Size_Type'Image (UnZ_Glob.uncompsize - S) & ']'
);
end if;
if Code_Size > Maximum_Code_Size then
raise Zip.Archive_corrupted with "Wrong LZW (Shrink) code size";
end if;
when Code_for_clearing_table =>
Clear_Leaf_Nodes;
when others =>
raise Zip.Archive_corrupted with
"Wrong LZW (Shrink) special code" & Integer'Image (Incode);
end case;
else -- Normal code (either a literal (< 256), or a tree node (> 256))
New_Code := Incode;
if Incode < 256 then -- Literal (simple character)
Last_Outcode := Zip.Byte (Incode);
UD_Write_Byte (Last_Outcode);
S := S - 1;
else -- Tree node (code > 256)
if Previous_Code (Incode) < 0 then
-- First node is orphan (parent is a free node).
if full_trace then
Ada.Text_IO.Put ("[ Node from stream is orphan ]");
end if;
Stack (Stack_Ptr) := Last_Outcode;
Stack_Ptr := Stack_Ptr - 1;
Incode := Last_Incode;
end if;
while Incode > 256 loop
if Stack_Ptr < Stack'First then
raise Zip.Archive_corrupted with "LZW (Shrink): String stack exhausted";
end if;
if Incode > Max_Code then
raise Zip.Archive_corrupted with "LZW (Shrink): Incode out of range";
end if;
if Previous_Code (Incode) < 0 then
-- Linked node is orphan (parent is a free node).
-- This rare case appears on some data, compressed only by PKZIP.
-- The last PKZIP version known to us that is able to compress
-- with the Shrink algorithm is PKZIP v.1.10, 1990-03-15.
if some_trace then
Ada.Text_IO.Put ("[ Linked node is orphan ]");
end if;
Stack (Stack_Ptr) := Last_Outcode;
Incode := Last_Incode;
else
Stack (Stack_Ptr) := Stored_Literal (Incode);
Incode := Previous_Code (Incode);
end if;
Stack_Ptr := Stack_Ptr - 1;
end loop;
-- NB: Incode cannot be negative (orphan case treated above).
-- It is <= 256 because of the while loop.
-- It is /= 256 because it is set to a Last_Incode value (directly or
-- through Previous_Code) which is either in [0 .. 255] or > 256.
-- So Incode is in [0 .. 255].
Last_Outcode := Zip.Byte (Incode);
UD_Write_Byte (Last_Outcode);
-- Now we output the string in forward order.
for I in Stack_Ptr + 1 .. Max_Stack loop
UD_Write_Byte (Stack (I));
end loop;
S := S - Zip.Zip_64_Data_Size_Type (Max_Stack - Stack_Ptr + 1);
Stack_Ptr := Max_Stack;
end if;
Attempt_Table_Increase;
Last_Incode := New_Code;
end if;
end loop Main_Unshrink_Loop;
if some_trace then
Ada.Text_IO.Put ("[ Unshrink main loop finished ]");
end if;
Unshrink_Flush;
end Unshrink;
--------[ Method: Unreduce ]--------
procedure Unreduce (factor : Reduction_factor) is
-- Original slide limit: 16#4000#
DLE_code : constant := 144;
subtype Symbol_range is Integer range 0 .. 255;
subtype Follower_range is Integer range 0 .. 63; -- Appnote: <= 32 !
Followers : array (Symbol_range, Follower_range) of Symbol_range :=
(others => (others => 0));
Slen : array (Symbol_range) of Follower_range;
-- Bits taken by (x-1) mod 256:
B_Table : constant array (Symbol_range) of Integer :=
(0 => 8,
1 .. 2 => 1,
3 .. 4 => 2,
5 .. 8 => 3,
9 .. 16 => 4,
17 .. 32 => 5,
33 .. 64 => 6,
65 .. 128 => 7,
129 .. 255 => 8);
procedure LoadFollowers is
list_followers : constant Boolean := some_trace;
procedure Show_symbol (S : Symbol_range) is
begin
if S in 32 .. 254 then
Ada.Text_IO.Put (Character'Val (S));
else
Ada.Text_IO.Put ('{' & Symbol_range'Image (S) & '}');
end if;
end Show_symbol;
begin
for X in reverse Symbol_range loop
Slen (X) := UnZ_IO.Bit_buffer.Read_and_dump (6);
if list_followers then
Show_symbol (X);
Ada.Text_IO.Put (" -> (" & Integer'Image (Slen (X)) & ") ");
end if;
for I in 0 .. Slen (X) - 1 loop
Followers (X, I) := UnZ_IO.Bit_buffer.Read_and_dump (8);
if list_followers then
Show_symbol (Followers (X, I));
end if;
end loop;
if list_followers then
Ada.Text_IO.New_Line;
end if;
end loop;
end LoadFollowers;
length,
char_read,
last_char : Integer := 0;
-- ^ some := 0 are useless, just to calm down ObjectAda 7.2.2
S : Zip.Zip_64_Data_Size_Type := UnZ_Glob.uncompsize;
-- number of bytes left to decompress
unflushed : Boolean := True;
maximum_AND_mask : constant Unsigned_32 := Shift_Left (1, 8 - factor) - 1;
procedure Out_byte (b : Zip.Byte) is
begin
S := S - 1;
UnZ_Glob.slide (UnZ_Glob.slide_index) := b;
UnZ_Glob.slide_index := UnZ_Glob.slide_index + 1;
UnZ_IO.Flush_if_full (UnZ_Glob.slide_index, unflushed);
end Out_byte;
V : Unsigned_32 := 0;
type State_type is (normal, length_a, length_b, distance);
state : State_type := normal;
begin
LoadFollowers;
while S > 0 and then not Zip_EOF loop
-- 1/ Probabilistic expansion
if Slen (last_char) = 0 then
-- follower set is empty for this character
char_read := UnZ_IO.Bit_buffer.Read_and_dump (8);
elsif UnZ_IO.Bit_buffer.Read_and_dump (1) = 0 then
char_read := Followers (
last_char,
UnZ_IO.Bit_buffer.Read_and_dump (B_Table (Slen (last_char)))
);
else
char_read := UnZ_IO.Bit_buffer.Read_and_dump (8);
end if;
-- 2/ Expand the resulting Zip.Byte into repeated sequences
case state is
when normal =>
if char_read = DLE_code then
-- >> Next will be a DLE
state := length_a;
else
-- >> A single char
Out_byte (Zip.Byte (char_read));
end if;
when length_a =>
if char_read = 0 then
-- >> DLE_code & 0 -> was just the Zip.Byte coded DLE_code
Out_byte (DLE_code);
state := normal;
else
V := Unsigned_32 (char_read);
length := Integer (V and maximum_AND_mask);
-- The remaining bits of V will be used for the distance
if length = Integer (maximum_AND_mask) then
state := length_b;
-- >> length must be completed before reading distance
else
state := distance;
end if;
end if;
when length_b =>
length := length + char_read;
state := distance;
when distance =>
length := length + 3;
S := S - Zip.Zip_64_Data_Size_Type (length);
UnZ_IO.Copy_or_zero (
distance => char_read + 1 + Integer (Shift_Right (V, 8 - factor) * 2**8),
length => length,
index => UnZ_Glob.slide_index,
unflushed => unflushed
);
state := normal;
end case;
last_char := char_read; -- store character for next iteration
end loop;
UnZ_IO.Flush (UnZ_Glob.slide_index);
end Unreduce;
--------[ Method: Explode ]--------
-- C code by info-zip group, translated to Pascal by Christian Ghisler
-- based on unz51g.zip
use UnZip.Decompress.Huffman;
procedure Get_Tree (L : out Length_array) is
I, K, J, B : Unsigned_32;
N : constant Unsigned_32 := L'Length;
L_Idx : Integer := L'First;
begin
if full_trace then
Ada.Text_IO.Put_Line ("Begin UnZ_Expl.Get_tree");
end if;
I := Unsigned_32 (UnZ_IO.Read_Byte_Decrypted) + 1;
K := 0;
loop
J := Unsigned_32 (UnZ_IO.Read_Byte_Decrypted);
B := (J and 16#0F#) + 1;
J := (J and 16#F0#) / 16 + 1;
if K + J > N then
raise Zip.Archive_corrupted;
end if;
loop
L (L_Idx) := Natural (B);
L_Idx := L_Idx + 1;
K := K + 1;
J := J - 1;
exit when J = 0;
end loop;
I := I - 1;
exit when I = 0;
end loop;
if K /= N then
raise Zip.Archive_corrupted;
end if;
if full_trace then
Ada.Text_IO.Put_Line ("End UnZ_Expl.Get_tree");
end if;
end Get_Tree;
procedure Explode_Lit ( -- method with 3 trees
Needed : Integer;
Tb, Tl, Td : p_Table_list;
Bb, Bl, Bd : Integer
)
is
S : Zip.Zip_64_Data_Size_Type;
E, N, D : Integer;
W : Integer := 0;
Ct : p_HufT_table; -- current table
Ci : Natural; -- current index
unflushed : Boolean := True; -- true while slide not yet unflushed
begin
if full_trace then
Ada.Text_IO.Put_Line ("Begin Explode_lit");
end if;
UnZ_IO.Bit_buffer.Init;
S := UnZ_Glob.uncompsize;
while S > 0 and not Zip_EOF loop
if UnZ_IO.Bit_buffer.Read_and_dump (1) /= 0 then -- 1: Literal
S := S - 1;
Ct := Tb.table;
Ci := UnZ_IO.Bit_buffer.Read_inverted (Bb);
loop
E := Ct (Ci).extra_bits;
exit when E <= 16;
if E = invalid then
raise Zip.Archive_corrupted;
end if;
UnZ_IO.Bit_buffer.Dump (Ct (Ci).bits);
E := E - 16;
Ct := Ct (Ci).next_table;
Ci := UnZ_IO.Bit_buffer.Read_inverted (E);
end loop;
UnZ_IO.Bit_buffer.Dump (Ct (Ci).bits);
UnZ_Glob.slide (W) := Zip.Byte (Ct (Ci).n);
W := W + 1;
UnZ_IO.Flush_if_full (W, unflushed);
else -- 0: Copy
D := UnZ_IO.Bit_buffer.Read_and_dump (Needed);
Ct := Td.table;
Ci := UnZ_IO.Bit_buffer.Read_inverted (Bd);
loop
E := Ct (Ci).extra_bits;
exit when E <= 16;
if E = invalid then
raise Zip.Archive_corrupted;
end if;
UnZ_IO.Bit_buffer.Dump (Ct (Ci).bits);
E := E - 16;
Ct := Ct (Ci).next_table;
Ci := UnZ_IO.Bit_buffer.Read_inverted (E);
end loop;
UnZ_IO.Bit_buffer.Dump (Ct (Ci).bits);
D := D + Ct (Ci).n;
Ct := Tl.table;
Ci := UnZ_IO.Bit_buffer.Read_inverted (Bl);
loop
E := Ct (Ci).extra_bits;
exit when E <= 16;
if E = invalid then
raise Zip.Archive_corrupted;
end if;
UnZ_IO.Bit_buffer.Dump (Ct (Ci).bits);
E := E - 16;
Ct := Ct (Ci).next_table;
Ci := UnZ_IO.Bit_buffer.Read_inverted (E);
end loop;
UnZ_IO.Bit_buffer.Dump (Ct (Ci).bits);
N := Ct (Ci).n;
if E /= 0 then
N := N + UnZ_IO.Bit_buffer.Read_and_dump (8);
end if;
S := S - Zip.Zip_64_Data_Size_Type (N);
UnZ_IO.Copy_or_zero (
distance => D,
length => N,
index => W,
unflushed => unflushed
);
end if;
end loop;
UnZ_IO.Flush (W);
if Zip_EOF then
raise Zip.Archive_corrupted with "End of stream reached";
end if;
if full_trace then
Ada.Text_IO.Put_Line ("End Explode_lit");
end if;
end Explode_Lit;
procedure Explode_Nolit ( -- method with 2 trees
Needed : Integer;
Tl, Td : p_Table_list;
Bl, Bd : Integer
)
is
S : Zip.Zip_64_Data_Size_Type;
E, N, D : Integer;
W : Integer := 0;
Ct : p_HufT_table; -- current table
Ci : Natural; -- current index
unflushed : Boolean := True; -- true while slide not yet unflushed
begin
if full_trace then
Ada.Text_IO.Put_Line ("Begin Explode_nolit");
end if;
UnZ_IO.Bit_buffer.Init;
S := UnZ_Glob.uncompsize;
while S > 0 and not Zip_EOF loop
if UnZ_IO.Bit_buffer.Read_and_dump (1) /= 0 then -- 1: Literal
S := S - 1;
UnZ_Glob.slide (W) :=
Zip.Byte (UnZ_IO.Bit_buffer.Read_and_dump (8));
W := W + 1;
UnZ_IO.Flush_if_full (W, unflushed);
else -- 0: Copy
D := UnZ_IO.Bit_buffer.Read_and_dump (Needed);
Ct := Td.table;
Ci := UnZ_IO.Bit_buffer.Read_inverted (Bd);
loop
E := Ct (Ci).extra_bits;
exit when E <= 16;
if E = invalid then
raise Zip.Archive_corrupted;
end if;
UnZ_IO.Bit_buffer.Dump (Ct (Ci).bits);
E := E - 16;
Ct := Ct (Ci).next_table;
Ci := UnZ_IO.Bit_buffer.Read_inverted (E);
end loop;
UnZ_IO.Bit_buffer.Dump (Ct (Ci).bits);
D := D + Ct (Ci).n;
Ct := Tl.table;
Ci := UnZ_IO.Bit_buffer.Read_inverted (Bl);
loop
E := Ct (Ci).extra_bits;
exit when E <= 16;
if E = invalid then
raise Zip.Archive_corrupted;
end if;
UnZ_IO.Bit_buffer.Dump (Ct (Ci).bits);
E := E - 16;
Ct := Ct (Ci).next_table;
Ci := UnZ_IO.Bit_buffer.Read_inverted (E);
end loop;
UnZ_IO.Bit_buffer.Dump (Ct (Ci).bits);
N := Ct (Ci).n;
if E /= 0 then
N := N + UnZ_IO.Bit_buffer.Read_and_dump (8);
end if;
S := S - Zip.Zip_64_Data_Size_Type (N);
UnZ_IO.Copy_or_zero (
distance => D,
length => N,
index => W,
unflushed => unflushed
);
end if;
end loop;
UnZ_IO.Flush (W);
if Zip_EOF then
raise Zip.Archive_corrupted with "End of stream reached";
end if;
if full_trace then
Ada.Text_IO.Put_Line ("End Explode_nolit");
end if;
end Explode_Nolit;
procedure Explode (literal_tree, slide_8_KB : Boolean) is
Tb, Tl, Td : p_Table_list;
Bb, Bl, Bd : Integer;
L : Length_array (0 .. 255);
huft_incomplete : Boolean;
cp_length_2_trees :
constant Length_array (0 .. 63) :=
(2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17,
18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34,
35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51,
52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65);
cp_length_3_trees :
constant Length_array (0 .. 63) :=
(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18,
19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35,
36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52,
53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66);
cp_dist_4KB :
constant Length_array (0 .. 63) :=
(1, 65, 129, 193, 257, 321, 385, 449, 513, 577, 641, 705,
769, 833, 897, 961, 1025, 1089, 1153, 1217, 1281, 1345, 1409, 1473,
1537, 1601, 1665, 1729, 1793, 1857, 1921, 1985, 2049, 2113, 2177,
2241, 2305, 2369, 2433, 2497, 2561, 2625, 2689, 2753, 2817, 2881,
2945, 3009, 3073, 3137, 3201, 3265, 3329, 3393, 3457, 3521, 3585,
3649, 3713, 3777, 3841, 3905, 3969, 4033);
cp_dist_8KB :
constant Length_array (0 .. 63) :=
(1, 129, 257, 385, 513, 641, 769, 897, 1025, 1153, 1281,
1409, 1537, 1665, 1793, 1921, 2049, 2177, 2305, 2433, 2561, 2689,
2817, 2945, 3073, 3201, 3329, 3457, 3585, 3713, 3841, 3969, 4097,
4225, 4353, 4481, 4609, 4737, 4865, 4993, 5121, 5249, 5377, 5505,
5633, 5761, 5889, 6017, 6145, 6273, 6401, 6529, 6657, 6785, 6913,
7041, 7169, 7297, 7425, 7553, 7681, 7809, 7937, 8065);
extra :
constant Length_array (0 .. 63) := (0 .. 62 => 0, 63 => 8);
begin
Bl := 7;
if UnZ_Glob.compsize > 200000 then
Bd := 8;
else
Bd := 7;
end if;
if literal_tree then
Bb := 9;
Get_Tree (L);
begin
HufT_build (L, 256, empty, empty, Tb, Bb, huft_incomplete);
if huft_incomplete then
HufT_free (Tb);
raise Zip.Archive_corrupted;
end if;
exception
when others =>
raise Zip.Archive_corrupted;
end;
begin
Get_Tree (L (0 .. 63));
exception
when others =>
HufT_free (Tb);
raise Zip.Archive_corrupted;
end;
begin
HufT_build (
L (0 .. 63), 0, cp_length_3_trees, extra, Tl, Bl, huft_incomplete
);
if huft_incomplete then
HufT_free (Tl);
HufT_free (Tb);
raise Zip.Archive_corrupted;
end if;
exception
when others =>
HufT_free (Tb);
raise Zip.Archive_corrupted;
end;
begin
Get_Tree (L (0 .. 63));
exception
when others =>
HufT_free (Tb);
HufT_free (Tl);
raise Zip.Archive_corrupted;
end;
begin
if slide_8_KB then
HufT_build (
L (0 .. 63), 0, cp_dist_8KB, extra, Td, Bd, huft_incomplete
);
if huft_incomplete then
HufT_free (Td);
HufT_free (Tl);
HufT_free (Tb);
raise Zip.Archive_corrupted;
end if;
-- Exploding, method: 8k slide, 3 trees
Explode_Lit (7, Tb, Tl, Td, Bb, Bl, Bd);
else
HufT_build (
L (0 .. 63), 0, cp_dist_4KB, extra, Td, Bd, huft_incomplete
);
if huft_incomplete then
HufT_free (Td);
HufT_free (Tl);
HufT_free (Tb);
raise Zip.Archive_corrupted;
end if;
-- Exploding, method: 4k slide, 3 trees
Explode_Lit (6, Tb, Tl, Td, Bb, Bl, Bd);
end if;
exception
when others =>
HufT_free (Tl);
HufT_free (Tb);
raise Zip.Archive_corrupted;
end;
HufT_free (Td);
HufT_free (Tl);
HufT_free (Tb);
else -- No literal tree
begin
Get_Tree (L (0 .. 63));
exception
when others =>
raise Zip.Archive_corrupted;
end;
begin
HufT_build (
L (0 .. 63), 0, cp_length_2_trees, extra, Tl, Bl, huft_incomplete
);
if huft_incomplete then
HufT_free (Tl);
raise Zip.Archive_corrupted;
end if;
exception
when others =>
raise Zip.Archive_corrupted;
end;
begin
Get_Tree (L (0 .. 63));
exception
when others =>
HufT_free (Tl);
raise Zip.Archive_corrupted;
end;
begin
if slide_8_KB then
HufT_build (
L (0 .. 63), 0, cp_dist_8KB, extra, Td, Bd, huft_incomplete
);
if huft_incomplete then
HufT_free (Td);
HufT_free (Tl);
raise Zip.Archive_corrupted;
end if;
-- Exploding, method: 8k slide, 2 trees
Explode_Nolit (7, Tl, Td, Bl, Bd);
else
HufT_build (
L (0 .. 63), 0, cp_dist_4KB, extra, Td, Bd, huft_incomplete
);
if huft_incomplete then
HufT_free (Td);
HufT_free (Tl);
raise Zip.Archive_corrupted;
end if;
-- Exploding, method: 4k slide, 2 trees
Explode_Nolit (6, Tl, Td, Bl, Bd);
end if;
exception
when others =>
HufT_free (Tl);
raise Zip.Archive_corrupted;
end;
HufT_free (Td);
HufT_free (Tl);
end if;
end Explode;
--------[ Method: Copy stored ]--------
procedure Copy_stored is
size : constant Zip.Zip_64_Data_Size_Type := UnZ_Glob.compsize;
read_in, absorbed : Zip.Zip_64_Data_Size_Type;
begin
absorbed := 0;
if Get_Mode (local_crypto_pack) = encrypted then
absorbed := 12;
end if;
while absorbed < size loop
read_in := size - absorbed;
if read_in > wsize then
read_in := wsize;
end if;
begin
for I in 0 .. read_in - 1 loop
UnZ_Glob.slide (Natural (I)) := UnZ_IO.Read_Byte_Decrypted;
end loop;
exception
when others =>
raise Zip.Archive_corrupted with
"End of stream reached (format: Store)";
end;
begin
UnZ_IO.Flush (Natural (read_in)); -- Takes care of CRC too
exception
when User_abort =>
raise;
when others =>
raise UnZip.Write_Error;
end;
absorbed := absorbed + read_in;
end loop;
end Copy_stored;
--------[ Method: Inflate ]--------
lt_count, dl_count,
lt_count_0, dl_count_0,
lt_count_dyn, dl_count_dyn,
lt_count_fix, dl_count_fix : Long_Integer := 0; -- Statistics of LZ codes per block
procedure Inflate_Codes (Tl, Td : p_Table_list; Bl, Bd : Integer) is
CT : p_HufT_table; -- current table
CT_idx : Natural; -- current table's index
length : Natural;
E : Integer; -- table entry flag/number of extra bits
W : Integer := UnZ_Glob.slide_index; -- more local variable for slide index
literal : Zip.Byte;
begin
if some_trace then
lt_count_0 := lt_count;
dl_count_0 := dl_count;
Ada.Text_IO.Put_Line ("Begin Inflate_codes");
end if;
-- inflate the coded data
main_loop :
while not Zip_EOF loop
if Tl = null then
raise Zip.Archive_corrupted with
"Null table list (on data decoding, Huffman tree for literals or LZ lengths)";
end if;
CT := Tl.table;
CT_idx := UnZ_IO.Bit_buffer.Read (Bl);
loop
E := CT (CT_idx).extra_bits;
exit when E <= 16;
if E = invalid then
raise Zip.Archive_corrupted;
end if;
-- then it's a literal
UnZ_IO.Bit_buffer.Dump (CT (CT_idx).bits);
E := E - 16;
CT := CT (CT_idx).next_table;
CT_idx := UnZ_IO.Bit_buffer.Read (E);
end loop;
UnZ_IO.Bit_buffer.Dump (CT (CT_idx).bits);
case E is
when 16 => -- CT(CT_idx).N is a Literal (code 0 .. 255)
literal := Zip.Byte (CT (CT_idx).n);
if some_trace then
lt_count := lt_count + 1;
Ada.Text_IO.Put (LZ77_dump, "Lit" & Zip.Byte'Image (literal));
if literal in 32 .. 126 then
Ada.Text_IO.Put (LZ77_dump, " '" & Character'Val (literal) & ''');
end if;
Ada.Text_IO.New_Line (LZ77_dump);
end if;
UnZ_Glob.slide (W) := literal;
W := W + 1;
UnZ_IO.Flush_if_full (W);
when 15 => -- End of block (EOB, code 256)
if full_trace then
Ada.Text_IO.Put_Line ("Exit Inflate_codes, e=15 -> EOB");
end if;
exit main_loop;
when others => -- We have a length/distance code
if some_trace then
dl_count := dl_count + 1;
end if;
-- Get length of block to copy:
length := CT (CT_idx).n + UnZ_IO.Bit_buffer.Read_and_dump (E);
-- Decode distance of block to copy:
if Td = null then
raise Zip.Archive_corrupted with
"Null table list (on data decoding, Huffman tree for LZ distances)";
end if;
CT := Td.table;
CT_idx := UnZ_IO.Bit_buffer.Read (Bd);
loop
E := CT (CT_idx).extra_bits;
exit when E <= 16;
if E = invalid then
raise Zip.Archive_corrupted;
end if;
UnZ_IO.Bit_buffer.Dump (CT (CT_idx).bits);
E := E - 16;
CT := CT (CT_idx).next_table;
CT_idx := UnZ_IO.Bit_buffer.Read (E);
end loop;
UnZ_IO.Bit_buffer.Dump (CT (CT_idx).bits);
UnZ_IO.Copy (
distance => CT (CT_idx).n + UnZ_IO.Bit_buffer.Read_and_dump (E),
copy_length => length,
index => W
);
end case;
end loop main_loop;
UnZ_Glob.slide_index := W;
if some_trace then
Ada.Text_IO.Put_Line ("End Inflate_codes; " &
Long_Integer'Image (lt_count - lt_count_0) & " literals," &
Long_Integer'Image (dl_count - dl_count_0) & " DL codes," &
Long_Integer'Image (dl_count + lt_count - lt_count_0 - dl_count_0) & " in total");
end if;
end Inflate_Codes;
procedure Inflate_stored_block is -- Actually, nothing to inflate
N : Integer;
begin
UnZ_IO.Bit_buffer.Dump_to_byte_boundary;
-- Get the block length and its complement
N := UnZ_IO.Bit_buffer.Read_and_dump (16);
if some_trace then
Ada.Text_IO.Put_Line ("Begin Inflate_stored_block, bytes stored: " & Integer'Image (N));
end if;
if N /= Integer (
(not UnZ_IO.Bit_buffer.Read_and_dump_U32 (16))
and 16#ffff#)
then
raise Zip.Archive_corrupted;
end if;
while N > 0 and then not Zip_EOF loop
-- Read and output the non-compressed data
N := N - 1;
UnZ_Glob.slide (UnZ_Glob.slide_index) :=
Zip.Byte (UnZ_IO.Bit_buffer.Read_and_dump (8));
UnZ_Glob.slide_index := UnZ_Glob.slide_index + 1;
UnZ_IO.Flush_if_full (UnZ_Glob.slide_index);
end loop;
if some_trace then
Ada.Text_IO.Put_Line ("End Inflate_stored_block");
end if;
end Inflate_stored_block;
-- Copy lengths for literal codes 257..285
copy_lengths_literal : Length_array (0 .. 30) :=
(3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 15, 17, 19, 23, 27, 31,
35, 43, 51, 59, 67, 83, 99, 115, 131, 163, 195, 227, 258, 0, 0);
-- Extra bits for literal codes 257..285
extra_bits_literal : Length_array (0 .. 30) :=
(0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 2, 2, 2, 2,
3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 5, 5, 0, invalid, invalid);
-- Copy offsets for distance codes 0..29 (30..31: deflate_e)
copy_offset_distance : constant Length_array (0 .. 31) :=
(1, 2, 3, 4, 5, 7, 9, 13, 17, 25, 33, 49, 65, 97, 129, 193,
257, 385, 513, 769, 1025, 1537, 2049, 3073, 4097, 6145,
8193, 12289, 16385, 24577, 32769, 49153);
-- Extra bits for distance codes
extra_bits_distance : constant Length_array (0 .. 31) :=
(0, 0, 0, 0, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6,
7, 7, 8, 8, 9, 9, 10, 10, 11, 11, 12, 12, 13, 13, 14, 14);
max_dist : Integer := 29; -- changed to 31 for deflate_e
length_list_for_fixed_block_literals : constant Length_array (0 .. 287) :=
(0 .. 143 => 8, 144 .. 255 => 9, 256 .. 279 => 7, 280 .. 287 => 8);
procedure Inflate_fixed_block is
Tl, -- literal/length code table
Td : p_Table_list; -- distance code table
Bl, Bd : Integer; -- lookup bits for tl/bd
huft_incomplete : Boolean;
begin
if some_trace then
Ada.Text_IO.Put_Line ("Begin Inflate_fixed_block");
end if;
-- Make a complete, but wrong [why ?] code set (see Appnote: 5.5.2, RFC 1951: 3.2.6)
Bl := 7;
HufT_build (
length_list_for_fixed_block_literals, 257, copy_lengths_literal,
extra_bits_literal, Tl, Bl, huft_incomplete
);
-- Make an incomplete code set (see Appnote: 5.5.2, RFC 1951: 3.2.6)
Bd := 5;
begin
HufT_build (
(0 .. max_dist => 5), 0,
copy_offset_distance, extra_bits_distance,
Td, Bd, huft_incomplete
);
if huft_incomplete then
if full_trace then
Ada.Text_IO.Put_Line (
"td is incomplete, pointer=null: " &
Boolean'Image (Td = null)
);
end if;
end if;
exception
when huft_out_of_memory | huft_error =>
HufT_free (Tl);
raise Zip.Archive_corrupted;
end;
-- Decompress the block's data, until an end-of-block code.
Inflate_Codes (Tl, Td, Bl, Bd);
-- Done with this block, free resources.
HufT_free (Tl);
HufT_free (Td);
if some_trace then
Ada.Text_IO.Put_Line ("End Inflate_fixed_block");
lt_count_fix := lt_count_fix + (lt_count - lt_count_0);
dl_count_fix := dl_count_fix + (dl_count - dl_count_0);
end if;
end Inflate_fixed_block;
bit_order_for_dynamic_block : constant array (0 .. 18) of Natural :=
(16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15);
procedure Inflate_dynamic_block is
Lbits : constant := 9;
Dbits : constant := 6;
current_length : Natural;
defined, number_of_lengths : Natural;
Tl, -- literal/length code tables
Td : p_Table_list; -- distance code tables
CT : p_HufT_table; -- current table
CT_idx : Natural; -- current table's index
Bl, Bd : Integer; -- lookup bits for tl/bd
Nb : Natural; -- number of bit length codes
Nl : Natural; -- number of literal length codes
Nd : Natural; -- number of distance codes
-- literal/length and distance code lengths
Ll : Length_array (0 .. 288 + 32 - 1) := (others => 0);
huft_incomplete : Boolean;
procedure Repeat_length_code (amount : Natural) is
begin
if defined + amount > number_of_lengths then
raise Zip.Archive_corrupted;
end if;
for c in reverse 1 .. amount loop
Ll (defined) := current_length;
defined := defined + 1;
end loop;
end Repeat_length_code;
begin
if some_trace then
Ada.Text_IO.Put_Line ("Begin Inflate_dynamic_block");
end if;
-- Read in table lengths
Nl := 257 + UnZ_IO.Bit_buffer.Read_and_dump (5);
Nd := 1 + UnZ_IO.Bit_buffer.Read_and_dump (5);
Nb := 4 + UnZ_IO.Bit_buffer.Read_and_dump (4);
if Nl > 288 or else Nd > 32 then
raise Zip.Archive_corrupted;
end if;
-- Read in bit-length-code lengths for decoding the compression structure.
-- The rest, Ll( Bit_Order( Nb .. 18 ) ), is already = 0
for J in 0 .. Nb - 1 loop
Ll (bit_order_for_dynamic_block (J)) := UnZ_IO.Bit_buffer.Read_and_dump (3);
end loop;
-- Build decoding table for trees--single level, 7 bit lookup
Bl := 7;
begin
HufT_build (
Ll (0 .. 18), 19, empty, empty, Tl, Bl, huft_incomplete
);
if huft_incomplete then
HufT_free (Tl);
raise Zip.Archive_corrupted with "Incomplete code set for compression structure";
end if;
exception
when others =>
raise Zip.Archive_corrupted with "Error when building tables for compression structure";
end;
-- Read in the compression structure: literal and distance code lengths
number_of_lengths := Nl + Nd;
defined := 0;
current_length := 0;
while defined < number_of_lengths loop
if Tl = null then
raise Zip.Archive_corrupted with
"Null table list (on compression structure)";
end if;
CT := Tl.table;
CT_idx := UnZ_IO.Bit_buffer.Read (Bl);
UnZ_IO.Bit_buffer.Dump (CT (CT_idx).bits);
case CT (CT_idx).n is
when 0 .. 15 => -- Length of code for symbol of index 'defined', in bits (0..15)
current_length := CT (CT_idx).n;
Ll (defined) := current_length;
defined := defined + 1;
when 16 => -- 16 means: repeat last bit length 3 to 6 times
if defined = 0 then
-- Nothing in the Ll array has been defined so far. Then, current_length is
-- (theoretically) undefined and cannot be repeated.
-- This unspecified case is treated as an error by zlib's inflate.c.
raise Zip.Archive_corrupted with
"Illegal data for compression structure (repeat an undefined code length)";
end if;
Repeat_length_code (3 + UnZ_IO.Bit_buffer.Read_and_dump (2));
when 17 => -- 17 means: the next 3 to 10 symbols' codes have zero bit lengths
current_length := 0;
Repeat_length_code (3 + UnZ_IO.Bit_buffer.Read_and_dump (3));
when 18 => -- 18 means: the next 11 to 138 symbols' codes have zero bit lengths
current_length := 0;
Repeat_length_code (11 + UnZ_IO.Bit_buffer.Read_and_dump (7));
when others => -- Shouldn't occur if this tree is correct
raise Zip.Archive_corrupted with
"Illegal data for compression structure (values should be in the range 0 .. 18): "
& Integer'Image (CT (CT_idx).n);
end case;
end loop;
-- Free the Huffman tree that was used for decoding the compression
-- structure, which is contained now in Ll.
HufT_free (Tl);
if Ll (256) = 0 then
-- No code length for the End-Of-Block symbol, implies infinite stream!
-- This case is unspecified but obviously we must stop here.
raise Zip.Archive_corrupted with "No code length for End-Of-Block symbol #256";
end if;
-- Build the decoding tables for literal/length codes
Bl := Lbits;
begin
HufT_build (
Ll (0 .. Nl - 1), 257,
copy_lengths_literal, extra_bits_literal,
Tl, Bl, huft_incomplete
);
if huft_incomplete then
HufT_free (Tl);
raise Zip.Archive_corrupted with "Incomplete code set for literals/lengths";
end if;
exception
when others =>
raise Zip.Archive_corrupted with "Error when building tables for literals/lengths";
end;
-- Build the decoding tables for distance codes
Bd := Dbits;
begin
HufT_build (
Ll (Nl .. Nl + Nd - 1), 0,
copy_offset_distance, extra_bits_distance,
Td, Bd, huft_incomplete
);
if huft_incomplete then
if deflate_strict then
raise Zip.Archive_corrupted with "Incomplete code set for distances";
elsif some_trace then -- not deflate_strict => don't stop
Ada.Text_IO.Put_Line ("Huffman tree incomplete - PKZIP 1.93a bug workaround");
end if;
end if;
exception
when huft_out_of_memory | huft_error =>
HufT_free (Tl);
raise Zip.Archive_corrupted with "Error when building tables for distances";
end;
-- Decompress the block's data, until an end-of-block code.
Inflate_Codes (Tl, Td, Bl, Bd);
-- Done with this block, free resources.
HufT_free (Tl);
HufT_free (Td);
if some_trace then
Ada.Text_IO.Put_Line ("End Inflate_dynamic_block");
lt_count_dyn := lt_count_dyn + (lt_count - lt_count_0);
dl_count_dyn := dl_count_dyn + (dl_count - dl_count_0);
end if;
end Inflate_dynamic_block;
procedure Inflate_Block (last_block : out Boolean; fix, dyn : in out Long_Integer) is
begin
last_block := Boolean'Val (UnZ_IO.Bit_buffer.Read_and_dump (1));
case UnZ_IO.Bit_buffer.Read_and_dump (2) is -- Block type = 0, 1, 2, 3
when 0 => Inflate_stored_block;
when 1 => Inflate_fixed_block;
fix := fix + 1;
when 2 => Inflate_dynamic_block;
dyn := dyn + 1;
when others => raise Zip.Archive_corrupted with "Inflate: Bad block type (3)";
end case;
end Inflate_Block;
procedure Inflate is
is_last_block : Boolean;
blocks, blocks_fix, blocks_dyn : Long_Integer := 0;
begin
if deflate_e_mode then
copy_lengths_literal (28) := 3; -- instead of 258
extra_bits_literal (28) := 16; -- instead of 0
max_dist := 31;
end if;
loop
blocks := blocks + 1;
Inflate_Block (is_last_block, blocks_fix, blocks_dyn);
exit when is_last_block;
end loop;
UnZ_IO.Flush (UnZ_Glob.slide_index);
UnZ_Glob.slide_index := 0;
if some_trace then
Ada.Text_IO.Put_Line (
"# blocks:" & Long_Integer'Image (blocks) &
"; fixed:" & Long_Integer'Image (blocks_fix) &
"; dynamic:" & Long_Integer'Image (blocks_dyn));
if blocks_fix > 0 then
Ada.Text_IO.Put_Line (
"Averages per fixed block: literals:" & Long_Integer'Image (lt_count_fix / blocks_fix) &
"; DL codes:" & Long_Integer'Image (dl_count_fix / blocks_fix) &
"; all codes:" & Long_Integer'Image ((lt_count_fix + dl_count_fix) / blocks_fix));
end if;
if blocks_dyn > 0 then
Ada.Text_IO.Put_Line (
"Averages per dynamic block: literals:" & Long_Integer'Image (lt_count_dyn / blocks_dyn) &
"; DL codes:" & Long_Integer'Image (dl_count_dyn / blocks_dyn) &
"; all codes:" & Long_Integer'Image ((lt_count_dyn + dl_count_dyn) / blocks_dyn));
end if;
end if;
end Inflate;
procedure Write_Single_Byte (b : Unsigned_8) with Inline is
begin
UnZ_Glob.slide (UnZ_Glob.slide_index) := b;
UnZ_Glob.slide_index := UnZ_Glob.slide_index + 1;
UnZ_IO.Flush_if_full (UnZ_Glob.slide_index);
end Write_Single_Byte;
--------[ Method: BZip2 ]--------
procedure Bunzip2 is
package My_BZip2 is new BZip2.Decoding
(Read_Byte => UnZ_IO.Read_Byte_Decrypted,
Write_Byte => Write_Single_Byte,
check_CRC => False); -- CRC check is already done by UnZ_IO
begin
My_BZip2.Decompress;
UnZ_IO.Flush (UnZ_Glob.slide_index);
exception
when E : My_BZip2.bad_header_magic | My_BZip2.bad_block_magic | My_BZip2.data_error =>
raise Zip.Archive_corrupted with
"BZip2 error: " & Exception_Name (E) & " - " & Exception_Message (E);
when E : My_BZip2.randomized_not_yet_implemented =>
raise UnZip.Unsupported_method with
"BZip2: " & Exception_Name (E) & " - " & Exception_Message (E);
end Bunzip2;
--------[ Method: LZMA ]--------
procedure LZMA_Decode is
package My_LZMA_Decoding is new LZMA.Decoding (UnZ_IO.Read_Byte_Decrypted, Write_Single_Byte);
b3, b4 : Unsigned_8;
begin
b3 := UnZ_IO.Read_Byte_Decrypted; -- LZMA SDK major version (e.g.: 9)
b3 := UnZ_IO.Read_Byte_Decrypted; -- LZMA SDK minor version (e.g.: 20)
b3 := UnZ_IO.Read_Byte_Decrypted; -- LZMA properties size low byte
b4 := UnZ_IO.Read_Byte_Decrypted; -- LZMA properties size high byte
if Natural (b3) + 256 * Natural (b4) /= 5 then
raise Zip.Archive_corrupted with "Unexpected LZMA properties block size";
end if;
My_LZMA_Decoding.Decompress
((has_size => False, -- Data size is not part of the LZMA header.
given_size => LZMA.Data_Bytes_Count (UnZ_Glob.uncompsize),
marker_expected => explode_slide_8KB_LZMA_EOS, -- End-Of-Stream marker?
fail_on_bad_range_code => True));
UnZ_IO.Flush (UnZ_Glob.slide_index);
exception
when E : My_LZMA_Decoding.LZMA_Error =>
raise Zip.Archive_corrupted with
"LZMA error: " & Exception_Name (E) & " - " & Exception_Message (E);
end LZMA_Decode;
end UnZ_Meth;
procedure Process_descriptor (dd : out Zip.Headers.Data_Descriptor) is
start : Integer;
b : Unsigned_8;
dd_buffer : Zip.Byte_Buffer (1 .. 30);
begin
UnZ_IO.Bit_buffer.Dump_to_byte_boundary;
Set_Mode (local_crypto_pack, clear); -- We are after compressed data, switch off decryption.
b := UnZ_IO.Read_Byte_Decrypted;
if b = 75 then -- 'K' ('P' is before, this is a Java/JAR bug!)
dd_buffer (1) := 80;
dd_buffer (2) := 75;
start := 3;
else
dd_buffer (1) := b; -- hopefully = 80 (will be checked)
start := 2;
end if;
for i in start .. 16 loop
dd_buffer (i) := UnZ_IO.Read_Byte_Decrypted;
end loop;
Zip.Headers.Copy_and_Check (dd_buffer, dd);
exception
when Zip.Headers.bad_data_descriptor =>
raise Zip.Archive_corrupted;
end Process_descriptor;
work_index : Zip_Streams.ZS_Index_Type;
use Zip, UnZ_Meth, Ada.Strings.Unbounded;
begin -- Decompress_Data
if some_trace then
Ada.Text_IO.Create (LZ77_dump, Ada.Text_IO.Out_File, "dump.lz77");
end if;
output_memory_access := null;
-- ^ this is an 'out' parameter, we have to set it anyway
case write_mode is
when write_to_binary_file =>
Ada.Streams.Stream_IO.Create (UnZ_IO.out_bin_file, Ada.Streams.Stream_IO.Out_File, output_file_name,
Form => To_String (Zip_Streams.Form_For_IO_Open_and_Create));
when write_to_text_file =>
Ada.Text_IO.Create (UnZ_IO.out_txt_file, Ada.Text_IO.Out_File, output_file_name,
Form => To_String (Zip_Streams.Form_For_IO_Open_and_Create));
when write_to_memory =>
output_memory_access := new
Ada.Streams.Stream_Element_Array (
1 .. Ada.Streams.Stream_Element_Offset (hint.dd.uncompressed_size)
);
UnZ_Glob.uncompressed_index := output_memory_access'First;
when write_to_stream | just_test =>
null;
end case;
UnZ_Glob.compsize := hint.dd.compressed_size;
UnZ_Glob.uncompsize := hint.dd.uncompressed_size;
UnZ_IO.Init_Buffers;
if is_encrypted then
Set_Mode (local_crypto_pack, encrypted);
work_index := Zip_Streams.Index (zip_file);
password_passes : for pass in 1 .. tolerance_wrong_password loop
begin
Init_Decryption (To_String (password), hint.dd.crc_32);
exit password_passes; -- the current password fits, then go on!
exception
when Wrong_password =>
if pass = tolerance_wrong_password then
raise;
elsif get_new_password /= null then
get_new_password (password); -- ask for a new one
end if;
end;
-- Go back to data beginning:
begin
Zip_Streams.Set_Index (zip_file, work_index);
exception
when others =>
raise UnZip.Read_Error with "Failure after password interaction";
end;
UnZ_IO.Init_Buffers;
end loop password_passes;
else
Set_Mode (local_crypto_pack, clear);
end if;
-- UnZip correct type
begin
case format is
when store => Copy_stored;
when shrink => Unshrink;
when Reduce_Format => Unreduce (1 + Reduce_Format'Pos (format) - Reduce_Format'Pos (reduce_1));
when implode =>
UnZ_Meth.Explode (explode_literal_tree, explode_slide_8KB_LZMA_EOS);
when deflate | deflate_e =>
UnZ_Meth.deflate_e_mode := format = deflate_e;
UnZ_Meth.Inflate;
when Zip.bzip2_meth => UnZ_Meth.Bunzip2;
when Zip.lzma_meth => UnZ_Meth.LZMA_Decode;
when others =>
raise Unsupported_method with
"Format/method " & Image (format) &
" not supported for decompression";
end case;
exception
when others =>
UnZ_IO.Delete_output;
raise;
end;
UnZ_Glob.crc32val := Zip.CRC_Crypto.Final (UnZ_Glob.crc32val);
-- Decompression done !
if data_descriptor_after_data then -- Sizes and CRC at the end
declare
memo_uncomp_size : constant Zip.Zip_64_Data_Size_Type := hint.dd.uncompressed_size;
begin
Process_descriptor (hint.dd); -- CRC is for checking; sizes are for informing user
if memo_uncomp_size < Zip_64_Data_Size_Type (Zip_32_Data_Size_Type'Last) and then --
memo_uncomp_size /= hint.dd.uncompressed_size
then
UnZ_IO.Delete_output;
raise Uncompressed_Size_Error
with "Uncompressed size mismatch: in catalogue:" & memo_uncomp_size'Image &
"; in post-data data descriptor:" & hint.dd.uncompressed_size'Image;
end if;
end;
end if;
if hint.dd.crc_32 /= UnZ_Glob.crc32val then
UnZ_IO.Delete_output;
raise CRC_Error with
"CRC stored in archive: " & Hexadecimal (hint.dd.crc_32) &
"; CRC computed now: " & Hexadecimal (UnZ_Glob.crc32val);
end if;
case write_mode is
when write_to_binary_file =>
Ada.Streams.Stream_IO.Close (UnZ_IO.out_bin_file);
when write_to_text_file =>
Ada.Text_IO.Close (UnZ_IO.out_txt_file);
when write_to_memory | write_to_stream | just_test =>
null; -- Nothing to close!
end case;
if some_trace then
Ada.Text_IO.Close (LZ77_dump);
end if;
exception
when others => -- close the file in case of an error, if not yet closed
case write_mode is -- or deleted
when write_to_binary_file =>
if Ada.Streams.Stream_IO.Is_Open (UnZ_IO.out_bin_file) then
Ada.Streams.Stream_IO.Close (UnZ_IO.out_bin_file);
end if;
when write_to_text_file =>
if Ada.Text_IO.Is_Open (UnZ_IO.out_txt_file) then
Ada.Text_IO.Close (UnZ_IO.out_txt_file);
end if;
when write_to_memory | write_to_stream | just_test =>
null; -- Nothing to close!
end case;
raise;
end Decompress_Data;
end UnZip.Decompress;
Zip-Ada: Ada library for zip archive files (.zip).
Ada programming.
Some news about Zip-Ada and other Ada projects
on Gautier's blog.
