Source file : unzip-decompress.adb
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;
format : PKZip_method;
mode : Write_mode;
output_file_name : String; -- relevant only if mode = write_to_file
output_memory_access : out p_Stream_Element_Array; -- \ = write_to_memory
output_stream_access : p_Stream; -- \ = write_to_stream
feedback : Zip.Feedback_proc;
explode_literal_tree : Boolean;
explode_slide_8KB_LZMA_EOS : Boolean;
data_descriptor_after_data : Boolean;
is_encrypted : Boolean;
password : in out Unbounded_String;
get_new_password : Get_password_proc;
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 KB)
-- I/O Buffers: Size of sliding dictionary and output buffer
wsize : constant:= 16#10000#; -- (orig: 16#8000# B = 32 KB)
----------------------------------------------------------------------------
-- 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 : UnZip.File_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, 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: File_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_Exception(Zip.Archive_corrupted'Identity,
"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 and we hope for a wrong code or a CRC error
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.BlockRead(
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 + UnZip.File_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, UnZip, Ada.Streams;
begin
if full_trace then
Ada.Text_IO.Put("[Flush...");
end if;
begin
case mode is
when write_to_binary_file =>
BlockWrite(Ada.Streams.Stream_IO.Stream(out_bin_file).all, UnZ_Glob.slide(0..x-1));
when write_to_text_file =>
Zip.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 =>
BlockWrite(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(File_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, 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(length));
end if;
source:= index - distance;
remain:= 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 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: 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);
-- 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).
-- 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 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.
Max_Code : constant := 8192;
Max_Stack : constant := 8192;
Initial_Code_Size : constant := 9;
Maximum_Code_Size : constant := 13;
First_Entry : constant := 257;
-- Rest of slide=write buffer =766 bytes
Write_Max : constant := wsize-3*(Max_Code-256)-Max_Stack-2;
Previous_Code: array ( First_Entry .. Max_Code ) of Integer;
Actual_Code : array ( First_Entry .. Max_Code ) of Zip.Byte;
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, UnZip, Ada.Streams, Ada.Streams.Stream_IO;
begin
if full_trace then
Ada.Text_IO.Put("[Unshrink_Flush]");
end if;
begin
case mode is
when write_to_binary_file =>
BlockWrite(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 =>
BlockWrite(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(File_size_type(Write_Ptr));
end Unshrink_Flush;
procedure 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 Write_Byte;
procedure Clear_Leaf_Nodes is
Pc : Integer; -- previous code
Act_Max_Code : Integer; -- max code to be searched for leaf nodes
begin
Act_Max_Code := Next_Free - 1;
for I in First_Entry .. Act_Max_Code loop
Previous_Code( I ):=
Integer( Unsigned_32( Previous_Code(I) ) or 16#8000#);
end loop;
for I in First_Entry .. Act_Max_Code loop
Pc:= Previous_Code(I) mod 16#8000#;
if Pc > 256 then
Previous_Code(Pc):= Previous_Code(Pc) mod 16#8000#;
end if;
end loop;
-- Build new free list
Pc := - 1;
Next_Free := - 1;
for I in First_Entry .. Act_Max_Code loop
-- Either free before or marked now
if (Unsigned_32( Previous_Code(I) ) and 16#C000#) /= 0 then
-- Link last item to this item
if Pc = -1 then
Next_Free := I;
else
Previous_Code( Pc ) := -I;
end if;
Pc := I;
end if;
end loop;
if Pc /= - 1 then
Previous_Code ( Pc ) := - Act_Max_Code - 1;
end if;
end Clear_Leaf_Nodes;
procedure Unshrink is
Incode : Integer; -- Code read in
Last_Incode : Integer;
Last_Outcode: Zip.Byte;
Code_Size : Integer:= Initial_Code_Size; -- Actual code size (9..13)
Stack : Zip.Byte_Buffer ( 0..Max_Stack ); -- Stack for output
Stack_Ptr : Integer:= Max_Stack;
New_Code : Integer; -- Save new normal code read
Code_for_Special : constant:= 256;
Code_Increase_size: constant:= 1;
Code_Clear_table : constant:= 2;
S: UnZip.File_size_type:= UnZ_Glob.uncompsize;
-- Fix Jan-2009: replaces a remaining bits counter as Unsigned_*32*...
procedure Read_Code is
pragma Inline(Read_Code);
begin
Incode := UnZ_IO.Bit_buffer.Read_and_dump( Code_Size );
end Read_Code;
begin
Previous_Code:= (others=> 0);
Actual_Code := (others=> 0);
Stack := (others=> 0);
Writebuf := (others=> 0);
if UnZ_Glob.compsize = File_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;
-- initialize free codes list
for I in Previous_Code'Range loop
Previous_Code(I) := - (I+1);
end loop;
Next_Free := First_Entry;
Write_Ptr := 0;
Read_Code;
Last_Incode := Incode;
if Incode not in 0 .. 255 then
Raise_Exception(Zip.Archive_corrupted'Identity, "Wrong LZW (Shrink) 1st byte");
end if;
Last_Outcode := Zip.Byte( Incode );
Write_Byte ( Last_Outcode );
S:= S - 1;
while S > 0 and then not Zip_EOF loop
Read_Code;
if Incode = Code_for_Special then
Read_Code;
case Incode is
when Code_Increase_size =>
Code_Size:= Code_Size + 1;
if some_trace then
Ada.Text_IO.Put(
"[LZW code size ->" & Integer'Image(Code_Size) & ']'
);
end if;
if Code_Size > Maximum_Code_Size then
Raise_Exception(Zip.Archive_corrupted'Identity, "Wrong LZW (Shrink) code size");
end if;
when Code_Clear_table =>
Clear_Leaf_Nodes;
when others =>
Raise_Exception(Zip.Archive_corrupted'Identity,
"Wrong LZW (Shrink) special code" & Integer'Image(Incode));
end case;
else -- Normal code
New_Code := Incode;
if Incode < 256 then -- Simple char
Last_Outcode := Zip.Byte( Incode );
Write_Byte ( Last_Outcode );
S:= S - 1;
else
if Previous_Code( Incode ) < 0 then
Stack( Stack_Ptr ):= Last_Outcode;
Stack_Ptr:= Stack_Ptr -1;
Incode := Last_Incode;
end if;
while Incode > 256 loop
-- Test added 11-Dec-2007 for situations happening on corrupt files:
if Stack_Ptr < Stack'First or
Incode > Actual_Code'Last
then
raise Zip.Archive_corrupted;
end if;
Stack( Stack_Ptr ):= Actual_Code( Incode );
Stack_Ptr:= Stack_Ptr -1;
Incode := Previous_Code( Incode );
end loop;
Last_Outcode := Zip.Byte( Incode mod 256 );
Write_Byte( Last_Outcode );
for I in Stack_Ptr+1 .. Max_Stack loop
Write_Byte( Stack( I ) );
end loop;
S:= S - UnZip.File_size_type(Max_Stack - Stack_Ptr + 1);
Stack_Ptr := Max_Stack;
end if;
Incode := Next_Free;
if Incode <= Max_Code then
if Incode not in Previous_Code'Range then
Raise_Exception(Zip.Archive_corrupted'Identity, "Wrong LZW (Shrink) index");
end if;
Next_Free := - Previous_Code( Incode );
-- Next node in free list
Previous_Code( Incode ) := Last_Incode;
Actual_Code ( Incode ) := Last_Outcode;
end if;
Last_Incode := New_Code;
end if;
end 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: UnZip.File_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 - UnZip.File_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 : Unsigned_32;
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 - Unsigned_32(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_Exception(Zip.Archive_corrupted'Identity, "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 : Unsigned_32;
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 - Unsigned_32(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_Exception(Zip.Archive_corrupted'Identity, "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 UnZip.File_size_type:= UnZ_Glob.compsize;
read_in, absorbed : UnZip.File_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_Exception(Zip.Archive_corrupted'Identity,
"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_Exception(Zip.Archive_corrupted'Identity,
"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_Exception(Zip.Archive_corrupted'Identity,
"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),
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_Exception(Zip.Archive_corrupted'Identity, "Incomplete code set for compression structure");
end if;
exception
when others =>
Raise_Exception(Zip.Archive_corrupted'Identity, "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_Exception(Zip.Archive_corrupted'Identity,
"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
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_Exception(Zip.Archive_corrupted'Identity,
"Illegal data for compression structure (values should be in the range 0 .. 18): "
& Integer'Image(CT(CT_idx).n));
end case;
end loop;
HufT_free ( Tl );
-- 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_Exception(Zip.Archive_corrupted'Identity, "Incomplete code set for literals/lengths");
end if;
exception
when others =>
Raise_Exception(Zip.Archive_corrupted'Identity, "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_Exception(Zip.Archive_corrupted'Identity, "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_Exception(Zip.Archive_corrupted'Identity, "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; -- 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;
--------[ Method: BZip2 ]--------
procedure Bunzip2 is
type BZ_Buffer is array(Natural range <>) of Interfaces.Unsigned_8;
procedure Read( b: out BZ_Buffer ) is
pragma Inline(Read);
begin
for i in b'Range loop
b(i):= UnZ_IO.Read_byte_decrypted;
end loop;
end Read;
procedure Write( b: in BZ_Buffer ) is
pragma Inline(Write);
begin
for i in b'Range loop
UnZ_Glob.slide ( UnZ_Glob.slide_index ) := b(i);
UnZ_Glob.slide_index:= UnZ_Glob.slide_index + 1;
UnZ_IO.Flush_if_full(UnZ_Glob.slide_index);
end loop;
end Write;
package My_BZip2 is new BZip2_Decoding
( Buffer => BZ_Buffer,
check_CRC => False, -- Already done by UnZ_IO
Read => Read,
Write => Write
);
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_Exception(Zip.Archive_corrupted'Identity,
"BZip2 error: " & Exception_Name(E) & " - " & Exception_Message(E));
when E: My_BZip2.randomized_not_yet_implemented =>
Raise_Exception(UnZip.Unsupported_method'Identity,
"BZip2: " & Exception_Name(E) & " - " & Exception_Message(E));
end Bunzip2;
--------[ Method: LZMA ]--------
procedure LZMA_Decode is
--
procedure Write_Byte(b: Unsigned_8) is
pragma Inline(Write_Byte);
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_Byte;
--
package My_LZMA_Decoding is new LZMA.Decoding(UnZ_IO.Read_byte_decrypted, Write_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_Exception(Zip.Archive_corrupted'Identity, "Unexpected LZMA properties block size");
end if;
My_LZMA_Decoding.Decompress(
(has_size => False,
given_size => My_LZMA_Decoding.Data_Bytes_Count(UnZ_Glob.uncompsize),
marker_expected => explode_slide_8KB_LZMA_EOS,
fail_on_bad_range_code => True)
);
UnZ_IO.Flush( UnZ_Glob.slide_index );
exception
when E: My_LZMA_Decoding.LZMA_Error =>
Raise_Exception(Zip.Archive_corrupted'Identity,
"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;
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 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;
if UnZ_Glob.compsize > File_size_type'Last - 2 then -- This means: unknown size
UnZ_Glob.compsize:= File_size_type'Last - 2; -- Avoid wraparound in read_buffer
end if; -- From TT's version, 2008
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_Exception(UnZip.Read_Error'Identity, "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 => Unreduce(1 + reduce'Pos(format) - reduce'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 => UnZ_Meth.Bunzip2;
when Zip.lzma_meth => UnZ_Meth.LZMA_Decode;
when others =>
Raise_Exception(Unsupported_method'Identity,
"Format/method " & PKZip_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 Unsigned_32:= hint.dd.uncompressed_size;
begin
Process_descriptor(hint.dd); -- CRC is for checking; sizes are for informing user
if memo_uncomp_size < Unsigned_32'Last and then --
memo_uncomp_size /= hint.dd.uncompressed_size
then
UnZ_IO.Delete_output;
raise Uncompressed_size_Error;
end if;
end;
end if;
if hint.dd.crc_32 /= UnZ_Glob.crc32val then
UnZ_IO.Delete_output;
Raise_Exception(CRC_Error'Identity,
"CRC stored in archive: " & Hexadecimal(hint.dd.crc_32) &
"; CRC computed now: " & Hexadecimal(UnZ_Glob.crc32val));
end if;
case 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 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 related Ada projects
on Gautier's blog.