-- UnZip.Decompress -------------------- -- Internal to the UnZip package. See root package (UnZip) for details & credits. -- Legal licensing note: -- Copyright (c) 2007 .. 2020 Gautier de Montmollin (maintainer of the Ada version) -- 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; format : Zip.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 Ada.Strings.Unbounded.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 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_32_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_32_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 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.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_32_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 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 => 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 => 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_32_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 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 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_32_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_32_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_32_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_32_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_32_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_32_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_32_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_32_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 : 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 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 : 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 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_32_Data_Size_Type := UnZ_Glob.compsize; read_in, absorbed : Zip.Zip_32_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; --------[ Method: BZip2 ]-------- procedure Bunzip2 is type BZ_Buffer is array (Natural range <>) of Interfaces.Unsigned_8; procedure UD_Read (b : out BZ_Buffer) is pragma Inline (UD_Read); begin for i in b'Range loop b (i) := UnZ_IO.Read_byte_decrypted; end loop; end UD_Read; procedure UD_Write (b : in BZ_Buffer) is pragma Inline (UD_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 UD_Write; package My_BZip2 is new BZip2.Decoding (Buffer => BZ_Buffer, check_CRC => False, -- CRC check is already done by UnZ_IO Read => UD_Read, Write => UD_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 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 -- procedure Write_Single_Byte (b : Unsigned_8) is pragma Inline (Write_Single_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_Single_Byte; -- 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 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 > Zip_32_Data_Size_Type'Last - 2 then -- This means: unknown size UnZ_Glob.compsize := Zip_32_Data_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 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 => 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 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 CRC_Error with "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;