Back to... Zip-Ada

Source file : unzip-decompress.adb



   1  --  UnZip.Decompress
   2  --------------------
   3  --  Internal to the UnZip package. See root package (UnZip) for details & credits.
   4  
   5  --  Legal licensing note:
   6  
   7  --  Copyright (c) 2007 .. 2024 Gautier de Montmollin
   8  --  SWITZERLAND
   9  
  10  --  Permission is hereby granted, free of charge, to any person obtaining a copy
  11  --  of this software and associated documentation files (the "Software"), to deal
  12  --  in the Software without restriction, including without limitation the rights
  13  --  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  14  --  copies of the Software, and to permit persons to whom the Software is
  15  --  furnished to do so, subject to the following conditions:
  16  
  17  --  The above copyright notice and this permission notice shall be included in
  18  --  all copies or substantial portions of the Software.
  19  
  20  --  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  21  --  IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  22  --  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  23  --  AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  24  --  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  25  --  OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
  26  --  THE SOFTWARE.
  27  
  28  --  NB: this is the MIT License, as found on the site
  29  --  http://www.opensource.org/licenses/mit-license.php
  30  
  31  with Zip.CRC_Crypto, UnZip.Decompress.Huffman, BZip2.Decoding, LZMA.Decoding;
  32  
  33  with Ada.Exceptions, Ada.Streams.Stream_IO, Ada.Text_IO, Interfaces;
  34  
  35  package body UnZip.Decompress is
  36  
  37    procedure Decompress_Data
  38      (zip_file                   : in out Zip_Streams.Root_Zipstream_Type'Class;
  39       --  zip_file must be open and its index is meant
  40       --  to point to the beginning of compressed data
  41       format                     : in     Zip.PKZip_method;
  42       write_mode                 : in     Write_Mode_Type;
  43       output_file_name           : in     String;  --  relevant only if mode = write_to_file
  44       output_memory_access       :    out p_Stream_Element_Array;  -- \ = write_to_memory
  45       output_stream_access       : in     p_Stream;                -- \ = write_to_stream
  46       feedback                   : in     Zip.Feedback_Proc;
  47       explode_literal_tree       : in     Boolean;  --  relevant for the "explode" format
  48       explode_slide_8KB_LZMA_EOS : in     Boolean;  --  relevant for the "explode" and "LZMA" formats
  49       data_descriptor_after_data : in     Boolean;
  50       is_encrypted               : in     Boolean;
  51       password                   : in out Ada.Strings.Unbounded.Unbounded_String;
  52       get_new_password           : in     Get_Password_Proc;  --  if null, initial pwd must fit
  53       hint                       : in out Zip.Headers.Local_File_Header)
  54    is
  55      --  Disable AdaControl rule for detecting global variables, they have become local here.
  56      --## RULE OFF Directly_Accessed_Globals
  57      --
  58      --  I/O Buffers: Size of input buffer
  59      inbuf_size : constant := 16#8000#;  --  (orig: 16#1000# B =  4 KiB)
  60      --  I/O Buffers: Size of sliding dictionary and output buffer
  61      wsize     : constant := 16#10000#;  --  (orig: 16#8000# B = 32 KiB)
  62  
  63      ----------------------------------------------------------------------------
  64      -- Specifications of UnZ_* packages (remain of Info Zip's code structure) --
  65      ----------------------------------------------------------------------------
  66      use Ada.Exceptions, Interfaces;
  67  
  68      package UnZ_Glob is -- Not global anymore, since local to Decompress_data :-)
  69        --  I/O Buffers: Sliding dictionary for unzipping, and output buffer as well
  70        slide : Zip.Byte_Buffer (0 .. wsize);
  71        slide_index : Integer := 0;  --  Current Position in slide
  72        --  I/O Buffers: Input buffer
  73        inbuf : Zip.Byte_Buffer (0 .. inbuf_size - 1);
  74        inpos, readpos : Integer;  --  pos. in input buffer, pos. read from file
  75        compsize,            --  compressed size of file
  76        reachedsize,         --  number of bytes read from zipfile
  77        uncompsize,          --  uncompressed size of file
  78        effective_writes : Zip.Zip_64_Data_Size_Type;
  79        --  ^ count of effective bytes written or tested, for feedback only
  80        percents_done    : Natural;
  81        crc32val : Unsigned_32;  -- crc calculated from data
  82        uncompressed_index  : Ada.Streams.Stream_Element_Offset;
  83      end UnZ_Glob;
  84  
  85      Zip_EOF  : Boolean; -- read over end of zip section for this file
  86      LZ77_dump : Ada.Text_IO.File_Type;
  87  
  88      package UnZ_IO is
  89        out_bin_file : Ada.Streams.Stream_IO.File_Type;
  90        out_txt_file : Ada.Text_IO.File_Type;
  91        last_char    : Character := ' ';
  92  
  93        procedure Init_Buffers;
  94  
  95        procedure Read_Byte_no_Decrypt (bt : out Zip.Byte);
  96          pragma Inline (Read_Byte_no_Decrypt);
  97  
  98        function Read_Byte_Decrypted return Unsigned_8;  --  NB: reading goes on a while even if
  99          pragma Inline (Read_Byte_Decrypted);           --  Zip_EOF is set: just gives garbage
 100  
 101        package Bit_buffer is
 102          procedure Init;
 103          --  Read at least n bits into the bit buffer, returns the n first bits
 104          function Read (n : Natural) return Integer;
 105            pragma Inline (Read);
 106          function Read_U32 (n : Natural) return Unsigned_32;
 107            pragma Inline (Read_U32);
 108          --  Inverts (NOT operator) the result before masking by n bits
 109          function Read_inverted (n : Natural) return Integer;
 110            pragma Inline (Read_inverted);
 111          --  Dump n bits no longer needed from the bit buffer
 112          procedure Dump (n : Natural);
 113            pragma Inline (Dump);
 114          procedure Dump_to_byte_boundary;
 115          function Read_and_dump (n : Natural) return Integer;
 116            pragma Inline (Read_and_dump);
 117          function Read_and_dump_U32 (n : Natural) return Unsigned_32;
 118            pragma Inline (Read_and_dump_U32);
 119        end Bit_buffer;
 120  
 121        procedure Flush (x : Natural);  --  directly from slide to output stream
 122  
 123        procedure Flush_if_full (W : in out Integer; unflushed : in out Boolean);
 124        pragma Inline (Flush_if_full);
 125  
 126        procedure Flush_if_full (W : in out Integer);
 127        pragma Inline (Flush_if_full);
 128  
 129        procedure Copy (distance, copy_length : Natural; index : in out Natural);
 130        pragma Inline (Copy);
 131  
 132        procedure Copy_or_zero (
 133          distance, length :        Natural;
 134          index            : in out Natural;
 135          unflushed        : in out Boolean);
 136        pragma Inline (Copy_or_zero);
 137  
 138        procedure Delete_output;  --  an error has occured (bad compressed data)
 139  
 140      end UnZ_IO;
 141  
 142      package UnZ_Meth is
 143        procedure Copy_stored;
 144        procedure Unshrink;
 145        subtype Reduction_factor is Integer range 1 .. 4;
 146        procedure Unreduce (factor : Reduction_factor);
 147        procedure Explode (literal_tree, slide_8_KB : Boolean);
 148        deflate_e_mode : Boolean := False;
 149        procedure Inflate;
 150        procedure Bunzip2;      --  Nov-2009
 151        procedure LZMA_Decode;  --  Jun-2014
 152      end UnZ_Meth;
 153  
 154      procedure Process_feedback (new_bytes : Zip.Zip_64_Data_Size_Type) is
 155      pragma Inline (Process_feedback);
 156        new_percents_done : Natural;
 157        user_aborting : Boolean;
 158        use Zip;
 159      begin
 160        if feedback = null or UnZ_Glob.uncompsize = 0 then
 161          return; -- no feedback proc. or cannot calculate percentage
 162        end if;
 163        UnZ_Glob.effective_writes := UnZ_Glob.effective_writes + new_bytes;
 164        new_percents_done := Natural (
 165          (100.0 * Float (UnZ_Glob.effective_writes)) / Float (UnZ_Glob.uncompsize)
 166        );
 167        if new_percents_done > UnZ_Glob.percents_done then
 168          feedback (
 169            percents_done => new_percents_done,
 170            entry_skipped => False,
 171            user_abort    => user_aborting
 172          );
 173          if user_aborting then
 174            raise User_abort;
 175          end if;
 176          UnZ_Glob.percents_done := new_percents_done;
 177        end if;
 178      end Process_feedback;
 179  
 180      use Zip.CRC_Crypto;
 181      local_crypto_pack : Crypto_pack;
 182  
 183      ------------------------------
 184      -- Bodies of UnZ_* packages --
 185      ------------------------------
 186      package body UnZ_IO is
 187  
 188        procedure Init_Buffers is
 189        begin
 190          UnZ_Glob.inpos   :=  0;  --  Input buffer position
 191          UnZ_Glob.readpos := -1;  --  Nothing read
 192          UnZ_Glob.slide_index := 0;
 193          UnZ_Glob.reachedsize      := 0;
 194          UnZ_Glob.effective_writes := 0;
 195          UnZ_Glob.percents_done    := 0;
 196          Zip_EOF := False;
 197          Zip.CRC_Crypto.Init (UnZ_Glob.crc32val);
 198          Bit_buffer.Init;
 199        end Init_Buffers;
 200  
 201        procedure Process_compressed_end_reached is
 202        begin
 203          if Zip_EOF then  --  We came already here once
 204            raise Zip.Archive_corrupted with
 205              "Decoding went past compressed data size plus one buffer length";
 206            --  Avoid infinite loop on data with exactly buffer's length and no end marker
 207          else
 208            UnZ_Glob.readpos := UnZ_Glob.inbuf'Length;
 209            --  Simulates reading -> no blocking.
 210            --  The buffer is full of "random" data.
 211            --  A correct compressed stream will hit its own end-of-compressed-stream.
 212            --  On a corrupted data we will get a wrong code or a CRC error on the way.
 213            Zip_EOF := True;
 214          end if;
 215        end Process_compressed_end_reached;
 216  
 217        procedure Read_buffer is
 218        begin
 219          if full_trace then
 220            Ada.Text_IO.Put ("[Read_buffer...");
 221          end if;
 222          if UnZ_Glob.reachedsize > UnZ_Glob.compsize + 2 then
 223            --  +2: last code is smaller than requested!
 224            Process_compressed_end_reached;
 225          else
 226            begin
 227              Zip.Block_Read (
 228                stream        => zip_file,
 229                buffer        => UnZ_Glob.inbuf,
 230                actually_read => UnZ_Glob.readpos
 231              );
 232            exception
 233              when others => -- I/O error
 234                Process_compressed_end_reached;
 235            end;
 236            if UnZ_Glob.readpos = 0 then -- No byte at all was read
 237              Process_compressed_end_reached;
 238            end if;
 239            UnZ_Glob.reachedsize :=
 240              UnZ_Glob.reachedsize + Zip.Zip_64_Data_Size_Type (UnZ_Glob.readpos);
 241            UnZ_Glob.readpos := UnZ_Glob.readpos - 1;  --  Reason: index of inbuf starts at 0
 242          end if;
 243          UnZ_Glob.inpos := 0;
 244          if full_trace then
 245            Ada.Text_IO.Put_Line ("finished]");
 246          end if;
 247        end Read_buffer;
 248  
 249        procedure Read_Byte_no_Decrypt (bt : out Zip.Byte) is
 250        begin
 251          if UnZ_Glob.inpos > UnZ_Glob.readpos then
 252            Read_buffer;
 253          end if;
 254          bt := UnZ_Glob.inbuf (UnZ_Glob.inpos);
 255          UnZ_Glob.inpos := UnZ_Glob.inpos + 1;
 256        end Read_Byte_no_Decrypt;
 257  
 258        function Read_Byte_Decrypted return Unsigned_8 is
 259          bt : Zip.Byte;
 260        begin
 261          Read_Byte_no_Decrypt (bt);
 262          Decode (local_crypto_pack, bt);
 263          return bt;
 264        end Read_Byte_Decrypted;
 265  
 266        package body Bit_buffer is
 267          B : Unsigned_32;
 268          K : Integer;
 269  
 270          procedure Init is
 271          begin
 272            B := 0;
 273            K := 0;
 274          end Init;
 275  
 276          procedure Need (n : Natural) is
 277            pragma Inline (Need);
 278          begin
 279            while K < n loop
 280              B := B or Shift_Left (Unsigned_32 (Read_Byte_Decrypted), K);
 281              K := K + 8;
 282            end loop;
 283          end Need;
 284  
 285          procedure Dump (n : Natural) is
 286          begin
 287            B := Shift_Right (B, n);
 288            K := K - n;
 289          end Dump;
 290  
 291          procedure Dump_to_byte_boundary is
 292          begin
 293            Dump (K mod 8);
 294          end Dump_to_byte_boundary;
 295  
 296          function Read_U32 (n : Natural) return Unsigned_32 is
 297          begin
 298            Need (n);
 299            return B and (Shift_Left (1, n) - 1);
 300          end Read_U32;
 301  
 302          function Read_inverted (n : Natural) return Integer is
 303          begin
 304            Need (n);
 305            return Integer ((not B) and (Shift_Left (1, n) - 1));
 306          end Read_inverted;
 307  
 308          function Read (n : Natural) return Integer is
 309          begin
 310            return Integer (Read_U32 (n));
 311          end Read;
 312  
 313          function Read_and_dump (n : Natural) return Integer is
 314            res : Integer;
 315          begin
 316            res := Read (n);
 317            Dump (n);
 318            return res;
 319          end Read_and_dump;
 320  
 321          function Read_and_dump_U32 (n : Natural) return Unsigned_32 is
 322            res : Unsigned_32;
 323          begin
 324            res := Read_U32 (n);
 325            Dump (n);
 326            return res;
 327          end Read_and_dump_U32;
 328  
 329        end Bit_buffer;
 330  
 331        procedure Flush (x : Natural) is
 332          use Zip, Ada.Streams;
 333        begin
 334          if full_trace then
 335            Ada.Text_IO.Put ("[Flush...");
 336          end if;
 337          begin
 338            case write_mode is
 339              when write_to_binary_file =>
 340                Block_Write (Ada.Streams.Stream_IO.Stream (out_bin_file).all, UnZ_Glob.slide (0 .. x - 1));
 341              when write_to_text_file =>
 342                Write_as_Text
 343                  (UnZ_IO.out_txt_file, UnZ_Glob.slide (0 .. x - 1), UnZ_IO.last_char);
 344              when write_to_memory =>
 345                for i in 0 .. x - 1 loop
 346                  output_memory_access (UnZ_Glob.uncompressed_index) :=
 347                    Ada.Streams.Stream_Element (UnZ_Glob.slide (i));
 348                  UnZ_Glob.uncompressed_index := UnZ_Glob.uncompressed_index + 1;
 349                end loop;
 350              when write_to_stream =>
 351                Block_Write (output_stream_access.all, UnZ_Glob.slide (0 .. x - 1));
 352              when just_test =>
 353                null;
 354            end case;
 355          exception
 356            when others =>
 357              raise UnZip.Write_Error;
 358          end;
 359          Zip.CRC_Crypto.Update (UnZ_Glob.crc32val, UnZ_Glob.slide (0 .. x - 1));
 360          Process_feedback (Zip_64_Data_Size_Type (x));
 361          if full_trace then
 362            Ada.Text_IO.Put_Line ("finished]");
 363          end if;
 364        end Flush;
 365  
 366        procedure Flush_if_full (W : in out Integer; unflushed : in out Boolean) is
 367        begin
 368          if W = wsize then
 369            Flush (wsize);
 370            W := 0;
 371            unflushed := False;
 372          end if;
 373        end Flush_if_full;
 374  
 375        procedure Flush_if_full (W : in out Integer) is
 376        begin
 377          if W = wsize then
 378            Flush (wsize);
 379            W := 0;
 380          end if;
 381        end Flush_if_full;
 382  
 383        ----------------------------------------------------
 384        -- Reproduction of sequences in the output slide. --
 385        ----------------------------------------------------
 386  
 387        --  Internal:
 388  
 389        procedure Adjust_to_Slide (
 390            source         : in out Integer;
 391            remain         : in out Natural;
 392            part           :    out Integer;
 393            index          :        Integer)
 394        is
 395          pragma Inline (Adjust_to_Slide);
 396        begin
 397          source := source mod wsize;
 398          --  source and index are now in 0 .. WSize-1
 399          if source > index then
 400            part := wsize - source;
 401          else
 402            part := wsize - index;
 403          end if;
 404          --  NB: part is in 1..WSize (part cannot be 0)
 405          if part > remain then
 406            part := remain;
 407          end if;
 408          --  Now part <= remain
 409          remain := remain - part;
 410          --  NB: remain cannot be < 0
 411        end Adjust_to_Slide;
 412  
 413        procedure Copy_range (source, index : in out Natural; amount : Positive) is
 414          pragma Inline (Copy_range);
 415        begin
 416          if full_trace then
 417            Ada.Text_IO.Put (
 418              "(Copy_range: source=" & Integer'Image (source) &
 419              " index=" & Integer'Image (index) &
 420              " amount=" & Integer'Image (amount));
 421          end if;
 422          if abs (index - source) < amount then
 423            if full_trace and then source < index then
 424              Ada.Text_IO.Put (
 425                "; replicates" &
 426                Integer'Image (amount) & " /" & Integer'Image (index - source) &
 427                " )"
 428              );
 429              --  ...times the range source..index-1
 430            end if;
 431            --  if source >= index, the effect of copy is just like the non-overlapping case
 432            for count in reverse 1 .. amount loop
 433              UnZ_Glob.slide (index) := UnZ_Glob.slide (source);
 434              index  := index  + 1;
 435              source := source + 1;
 436            end loop;
 437          else  --  non-overlapping -> copy slice
 438            UnZ_Glob.slide (index .. index + amount - 1) :=
 439              UnZ_Glob.slide (source .. source + amount - 1);
 440            index  := index  + amount;
 441            source := source + amount;
 442          end if;
 443          if full_trace then
 444            Ada.Text_IO.Put (')');
 445          end if;
 446        end Copy_range;
 447  
 448        --  The copying routines:
 449  
 450        procedure Copy (distance, copy_length : Natural; index : in out Natural) is
 451          source, part, remain : Integer;
 452        begin
 453          if some_trace then
 454            Ada.Text_IO.Put_Line (LZ77_dump, "DLE" & Integer'Image (distance) & Integer'Image (copy_length));
 455          end if;
 456          source := index - distance;
 457          remain := copy_length;
 458          loop
 459            Adjust_to_Slide (source, remain, part, index);
 460            Copy_range (source, index, part);
 461            Flush_if_full (index);
 462            exit when remain = 0;
 463          end loop;
 464        end Copy;
 465  
 466        procedure Copy_or_zero (
 467            distance, length :        Natural;
 468            index            : in out Natural;
 469            unflushed        : in out Boolean)
 470        is
 471          source, part, remain : Integer;
 472        begin
 473          source := index - distance;
 474          remain := length;
 475          loop
 476            Adjust_to_Slide (source, remain, part, index);
 477            if unflushed and then index <= source then
 478              UnZ_Glob.slide (index .. index + part - 1) := (others => 0);
 479              index  := index  + part;
 480              source := source + part;
 481            else
 482              Copy_range (source, index, part);
 483            end if;
 484            Flush_if_full (index, unflushed);
 485            exit when remain = 0;
 486          end loop;
 487        end Copy_or_zero;
 488  
 489        procedure Delete_output is  --  an error has occured (bad compressed data)
 490        begin
 491          if no_trace then  --  if there is a trace, we are debugging
 492            case write_mode is   --  and want to keep the malformed file
 493              when write_to_binary_file =>
 494                Ada.Streams.Stream_IO.Delete (UnZ_IO.out_bin_file);
 495              when write_to_text_file =>
 496                Ada.Text_IO.Delete (UnZ_IO.out_txt_file);
 497              when write_to_memory | write_to_stream | just_test =>
 498                null; -- Nothing to delete!
 499            end case;
 500          end if;
 501        end Delete_output;
 502  
 503      end UnZ_IO;
 504  
 505      procedure Init_Decryption (password_for_keys : String; crc_check : Unsigned_32) is
 506        c : Zip.Byte := 0;
 507        t : Unsigned_32;
 508      begin
 509        --  Step 1 - Initializing the encryption keys
 510        Init_Keys (local_crypto_pack, password_for_keys);
 511        --  Step 2 - Decrypting the encryption header. 11 bytes are random,
 512        --           just to shuffle the keys, 1 byte is from the CRC value.
 513        Set_Mode (local_crypto_pack, encrypted);
 514        for i in 1 .. 12 loop
 515          UnZ_IO.Read_Byte_no_Decrypt (c);
 516          Decode (local_crypto_pack, c);
 517        end loop;
 518        t := Zip_Streams.Calendar.Convert (hint.file_timedate);
 519        --  Last byte used to check password; 1/256 probability of success with any password!
 520        if c /= Zip.Byte (Shift_Right (crc_check, 24)) and not
 521          --  Dec. 2012. This is a feature of Info-Zip (crypt.c), not of PKWARE.
 522          --  Since CRC is only known at the end of a one-way stream
 523          --  compression, and cannot be written back, they are using a byte of
 524          --  the time stamp instead. This is NOT documented in PKWARE's appnote.txt v.6.3.3.
 525          (data_descriptor_after_data and c = Zip.Byte (Shift_Right (t, 8) and 16#FF#))
 526        then
 527          raise UnZip.Wrong_password;
 528        end if;
 529      end Init_Decryption;
 530  
 531      package body UnZ_Meth is
 532  
 533        --------[ Method: Unshrink ]--------
 534  
 535        --  Original in Pascal written by Christian Ghisler.
 536  
 537        Initial_Code_Size : constant := 9;
 538        Maximum_Code_Size : constant := 13;
 539        Max_Code          : constant := 2 ** Maximum_Code_Size;
 540        Max_Stack         : constant := 2 ** Maximum_Code_Size;
 541  
 542        --  Rest of slide=write buffer =766 bytes
 543  
 544        Write_Max : constant := wsize - 3 * (Max_Code - 256) - Max_Stack - 2;
 545  
 546        Next_Free : Integer;      --  Next free code in trie
 547        Write_Ptr : Integer;      --  Pointer to output buffer
 548  
 549        Writebuf : Zip.Byte_Buffer (0 .. Write_Max);  --  Write buffer
 550  
 551        procedure Unshrink_Flush is
 552          use Zip, Ada.Streams, Ada.Streams.Stream_IO;
 553        begin
 554          if full_trace then
 555            Ada.Text_IO.Put ("[Unshrink_Flush]");
 556          end if;
 557          begin
 558            case write_mode is
 559              when write_to_binary_file =>
 560                Block_Write (Stream (UnZ_IO.out_bin_file).all, Writebuf (0 .. Write_Ptr - 1));
 561              when write_to_text_file =>
 562                Zip.Write_as_Text (UnZ_IO.out_txt_file, Writebuf (0 .. Write_Ptr - 1), UnZ_IO.last_char);
 563              when write_to_memory =>
 564                for I in 0 .. Write_Ptr - 1 loop
 565                  output_memory_access (UnZ_Glob.uncompressed_index) :=
 566                    Stream_Element (Writebuf (I));
 567                  UnZ_Glob.uncompressed_index :=  UnZ_Glob.uncompressed_index + 1;
 568                end loop;
 569              when write_to_stream =>
 570                Block_Write (output_stream_access.all, Writebuf (0 .. Write_Ptr - 1));
 571              when just_test =>
 572                null;
 573            end case;
 574          exception
 575            when others =>
 576              raise UnZip.Write_Error;
 577          end;
 578          Zip.CRC_Crypto.Update (UnZ_Glob.crc32val, Writebuf (0 .. Write_Ptr - 1));
 579          Process_feedback (Zip_64_Data_Size_Type (Write_Ptr));
 580        end Unshrink_Flush;
 581  
 582        procedure UD_Write_Byte (B : Zip.Byte) is
 583        begin
 584          Writebuf (Write_Ptr) := B;
 585          Write_Ptr := Write_Ptr + 1;
 586          if Write_Ptr > Write_Max then
 587            Unshrink_Flush;
 588            Write_Ptr := 0;
 589          end if;
 590        end UD_Write_Byte;
 591  
 592        procedure Unshrink is
 593          S : Zip.Zip_64_Data_Size_Type := UnZ_Glob.uncompsize;
 594  
 595          Last_Incode     : Integer;
 596          Last_Outcode    : Zip.Byte;
 597          Code_Size       : Integer := Initial_Code_Size;  --  Actual code size [9 .. 13]
 598          Actual_Max_Code : Integer;  --  Max code to be searched for leaf nodes
 599          First_Entry     : constant := 257;
 600          Previous_Code   : array (First_Entry .. Max_Code) of Integer;
 601          Stored_Literal  : array (First_Entry .. Max_Code) of Zip.Byte;
 602  
 603          procedure Clear_Leaf_Nodes is
 604            Is_Leaf : array (First_Entry .. Max_Code) of Boolean := (others => True);
 605            Pc : Integer;  --  Previous code
 606          begin
 607            if full_trace then
 608              Ada.Text_IO.Put ("[Clear leaf nodes @ pos" &
 609                Zip.Zip_64_Data_Size_Type'Image (UnZ_Glob.uncompsize - S) &
 610                "; old Next_Free =" & Integer'Image (Next_Free));
 611            end if;
 612            for I in First_Entry .. Actual_Max_Code loop
 613              Pc := Previous_Code (I);
 614              if  Pc > 256 then
 615                --  Pc is in a tree as well
 616                Is_Leaf (Pc) := False;
 617              end if;
 618            end loop;
 619  
 620            --  Build new free list
 621            Pc := -1;
 622            Next_Free := -1;
 623            for I in First_Entry .. Actual_Max_Code loop
 624              --  Either free before, or marked now as leaf
 625              if Previous_Code (I) < 0 or Is_Leaf (I) then
 626                --  Link last item to this item
 627                if Pc = -1 then
 628                  Next_Free := I;
 629                else
 630                  --  Next free node from Pc is I.
 631                  Previous_Code (Pc) := -I;
 632                end if;
 633                Pc := I;
 634              end if;
 635            end loop;
 636  
 637            if Pc /= -1 then
 638              --  Last (old or new) free node points to the first "never used".
 639              Previous_Code (Pc) := -(Actual_Max_Code + 1);
 640            end if;
 641            if Next_Free = -1 then
 642              --  Unlikely but possible case:
 643              --     - no previously free or leaf node found, or
 644              --     - table clearing is ordered when the table is still empty.
 645              Next_Free := Actual_Max_Code + 1;
 646            end if;
 647  
 648            if full_trace then
 649              Ada.Text_IO.Put ("; new Next_Free =" & Integer'Image (Next_Free) & ']');
 650            end if;
 651          end Clear_Leaf_Nodes;
 652  
 653          procedure Attempt_Table_Increase is
 654            Candidate : constant Integer := Next_Free;
 655          begin
 656            if Candidate > Max_Code then
 657              --  This case is supported by PKZip's LZW variant.
 658              --  Table clearing is done only on a special command.
 659              if some_trace then
 660                Ada.Text_IO.Put ("[Table is full]");
 661              end if;
 662            else
 663              if Candidate not in Previous_Code'Range then
 664                raise Zip.Archive_corrupted with "Wrong LZW (Shrink) index";
 665              end if;
 666              Next_Free := -Previous_Code (Candidate);
 667              Actual_Max_Code := Integer'Max (Actual_Max_Code, Next_Free - 1);
 668  
 669              --  Next node in free list
 670              Previous_Code (Candidate)  := Last_Incode;
 671              Stored_Literal (Candidate) := Last_Outcode;
 672            end if;
 673          end Attempt_Table_Increase;
 674  
 675          Incode    : Integer;  --  Code read in
 676          New_Code  : Integer;  --  Save new normal code read
 677          Stack     : Zip.Byte_Buffer (0 .. Max_Stack);  --  Stack for output
 678          Stack_Ptr : Integer := Max_Stack;
 679  
 680          --  PKZip's Shrink is a variant of the LZW algorithm in that the
 681          --  compressor controls the code increase and the table clearing.
 682          --  See appnote.txt, section 5.1.
 683          Special_Code : constant := 256;
 684          Code_for_increasing_code_size : constant := 1;
 685          Code_for_clearing_table       : constant := 2;
 686  
 687          procedure Read_Code is
 688            pragma Inline (Read_Code);
 689          begin
 690            Incode := UnZ_IO.Bit_buffer.Read_and_dump (Code_Size);
 691          end Read_Code;
 692  
 693        begin
 694          --  Initialize free codes list
 695          for I in Previous_Code'Range loop
 696            Previous_Code (I) := -(I + 1);
 697          end loop;
 698          --
 699          Stored_Literal := (others => 0);
 700          Stack          := (others => 0);
 701          Writebuf       := (others => 0);
 702  
 703          if UnZ_Glob.compsize = Zip.Zip_64_Data_Size_Type'Last then
 704            --  Compressed Size was not in header!
 705            raise UnZip.Not_supported;
 706          elsif UnZ_Glob.uncompsize = 0 then
 707            return;  --  compression of a 0-file with Shrink.pas
 708          end if;
 709  
 710          Next_Free := First_Entry;
 711          Actual_Max_Code := First_Entry - 1;
 712          Write_Ptr := 0;
 713  
 714          Read_Code;
 715          Last_Incode := Incode;
 716          if Incode not in 0 .. 255 then
 717            raise Zip.Archive_corrupted with "Wrong LZW (Shrink) 1st byte; must be a literal";
 718          end if;
 719          Last_Outcode := Zip.Byte (Incode);
 720          UD_Write_Byte (Last_Outcode);
 721          S := S - 1;
 722  
 723          Main_Unshrink_Loop :
 724          while S > 0 and then not Zip_EOF loop
 725            Read_Code;
 726            if Incode = Special_Code then  --  Code = 256
 727              Read_Code;
 728              case Incode is
 729                when Code_for_increasing_code_size =>
 730                  Code_Size := Code_Size + 1;
 731                  if some_trace then
 732                    Ada.Text_IO.Put (
 733                      "[Increment LZW code size to" & Integer'Image (Code_Size) &
 734                      " bits @ pos" & Zip.Zip_64_Data_Size_Type'Image (UnZ_Glob.uncompsize - S) & ']'
 735                    );
 736                  end if;
 737                  if Code_Size > Maximum_Code_Size then
 738                    raise Zip.Archive_corrupted with "Wrong LZW (Shrink) code size";
 739                  end if;
 740                when Code_for_clearing_table =>
 741                  Clear_Leaf_Nodes;
 742                when others =>
 743                  raise Zip.Archive_corrupted with
 744                    "Wrong LZW (Shrink) special code" & Integer'Image (Incode);
 745              end case;
 746            else  --  Normal code (either a literal (< 256), or a tree node (> 256))
 747              New_Code := Incode;
 748              if Incode < 256 then          --  Literal (simple character)
 749                Last_Outcode :=  Zip.Byte (Incode);
 750                UD_Write_Byte (Last_Outcode);
 751                S := S - 1;
 752              else  --  Tree node (code > 256)
 753                if Previous_Code (Incode) < 0 then
 754                  --  First node is orphan (parent is a free node).
 755                  if full_trace then
 756                    Ada.Text_IO.Put ("[ Node from stream is orphan ]");
 757                  end if;
 758                  Stack (Stack_Ptr) := Last_Outcode;
 759                  Stack_Ptr := Stack_Ptr - 1;
 760                  Incode := Last_Incode;
 761                end if;
 762                while Incode > 256 loop
 763                  if Stack_Ptr < Stack'First then
 764                    raise Zip.Archive_corrupted with "LZW (Shrink): String stack exhausted";
 765                  end if;
 766                  if Incode > Max_Code then
 767                    raise Zip.Archive_corrupted with "LZW (Shrink): Incode out of range";
 768                  end if;
 769                  if Previous_Code (Incode) < 0 then
 770                    --  Linked node is orphan (parent is a free node).
 771                    --  This rare case appears on some data, compressed only by PKZIP.
 772                    --  The last PKZIP version known to us that is able to compress
 773                    --  with the Shrink algorithm is PKZIP v.1.10, 1990-03-15.
 774                    if some_trace then
 775                      Ada.Text_IO.Put ("[ Linked node is orphan ]");
 776                    end if;
 777                    Stack (Stack_Ptr) := Last_Outcode;
 778                    Incode := Last_Incode;
 779                  else
 780                    Stack (Stack_Ptr) := Stored_Literal (Incode);
 781                    Incode := Previous_Code (Incode);
 782                  end if;
 783                  Stack_Ptr := Stack_Ptr - 1;
 784                end loop;
 785                --  NB: Incode cannot be negative (orphan case treated above).
 786                --      It is <= 256 because of the while loop.
 787                --      It is /= 256 because it is set to a Last_Incode value (directly or
 788                --        through Previous_Code) which is either in [0 .. 255] or > 256.
 789                --      So Incode is in [0 .. 255].
 790                Last_Outcode := Zip.Byte (Incode);
 791                UD_Write_Byte (Last_Outcode);
 792                --  Now we output the string in forward order.
 793                for I in Stack_Ptr + 1 .. Max_Stack  loop
 794                  UD_Write_Byte (Stack (I));
 795                end loop;
 796                S := S - Zip.Zip_64_Data_Size_Type (Max_Stack - Stack_Ptr + 1);
 797                Stack_Ptr := Max_Stack;
 798              end if;
 799              Attempt_Table_Increase;
 800              Last_Incode := New_Code;
 801            end if;
 802          end loop Main_Unshrink_Loop;
 803  
 804          if some_trace then
 805            Ada.Text_IO.Put ("[ Unshrink main loop finished ]");
 806          end if;
 807          Unshrink_Flush;
 808        end Unshrink;
 809  
 810        --------[ Method: Unreduce ]--------
 811  
 812        procedure Unreduce (factor : Reduction_factor) is
 813  
 814          --  Original slide limit: 16#4000#
 815          DLE_code : constant := 144;
 816          subtype Symbol_range is Integer range 0 .. 255;
 817          subtype Follower_range is Integer range 0 .. 63;  --  Appnote: <= 32 !
 818          Followers : array (Symbol_range, Follower_range) of Symbol_range :=
 819            (others => (others => 0));
 820          Slen : array (Symbol_range) of Follower_range;
 821  
 822          --  Bits taken by (x-1) mod 256:
 823          B_Table : constant array (Symbol_range) of Integer :=
 824              (0        => 8,
 825               1 .. 2   => 1,
 826               3 .. 4   => 2,
 827               5 .. 8   => 3,
 828               9 .. 16  => 4,
 829              17 .. 32  => 5,
 830              33 .. 64  => 6,
 831              65 .. 128 => 7,
 832             129 .. 255 => 8);
 833  
 834          procedure LoadFollowers is
 835            list_followers : constant Boolean := some_trace;
 836            procedure Show_symbol (S : Symbol_range) is
 837            begin
 838              if S in 32 .. 254 then
 839                Ada.Text_IO.Put (Character'Val (S));
 840              else
 841                Ada.Text_IO.Put ('{' & Symbol_range'Image (S) & '}');
 842              end if;
 843            end Show_symbol;
 844          begin
 845            for X in reverse Symbol_range loop
 846              Slen (X) := UnZ_IO.Bit_buffer.Read_and_dump (6);
 847              if list_followers then
 848                Show_symbol (X);
 849                Ada.Text_IO.Put (" -> (" & Integer'Image (Slen (X)) & ") ");
 850              end if;
 851              for I in 0 .. Slen (X) - 1  loop
 852                Followers (X, I) := UnZ_IO.Bit_buffer.Read_and_dump (8);
 853                if list_followers then
 854                  Show_symbol (Followers (X, I));
 855                end if;
 856              end loop;
 857              if list_followers then
 858                Ada.Text_IO.New_Line;
 859              end if;
 860            end loop;
 861          end LoadFollowers;
 862  
 863          length,
 864          char_read,
 865          last_char : Integer := 0;
 866          --  ^ some := 0 are useless, just to calm down ObjectAda 7.2.2
 867          S : Zip.Zip_64_Data_Size_Type := UnZ_Glob.uncompsize;
 868          --  number of bytes left to decompress
 869          unflushed : Boolean := True;
 870          maximum_AND_mask : constant Unsigned_32 := Shift_Left (1, 8 - factor) - 1;
 871  
 872          procedure Out_byte (b : Zip.Byte) is
 873          begin
 874            S := S - 1;
 875            UnZ_Glob.slide (UnZ_Glob.slide_index) := b;
 876            UnZ_Glob.slide_index := UnZ_Glob.slide_index + 1;
 877            UnZ_IO.Flush_if_full (UnZ_Glob.slide_index, unflushed);
 878          end Out_byte;
 879  
 880          V : Unsigned_32 := 0;
 881          type State_type is (normal, length_a, length_b, distance);
 882          state : State_type := normal;
 883  
 884        begin
 885          LoadFollowers;
 886  
 887          while S > 0 and then not Zip_EOF loop
 888  
 889            --  1/ Probabilistic expansion
 890            if Slen (last_char) = 0 then
 891              --  follower set is empty for this character
 892              char_read := UnZ_IO.Bit_buffer.Read_and_dump (8);
 893            elsif UnZ_IO.Bit_buffer.Read_and_dump (1) = 0  then
 894              char_read := Followers (
 895                last_char,
 896                UnZ_IO.Bit_buffer.Read_and_dump (B_Table (Slen (last_char)))
 897              );
 898            else
 899              char_read := UnZ_IO.Bit_buffer.Read_and_dump (8);
 900            end if;
 901  
 902            --  2/ Expand the resulting Zip.Byte into repeated sequences
 903            case state is
 904  
 905              when normal =>
 906                if char_read = DLE_code then
 907                  --  >> Next will be a DLE
 908                  state := length_a;
 909                else
 910                  --  >> A single char
 911                  Out_byte (Zip.Byte (char_read));
 912                end if;
 913  
 914              when length_a =>
 915                if char_read = 0 then
 916                  --  >> DLE_code & 0 -> was just the Zip.Byte coded DLE_code
 917                  Out_byte (DLE_code);
 918                  state := normal;
 919                else
 920                  V := Unsigned_32 (char_read);
 921                  length := Integer (V and maximum_AND_mask);
 922                  --  The remaining bits of V will be used for the distance
 923                  if length = Integer (maximum_AND_mask) then
 924                    state := length_b;
 925                    --  >> length must be completed before reading distance
 926                  else
 927                    state := distance;
 928                  end if;
 929                end if;
 930  
 931              when length_b =>
 932                length := length + char_read;
 933                state := distance;
 934  
 935              when distance =>
 936                length := length + 3;
 937                S := S - Zip.Zip_64_Data_Size_Type (length);
 938  
 939                UnZ_IO.Copy_or_zero (
 940                  distance   => char_read + 1 + Integer (Shift_Right (V, 8 - factor) * 2**8),
 941                  length     => length,
 942                  index      => UnZ_Glob.slide_index,
 943                  unflushed  => unflushed
 944                );
 945                state := normal;
 946  
 947            end case;
 948  
 949            last_char := char_read;  -- store character for next iteration
 950          end loop;
 951  
 952          UnZ_IO.Flush (UnZ_Glob.slide_index);
 953        end Unreduce;
 954  
 955        --------[ Method: Explode ]--------
 956  
 957        --  C code by info-zip group, translated to Pascal by Christian Ghisler
 958        --  based on unz51g.zip
 959  
 960        use UnZip.Decompress.Huffman;
 961  
 962        procedure Get_Tree (L : out Length_array) is
 963          I, K, J, B : Unsigned_32;
 964          N          : constant Unsigned_32 := L'Length;
 965          L_Idx      : Integer    := L'First;
 966        begin
 967          if full_trace then
 968            Ada.Text_IO.Put_Line ("Begin UnZ_Expl.Get_tree");
 969          end if;
 970  
 971          I := Unsigned_32 (UnZ_IO.Read_Byte_Decrypted) + 1;
 972          K := 0;
 973  
 974          loop
 975            J := Unsigned_32 (UnZ_IO.Read_Byte_Decrypted);
 976            B := (J  and  16#0F#) + 1;
 977            J := (J  and  16#F0#) / 16 + 1;
 978            if  K + J > N then
 979              raise Zip.Archive_corrupted;
 980            end if;
 981  
 982            loop
 983              L (L_Idx) := Natural (B);
 984              L_Idx := L_Idx + 1;
 985              K := K + 1;
 986              J := J - 1;
 987              exit when  J = 0;
 988            end loop;
 989  
 990            I := I - 1;
 991            exit when  I = 0;
 992          end loop;
 993  
 994          if  K /= N then
 995            raise Zip.Archive_corrupted;
 996          end if;
 997  
 998          if full_trace then
 999            Ada.Text_IO.Put_Line ("End   UnZ_Expl.Get_tree");
1000          end if;
1001        end Get_Tree;
1002  
1003        procedure Explode_Lit ( -- method with 3 trees
1004          Needed : Integer;
1005          Tb, Tl, Td : p_Table_list;
1006          Bb, Bl, Bd : Integer
1007        )
1008        is
1009          S       : Zip.Zip_64_Data_Size_Type;
1010          E, N, D : Integer;
1011  
1012          W : Integer := 0;
1013          Ct : p_HufT_table; -- current table
1014          Ci : Natural;                               -- current index
1015          unflushed : Boolean := True; -- true while slide not yet unflushed
1016  
1017        begin
1018          if full_trace then
1019            Ada.Text_IO.Put_Line ("Begin Explode_lit");
1020          end if;
1021  
1022          UnZ_IO.Bit_buffer.Init;
1023  
1024          S := UnZ_Glob.uncompsize;
1025          while  S > 0  and  not Zip_EOF  loop
1026            if UnZ_IO.Bit_buffer.Read_and_dump (1) /= 0 then  -- 1: Literal
1027              S := S - 1;
1028              Ct := Tb.table;
1029              Ci := UnZ_IO.Bit_buffer.Read_inverted (Bb);
1030  
1031              loop
1032                E :=  Ct (Ci).extra_bits;
1033                exit when E <= 16;
1034  
1035                if E = invalid then
1036                  raise Zip.Archive_corrupted;
1037                end if;
1038  
1039                UnZ_IO.Bit_buffer.Dump (Ct (Ci).bits);
1040                E := E - 16;
1041                Ct := Ct (Ci).next_table;
1042                Ci := UnZ_IO.Bit_buffer.Read_inverted (E);
1043              end loop;
1044  
1045              UnZ_IO.Bit_buffer.Dump (Ct (Ci).bits);
1046              UnZ_Glob.slide (W) :=  Zip.Byte (Ct (Ci).n);
1047              W := W + 1;
1048              UnZ_IO.Flush_if_full (W, unflushed);
1049  
1050            else                                       -- 0: Copy
1051              D := UnZ_IO.Bit_buffer.Read_and_dump (Needed);
1052              Ct := Td.table;
1053              Ci := UnZ_IO.Bit_buffer.Read_inverted (Bd);
1054  
1055              loop
1056                E := Ct (Ci).extra_bits;
1057                exit when  E <= 16;
1058  
1059                if E = invalid then
1060                  raise Zip.Archive_corrupted;
1061                end if;
1062  
1063                UnZ_IO.Bit_buffer.Dump (Ct (Ci).bits);
1064                E := E - 16;
1065                Ct := Ct (Ci).next_table;
1066                Ci := UnZ_IO.Bit_buffer.Read_inverted (E);
1067              end loop;
1068  
1069              UnZ_IO.Bit_buffer.Dump (Ct (Ci).bits);
1070              D := D + Ct (Ci).n;
1071  
1072              Ct := Tl.table;
1073              Ci := UnZ_IO.Bit_buffer.Read_inverted (Bl);
1074  
1075              loop
1076                E := Ct (Ci).extra_bits;
1077                exit when  E <= 16;
1078  
1079                if E = invalid then
1080                  raise Zip.Archive_corrupted;
1081                end if;
1082  
1083                UnZ_IO.Bit_buffer.Dump (Ct (Ci).bits);
1084                E := E - 16;
1085                Ct := Ct (Ci).next_table;
1086                Ci := UnZ_IO.Bit_buffer.Read_inverted (E);
1087              end loop;
1088  
1089              UnZ_IO.Bit_buffer.Dump (Ct (Ci).bits);
1090  
1091              N :=  Ct (Ci).n;
1092              if E /= 0 then
1093                N := N + UnZ_IO.Bit_buffer.Read_and_dump (8);
1094              end if;
1095              S := S - Zip.Zip_64_Data_Size_Type (N);
1096  
1097              UnZ_IO.Copy_or_zero (
1098                distance   => D,
1099                length     => N,
1100                index      => W,
1101                unflushed  => unflushed
1102              );
1103  
1104            end if;
1105          end loop;
1106  
1107          UnZ_IO.Flush (W);
1108          if Zip_EOF then
1109            raise Zip.Archive_corrupted with "End of stream reached";
1110          end if;
1111  
1112          if full_trace then
1113            Ada.Text_IO.Put_Line ("End   Explode_lit");
1114          end if;
1115        end Explode_Lit;
1116  
1117        procedure Explode_Nolit ( -- method with 2 trees
1118            Needed : Integer;
1119            Tl, Td : p_Table_list;
1120            Bl, Bd : Integer
1121        )
1122        is
1123          S       : Zip.Zip_64_Data_Size_Type;
1124          E, N, D : Integer;
1125          W : Integer := 0;
1126          Ct : p_HufT_table; -- current table
1127          Ci : Natural;                               -- current index
1128          unflushed : Boolean := True; -- true while slide not yet unflushed
1129  
1130        begin
1131          if full_trace then
1132            Ada.Text_IO.Put_Line ("Begin Explode_nolit");
1133          end if;
1134  
1135          UnZ_IO.Bit_buffer.Init;
1136          S := UnZ_Glob.uncompsize;
1137          while  S > 0  and not Zip_EOF  loop
1138            if UnZ_IO.Bit_buffer.Read_and_dump (1) /= 0 then  -- 1: Literal
1139              S := S - 1;
1140              UnZ_Glob.slide (W) :=
1141                Zip.Byte (UnZ_IO.Bit_buffer.Read_and_dump (8));
1142              W := W + 1;
1143              UnZ_IO.Flush_if_full (W, unflushed);
1144            else                                       -- 0: Copy
1145              D := UnZ_IO.Bit_buffer.Read_and_dump (Needed);
1146              Ct := Td.table;
1147              Ci := UnZ_IO.Bit_buffer.Read_inverted (Bd);
1148  
1149              loop
1150                E := Ct (Ci).extra_bits;
1151                exit when  E <= 16;
1152  
1153                if E = invalid then
1154                  raise Zip.Archive_corrupted;
1155                end if;
1156  
1157                UnZ_IO.Bit_buffer.Dump (Ct (Ci).bits);
1158                E := E - 16;
1159                Ct := Ct (Ci).next_table;
1160                Ci := UnZ_IO.Bit_buffer.Read_inverted (E);
1161              end loop;
1162  
1163              UnZ_IO.Bit_buffer.Dump (Ct (Ci).bits);
1164  
1165              D :=  D + Ct (Ci).n;
1166              Ct := Tl.table;
1167              Ci := UnZ_IO.Bit_buffer.Read_inverted (Bl);
1168  
1169              loop
1170                E := Ct (Ci).extra_bits;
1171                exit when E <= 16;
1172  
1173                if E = invalid then
1174                  raise Zip.Archive_corrupted;
1175                end if;
1176  
1177                UnZ_IO.Bit_buffer.Dump (Ct (Ci).bits);
1178                E := E - 16;
1179                Ct := Ct (Ci).next_table;
1180                Ci := UnZ_IO.Bit_buffer.Read_inverted (E);
1181              end loop;
1182  
1183              UnZ_IO.Bit_buffer.Dump (Ct (Ci).bits);
1184  
1185              N := Ct (Ci).n;
1186              if  E /= 0 then
1187                N := N + UnZ_IO.Bit_buffer.Read_and_dump (8);
1188              end if;
1189              S := S - Zip.Zip_64_Data_Size_Type (N);
1190  
1191              UnZ_IO.Copy_or_zero (
1192                distance   => D,
1193                length     => N,
1194                index      => W,
1195                unflushed  => unflushed
1196              );
1197  
1198            end if;
1199          end loop;
1200  
1201          UnZ_IO.Flush (W);
1202          if Zip_EOF then
1203            raise Zip.Archive_corrupted with "End of stream reached";
1204          end if;
1205  
1206          if full_trace then
1207            Ada.Text_IO.Put_Line ("End   Explode_nolit");
1208          end if;
1209  
1210        end Explode_Nolit;
1211  
1212        procedure Explode (literal_tree, slide_8_KB : Boolean) is
1213  
1214          Tb, Tl, Td : p_Table_list;
1215          Bb, Bl, Bd : Integer;
1216          L :  Length_array (0 .. 255);
1217          huft_incomplete : Boolean;
1218  
1219          cp_length_2_trees :
1220            constant Length_array (0 .. 63) :=
1221             (2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 13, 14, 15, 16, 17,
1222             18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34,
1223             35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51,
1224             52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65);
1225  
1226          cp_length_3_trees :
1227            constant Length_array (0 .. 63) :=
1228             (3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 13, 14, 15, 16, 17, 18,
1229             19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35,
1230             36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52,
1231             53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66);
1232  
1233          cp_dist_4KB :
1234            constant Length_array (0 .. 63) :=
1235            (1, 65, 129, 193, 257, 321, 385, 449, 513, 577, 641, 705,
1236             769, 833, 897, 961, 1025, 1089, 1153, 1217, 1281, 1345, 1409, 1473,
1237             1537, 1601, 1665, 1729, 1793, 1857, 1921, 1985, 2049, 2113, 2177,
1238             2241, 2305, 2369, 2433, 2497, 2561, 2625, 2689, 2753, 2817, 2881,
1239             2945, 3009, 3073, 3137, 3201, 3265, 3329, 3393, 3457, 3521, 3585,
1240             3649, 3713, 3777, 3841, 3905, 3969, 4033);
1241  
1242          cp_dist_8KB :
1243            constant Length_array (0 .. 63) :=
1244               (1,  129,  257,  385,  513,  641,  769,  897, 1025, 1153, 1281,
1245             1409, 1537, 1665, 1793, 1921, 2049, 2177, 2305, 2433, 2561, 2689,
1246             2817, 2945, 3073, 3201, 3329, 3457, 3585, 3713, 3841, 3969, 4097,
1247             4225, 4353, 4481, 4609, 4737, 4865, 4993, 5121, 5249, 5377, 5505,
1248             5633, 5761, 5889, 6017, 6145, 6273, 6401, 6529, 6657, 6785, 6913,
1249             7041, 7169, 7297, 7425, 7553, 7681, 7809, 7937, 8065);
1250  
1251          extra :
1252            constant Length_array (0 .. 63) := (0 .. 62 => 0, 63 => 8);
1253  
1254        begin
1255          Bl := 7;
1256          if UnZ_Glob.compsize > 200000 then
1257            Bd := 8;
1258          else
1259            Bd := 7;
1260          end if;
1261  
1262          if literal_tree then
1263            Bb := 9;
1264            Get_Tree (L);
1265            begin
1266              HufT_build (L, 256, empty, empty, Tb, Bb, huft_incomplete);
1267              if huft_incomplete then
1268                HufT_free (Tb);
1269                raise Zip.Archive_corrupted;
1270              end if;
1271            exception
1272              when others =>
1273                raise Zip.Archive_corrupted;
1274            end;
1275  
1276            begin
1277              Get_Tree (L (0 .. 63));
1278            exception
1279              when others =>
1280                HufT_free (Tb);
1281                raise Zip.Archive_corrupted;
1282            end;
1283  
1284            begin
1285              HufT_build (
1286                L (0 .. 63), 0, cp_length_3_trees, extra, Tl, Bl, huft_incomplete
1287              );
1288              if huft_incomplete then
1289                HufT_free (Tl);
1290                HufT_free (Tb);
1291                raise Zip.Archive_corrupted;
1292              end if;
1293            exception
1294              when others =>
1295                HufT_free (Tb);
1296                raise Zip.Archive_corrupted;
1297            end;
1298  
1299            begin
1300              Get_Tree (L (0 .. 63));
1301            exception
1302              when others =>
1303                HufT_free (Tb);
1304                HufT_free (Tl);
1305                raise Zip.Archive_corrupted;
1306            end;
1307  
1308            begin
1309              if slide_8_KB then
1310                HufT_build (
1311                  L (0 .. 63), 0, cp_dist_8KB, extra, Td, Bd, huft_incomplete
1312                );
1313                if huft_incomplete then
1314                  HufT_free (Td);
1315                  HufT_free (Tl);
1316                  HufT_free (Tb);
1317                  raise Zip.Archive_corrupted;
1318                end if;
1319                --  Exploding, method: 8k slide, 3 trees
1320                Explode_Lit (7, Tb, Tl, Td, Bb, Bl, Bd);
1321              else
1322                HufT_build (
1323                  L (0 .. 63), 0, cp_dist_4KB, extra, Td, Bd, huft_incomplete
1324                );
1325                if huft_incomplete then
1326                  HufT_free (Td);
1327                  HufT_free (Tl);
1328                  HufT_free (Tb);
1329                  raise Zip.Archive_corrupted;
1330                end if;
1331                --  Exploding, method: 4k slide, 3 trees
1332                Explode_Lit (6, Tb, Tl, Td, Bb, Bl, Bd);
1333              end if;
1334            exception
1335              when  others =>
1336                HufT_free (Tl);
1337                HufT_free (Tb);
1338                raise Zip.Archive_corrupted;
1339            end;
1340            HufT_free (Td);
1341            HufT_free (Tl);
1342            HufT_free (Tb);
1343  
1344          else         -- No literal tree
1345  
1346            begin
1347              Get_Tree (L (0 .. 63));
1348            exception
1349              when others =>
1350                raise Zip.Archive_corrupted;
1351            end;
1352  
1353            begin
1354              HufT_build (
1355                L (0 .. 63), 0, cp_length_2_trees, extra, Tl, Bl, huft_incomplete
1356              );
1357              if huft_incomplete then
1358                HufT_free (Tl);
1359                raise Zip.Archive_corrupted;
1360              end if;
1361            exception
1362              when others =>
1363                raise Zip.Archive_corrupted;
1364            end;
1365  
1366            begin
1367              Get_Tree (L (0 .. 63));
1368            exception
1369              when others =>
1370                HufT_free (Tl);
1371                raise Zip.Archive_corrupted;
1372            end;
1373  
1374            begin
1375              if slide_8_KB then
1376                HufT_build (
1377                  L (0 .. 63), 0, cp_dist_8KB, extra, Td, Bd, huft_incomplete
1378                );
1379                if huft_incomplete then
1380                  HufT_free (Td);
1381                  HufT_free (Tl);
1382                  raise Zip.Archive_corrupted;
1383                end if;
1384                --  Exploding, method: 8k slide, 2 trees
1385                Explode_Nolit (7, Tl, Td, Bl, Bd);
1386              else
1387                HufT_build (
1388                  L (0 .. 63), 0, cp_dist_4KB, extra, Td, Bd, huft_incomplete
1389                );
1390                if huft_incomplete then
1391                  HufT_free (Td);
1392                  HufT_free (Tl);
1393                  raise Zip.Archive_corrupted;
1394                end if;
1395                --  Exploding, method: 4k slide, 2 trees
1396                Explode_Nolit (6, Tl, Td, Bl, Bd);
1397              end if;
1398            exception
1399              when others =>
1400                HufT_free (Tl);
1401                raise Zip.Archive_corrupted;
1402            end;
1403            HufT_free (Td);
1404            HufT_free (Tl);
1405          end if;
1406  
1407        end Explode;
1408  
1409        --------[ Method: Copy stored ]--------
1410  
1411        procedure Copy_stored is
1412          size : constant Zip.Zip_64_Data_Size_Type := UnZ_Glob.compsize;
1413          read_in, absorbed : Zip.Zip_64_Data_Size_Type;
1414        begin
1415          absorbed := 0;
1416          if Get_Mode (local_crypto_pack) = encrypted then
1417            absorbed := 12;
1418          end if;
1419          while absorbed < size loop
1420            read_in := size - absorbed;
1421            if read_in > wsize then
1422              read_in := wsize;
1423            end if;
1424            begin
1425              for I in 0 .. read_in - 1 loop
1426                UnZ_Glob.slide (Natural (I)) := UnZ_IO.Read_Byte_Decrypted;
1427              end loop;
1428            exception
1429              when others =>
1430                raise Zip.Archive_corrupted with
1431                  "End of stream reached (format: Store)";
1432            end;
1433            begin
1434              UnZ_IO.Flush (Natural (read_in));  --  Takes care of CRC too
1435            exception
1436              when User_abort =>
1437                raise;
1438              when others =>
1439                raise UnZip.Write_Error;
1440            end;
1441            absorbed := absorbed + read_in;
1442          end loop;
1443        end Copy_stored;
1444  
1445        --------[ Method: Inflate ]--------
1446  
1447        lt_count,     dl_count,
1448        lt_count_0,   dl_count_0,
1449        lt_count_dyn, dl_count_dyn,
1450        lt_count_fix, dl_count_fix : Long_Integer := 0;  --  Statistics of LZ codes per block
1451  
1452        procedure Inflate_Codes (Tl, Td : p_Table_list; Bl, Bd : Integer) is
1453          CT      : p_HufT_table;       -- current table
1454          CT_idx  : Natural;            -- current table's index
1455          length  : Natural;
1456          E       : Integer;      -- table entry flag/number of extra bits
1457          W       : Integer := UnZ_Glob.slide_index;  -- more local variable for slide index
1458          literal : Zip.Byte;
1459        begin
1460          if some_trace then
1461            lt_count_0 := lt_count;
1462            dl_count_0 := dl_count;
1463            Ada.Text_IO.Put_Line ("Begin Inflate_codes");
1464          end if;
1465  
1466          --  inflate the coded data
1467          main_loop :
1468          while not Zip_EOF loop
1469            if Tl = null then
1470              raise Zip.Archive_corrupted with
1471                "Null table list (on data decoding, Huffman tree for literals or LZ lengths)";
1472            end if;
1473            CT := Tl.table;
1474            CT_idx := UnZ_IO.Bit_buffer.Read (Bl);
1475            loop
1476              E := CT (CT_idx).extra_bits;
1477              exit when E <= 16;
1478              if E = invalid then
1479                raise Zip.Archive_corrupted;
1480              end if;
1481  
1482              --  then it's a literal
1483              UnZ_IO.Bit_buffer.Dump (CT (CT_idx).bits);
1484              E := E - 16;
1485              CT := CT (CT_idx).next_table;
1486              CT_idx := UnZ_IO.Bit_buffer.Read (E);
1487            end loop;
1488  
1489            UnZ_IO.Bit_buffer.Dump (CT (CT_idx).bits);
1490  
1491            case E is
1492              when 16 =>      --  CT(CT_idx).N is a Literal (code 0 .. 255)
1493                literal := Zip.Byte (CT (CT_idx).n);
1494                if some_trace then
1495                  lt_count := lt_count + 1;
1496                  Ada.Text_IO.Put (LZ77_dump, "Lit" & Zip.Byte'Image (literal));
1497                  if literal in 32 .. 126 then
1498                    Ada.Text_IO.Put (LZ77_dump, " '" & Character'Val (literal) & ''');
1499                  end if;
1500                  Ada.Text_IO.New_Line (LZ77_dump);
1501                end if;
1502                UnZ_Glob.slide (W) :=  literal;
1503                W := W + 1;
1504                UnZ_IO.Flush_if_full (W);
1505  
1506              when 15 =>      --  End of block (EOB, code 256)
1507                if full_trace then
1508                  Ada.Text_IO.Put_Line ("Exit  Inflate_codes, e=15 -> EOB");
1509                end if;
1510                exit main_loop;
1511  
1512              when others =>  --  We have a length/distance code
1513                if some_trace then
1514                  dl_count := dl_count + 1;
1515                end if;
1516                --  Get length of block to copy:
1517                length := CT (CT_idx).n + UnZ_IO.Bit_buffer.Read_and_dump (E);
1518  
1519                --  Decode distance of block to copy:
1520                if Td = null then
1521                  raise Zip.Archive_corrupted with
1522                    "Null table list (on data decoding, Huffman tree for LZ distances)";
1523                end if;
1524                CT := Td.table;
1525                CT_idx := UnZ_IO.Bit_buffer.Read (Bd);
1526                loop
1527                  E := CT (CT_idx).extra_bits;
1528                  exit when E <= 16;
1529                  if E = invalid then
1530                    raise Zip.Archive_corrupted;
1531                  end if;
1532                  UnZ_IO.Bit_buffer.Dump (CT (CT_idx).bits);
1533                  E := E - 16;
1534                  CT := CT (CT_idx).next_table;
1535                  CT_idx := UnZ_IO.Bit_buffer.Read (E);
1536                end loop;
1537                UnZ_IO.Bit_buffer.Dump (CT (CT_idx).bits);
1538                UnZ_IO.Copy (
1539                  distance    => CT (CT_idx).n + UnZ_IO.Bit_buffer.Read_and_dump (E),
1540                  copy_length => length,
1541                  index       => W
1542                );
1543            end case;
1544          end loop main_loop;
1545  
1546          UnZ_Glob.slide_index := W;
1547  
1548          if some_trace then
1549            Ada.Text_IO.Put_Line ("End   Inflate_codes;  " &
1550              Long_Integer'Image (lt_count - lt_count_0) & " literals," &
1551              Long_Integer'Image (dl_count - dl_count_0) & " DL codes," &
1552              Long_Integer'Image (dl_count + lt_count - lt_count_0 - dl_count_0) & " in total");
1553          end if;
1554        end Inflate_Codes;
1555  
1556        procedure Inflate_stored_block is -- Actually, nothing to inflate
1557          N : Integer;
1558        begin
1559          UnZ_IO.Bit_buffer.Dump_to_byte_boundary;
1560          --  Get the block length and its complement
1561          N := UnZ_IO.Bit_buffer.Read_and_dump (16);
1562          if some_trace then
1563            Ada.Text_IO.Put_Line ("Begin Inflate_stored_block, bytes stored: " & Integer'Image (N));
1564          end if;
1565          if  N /= Integer (
1566           (not UnZ_IO.Bit_buffer.Read_and_dump_U32 (16))
1567           and 16#ffff#)
1568          then
1569            raise Zip.Archive_corrupted;
1570          end if;
1571          while N > 0 and then not Zip_EOF loop
1572            --  Read and output the non-compressed data
1573            N := N - 1;
1574            UnZ_Glob.slide (UnZ_Glob.slide_index) :=
1575              Zip.Byte (UnZ_IO.Bit_buffer.Read_and_dump (8));
1576            UnZ_Glob.slide_index := UnZ_Glob.slide_index + 1;
1577            UnZ_IO.Flush_if_full (UnZ_Glob.slide_index);
1578          end loop;
1579          if some_trace then
1580            Ada.Text_IO.Put_Line ("End   Inflate_stored_block");
1581          end if;
1582        end Inflate_stored_block;
1583  
1584        --  Copy lengths for literal codes 257..285
1585  
1586        copy_lengths_literal : Length_array (0 .. 30) :=
1587               (3,  4,  5,  6,  7,  8,  9, 10, 11, 13, 15, 17, 19, 23, 27, 31,
1588               35, 43, 51, 59, 67, 83, 99, 115, 131, 163, 195, 227, 258, 0, 0);
1589  
1590        --  Extra bits for literal codes 257..285
1591  
1592        extra_bits_literal : Length_array (0 .. 30) :=
1593                (0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 2, 2, 2, 2,
1594                 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 5, 5, 0, invalid, invalid);
1595  
1596        --  Copy offsets for distance codes 0..29 (30..31: deflate_e)
1597  
1598        copy_offset_distance : constant Length_array (0 .. 31) :=
1599              (1, 2, 3, 4, 5, 7, 9, 13, 17, 25, 33, 49, 65, 97, 129, 193,
1600               257, 385, 513, 769, 1025, 1537, 2049, 3073, 4097, 6145,
1601               8193, 12289, 16385, 24577, 32769, 49153);
1602  
1603        --  Extra bits for distance codes
1604  
1605        extra_bits_distance : constant Length_array (0 .. 31) :=
1606              (0, 0, 0, 0, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6,
1607               7, 7, 8, 8, 9, 9, 10, 10, 11, 11, 12, 12, 13, 13, 14, 14);
1608  
1609        max_dist : Integer := 29;  --  changed to 31 for deflate_e
1610  
1611        length_list_for_fixed_block_literals : constant Length_array (0 .. 287) :=
1612            (0 .. 143 => 8, 144 .. 255 => 9, 256 .. 279 => 7, 280 .. 287 => 8);
1613  
1614        procedure Inflate_fixed_block is
1615          Tl,                        --   literal/length code table
1616              Td : p_Table_list;            --  distance code table
1617          Bl, Bd : Integer;          --  lookup bits for tl/bd
1618          huft_incomplete : Boolean;
1619        begin
1620          if some_trace then
1621            Ada.Text_IO.Put_Line ("Begin Inflate_fixed_block");
1622          end if;
1623          --  Make a complete, but wrong [why ?] code set (see Appnote: 5.5.2, RFC 1951: 3.2.6)
1624          Bl := 7;
1625          HufT_build (
1626            length_list_for_fixed_block_literals, 257, copy_lengths_literal,
1627            extra_bits_literal, Tl, Bl, huft_incomplete
1628          );
1629          --  Make an incomplete code set (see Appnote: 5.5.2, RFC 1951: 3.2.6)
1630          Bd := 5;
1631          begin
1632            HufT_build (
1633              (0 .. max_dist => 5), 0,
1634              copy_offset_distance, extra_bits_distance,
1635              Td, Bd, huft_incomplete
1636            );
1637            if huft_incomplete then
1638              if full_trace then
1639                Ada.Text_IO.Put_Line (
1640                  "td is incomplete, pointer=null: " &
1641                  Boolean'Image (Td = null)
1642                );
1643              end if;
1644            end if;
1645          exception
1646            when huft_out_of_memory | huft_error =>
1647              HufT_free (Tl);
1648              raise Zip.Archive_corrupted;
1649          end;
1650          --  Decompress the block's data, until an end-of-block code.
1651          Inflate_Codes (Tl, Td, Bl, Bd);
1652          --  Done with this block, free resources.
1653          HufT_free (Tl);
1654          HufT_free (Td);
1655          if some_trace then
1656            Ada.Text_IO.Put_Line ("End   Inflate_fixed_block");
1657            lt_count_fix := lt_count_fix + (lt_count - lt_count_0);
1658            dl_count_fix := dl_count_fix + (dl_count - dl_count_0);
1659          end if;
1660        end Inflate_fixed_block;
1661  
1662        bit_order_for_dynamic_block : constant array (0 .. 18) of Natural :=
1663           (16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15);
1664  
1665        procedure Inflate_dynamic_block is
1666  
1667          Lbits : constant := 9;
1668          Dbits : constant := 6;
1669  
1670          current_length : Natural;
1671          defined, number_of_lengths : Natural;
1672  
1673          Tl,                             -- literal/length code tables
1674            Td : p_Table_list;            -- distance code tables
1675  
1676          CT     : p_HufT_table;       -- current table
1677          CT_idx : Natural;            -- current table's index
1678  
1679          Bl, Bd : Integer;                  -- lookup bits for tl/bd
1680          Nb : Natural;  -- number of bit length codes
1681          Nl : Natural;  -- number of literal length codes
1682          Nd : Natural;  -- number of distance codes
1683  
1684          --  literal/length and distance code lengths
1685          Ll : Length_array (0 .. 288 + 32 - 1) := (others => 0);
1686  
1687          huft_incomplete : Boolean;
1688  
1689          procedure Repeat_length_code (amount : Natural) is
1690          begin
1691            if defined + amount > number_of_lengths then
1692              raise Zip.Archive_corrupted;
1693            end if;
1694            for c in reverse 1 .. amount loop
1695              Ll (defined) := current_length;
1696              defined := defined + 1;
1697            end loop;
1698          end Repeat_length_code;
1699  
1700        begin
1701          if some_trace then
1702            Ada.Text_IO.Put_Line ("Begin Inflate_dynamic_block");
1703          end if;
1704  
1705          --  Read in table lengths
1706          Nl := 257 + UnZ_IO.Bit_buffer.Read_and_dump (5);
1707          Nd :=   1 + UnZ_IO.Bit_buffer.Read_and_dump (5);
1708          Nb :=   4 + UnZ_IO.Bit_buffer.Read_and_dump (4);
1709  
1710          if Nl > 288 or else Nd > 32 then
1711            raise Zip.Archive_corrupted;
1712          end if;
1713  
1714          --  Read in bit-length-code lengths for decoding the compression structure.
1715          --  The rest, Ll( Bit_Order( Nb .. 18 ) ), is already = 0
1716          for J in  0 .. Nb - 1  loop
1717            Ll (bit_order_for_dynamic_block (J)) := UnZ_IO.Bit_buffer.Read_and_dump (3);
1718          end loop;
1719  
1720          --  Build decoding table for trees--single level, 7 bit lookup
1721          Bl := 7;
1722          begin
1723            HufT_build (
1724              Ll (0 .. 18), 19, empty, empty, Tl, Bl, huft_incomplete
1725            );
1726            if huft_incomplete then
1727              HufT_free (Tl);
1728              raise Zip.Archive_corrupted with "Incomplete code set for compression structure";
1729            end if;
1730          exception
1731            when others =>
1732              raise Zip.Archive_corrupted with "Error when building tables for compression structure";
1733          end;
1734  
1735          --  Read in the compression structure: literal and distance code lengths
1736          number_of_lengths := Nl + Nd;
1737          defined := 0;
1738          current_length := 0;
1739  
1740          while  defined < number_of_lengths  loop
1741            if Tl = null then
1742              raise Zip.Archive_corrupted with
1743              "Null table list (on compression structure)";
1744            end if;
1745            CT := Tl.table;
1746            CT_idx := UnZ_IO.Bit_buffer.Read (Bl);
1747            UnZ_IO.Bit_buffer.Dump (CT (CT_idx).bits);
1748  
1749            case CT (CT_idx).n is
1750              when 0 .. 15 =>     --  Length of code for symbol of index 'defined', in bits (0..15)
1751                current_length := CT (CT_idx).n;
1752                Ll (defined) := current_length;
1753                defined := defined + 1;
1754              when 16 =>          --  16 means: repeat last bit length 3 to 6 times
1755                if defined = 0 then
1756                  --  Nothing in the Ll array has been defined so far. Then, current_length is
1757                  --  (theoretically) undefined and cannot be repeated.
1758                  --  This unspecified case is treated as an error by zlib's inflate.c.
1759                  raise Zip.Archive_corrupted with
1760                    "Illegal data for compression structure (repeat an undefined code length)";
1761                end if;
1762                Repeat_length_code (3 + UnZ_IO.Bit_buffer.Read_and_dump (2));
1763              when 17 =>          --  17 means: the next 3 to 10 symbols' codes have zero bit lengths
1764                current_length := 0;
1765                Repeat_length_code (3 + UnZ_IO.Bit_buffer.Read_and_dump (3));
1766              when 18 =>          --  18 means: the next 11 to 138 symbols' codes have zero bit lengths
1767                current_length := 0;
1768                Repeat_length_code (11 + UnZ_IO.Bit_buffer.Read_and_dump (7));
1769              when others =>      --  Shouldn't occur if this tree is correct
1770                raise Zip.Archive_corrupted with
1771                  "Illegal data for compression structure (values should be in the range 0 .. 18): "
1772                  & Integer'Image (CT (CT_idx).n);
1773            end case;
1774          end loop;
1775          --  Free the Huffman tree that was used for decoding the compression
1776          --  structure, which is contained now in Ll.
1777          HufT_free (Tl);
1778          if Ll (256) = 0 then
1779            --  No code length for the End-Of-Block symbol, implies infinite stream!
1780            --  This case is unspecified but obviously we must stop here.
1781            raise Zip.Archive_corrupted with "No code length for End-Of-Block symbol #256";
1782          end if;
1783          --  Build the decoding tables for literal/length codes
1784          Bl := Lbits;
1785          begin
1786            HufT_build (
1787              Ll (0 .. Nl - 1), 257,
1788              copy_lengths_literal, extra_bits_literal,
1789              Tl, Bl, huft_incomplete
1790            );
1791            if huft_incomplete then
1792              HufT_free (Tl);
1793              raise Zip.Archive_corrupted with "Incomplete code set for literals/lengths";
1794            end if;
1795          exception
1796            when others =>
1797              raise Zip.Archive_corrupted with "Error when building tables for literals/lengths";
1798          end;
1799          --  Build the decoding tables for distance codes
1800          Bd := Dbits;
1801          begin
1802            HufT_build (
1803              Ll (Nl .. Nl + Nd - 1), 0,
1804              copy_offset_distance, extra_bits_distance,
1805              Td, Bd, huft_incomplete
1806            );
1807            if huft_incomplete then
1808              if deflate_strict then
1809                raise Zip.Archive_corrupted with "Incomplete code set for distances";
1810              elsif some_trace then  --  not deflate_strict => don't stop
1811                Ada.Text_IO.Put_Line ("Huffman tree incomplete - PKZIP 1.93a bug workaround");
1812              end if;
1813            end if;
1814          exception
1815            when huft_out_of_memory | huft_error =>
1816              HufT_free (Tl);
1817              raise Zip.Archive_corrupted with "Error when building tables for distances";
1818          end;
1819          --  Decompress the block's data, until an end-of-block code.
1820          Inflate_Codes (Tl, Td, Bl, Bd);
1821          --  Done with this block, free resources.
1822          HufT_free (Tl);
1823          HufT_free (Td);
1824          if some_trace then
1825            Ada.Text_IO.Put_Line ("End   Inflate_dynamic_block");
1826            lt_count_dyn := lt_count_dyn + (lt_count - lt_count_0);
1827            dl_count_dyn := dl_count_dyn + (dl_count - dl_count_0);
1828          end if;
1829        end Inflate_dynamic_block;
1830  
1831        procedure Inflate_Block (last_block : out Boolean; fix, dyn : in out Long_Integer) is
1832        begin
1833          last_block := Boolean'Val (UnZ_IO.Bit_buffer.Read_and_dump (1));
1834          case UnZ_IO.Bit_buffer.Read_and_dump (2) is  --  Block type = 0, 1, 2, 3
1835            when 0 =>      Inflate_stored_block;
1836            when 1 =>      Inflate_fixed_block;
1837                           fix := fix + 1;
1838            when 2 =>      Inflate_dynamic_block;
1839                           dyn := dyn + 1;
1840            when others => raise Zip.Archive_corrupted with "Inflate: Bad block type (3)";
1841          end case;
1842        end Inflate_Block;
1843  
1844        procedure Inflate is
1845          is_last_block : Boolean;
1846          blocks, blocks_fix, blocks_dyn : Long_Integer := 0;
1847        begin
1848          if deflate_e_mode then
1849            copy_lengths_literal (28) := 3;  --  instead of 258
1850            extra_bits_literal (28) := 16;   --  instead of 0
1851            max_dist := 31;
1852          end if;
1853          loop
1854            blocks := blocks + 1;
1855            Inflate_Block (is_last_block, blocks_fix, blocks_dyn);
1856            exit when is_last_block;
1857          end loop;
1858          UnZ_IO.Flush (UnZ_Glob.slide_index);
1859          UnZ_Glob.slide_index := 0;
1860          if some_trace then
1861            Ada.Text_IO.Put_Line (
1862              "# blocks:" & Long_Integer'Image (blocks) &
1863              "; fixed:" & Long_Integer'Image (blocks_fix) &
1864              "; dynamic:" & Long_Integer'Image (blocks_dyn));
1865            if blocks_fix > 0 then
1866              Ada.Text_IO.Put_Line (
1867                "Averages per fixed block: literals:" & Long_Integer'Image (lt_count_fix / blocks_fix) &
1868                "; DL codes:" & Long_Integer'Image (dl_count_fix / blocks_fix) &
1869                "; all codes:" & Long_Integer'Image ((lt_count_fix + dl_count_fix) / blocks_fix));
1870            end if;
1871            if blocks_dyn > 0 then
1872              Ada.Text_IO.Put_Line (
1873                "Averages per dynamic block: literals:" & Long_Integer'Image (lt_count_dyn / blocks_dyn) &
1874                "; DL codes:" & Long_Integer'Image (dl_count_dyn / blocks_dyn) &
1875                "; all codes:" & Long_Integer'Image ((lt_count_dyn + dl_count_dyn) / blocks_dyn));
1876            end if;
1877          end if;
1878        end Inflate;
1879  
1880        procedure Write_Single_Byte (b : Unsigned_8) with Inline is
1881        begin
1882          UnZ_Glob.slide (UnZ_Glob.slide_index) := b;
1883          UnZ_Glob.slide_index := UnZ_Glob.slide_index + 1;
1884          UnZ_IO.Flush_if_full (UnZ_Glob.slide_index);
1885        end Write_Single_Byte;
1886  
1887        --------[ Method: BZip2 ]--------
1888  
1889        procedure Bunzip2 is
1890          package My_BZip2 is new BZip2.Decoding
1891            (Read_Byte  => UnZ_IO.Read_Byte_Decrypted,
1892             Write_Byte => Write_Single_Byte,
1893             check_CRC  => False);  --  CRC check is already done by UnZ_IO
1894        begin
1895          My_BZip2.Decompress;
1896          UnZ_IO.Flush (UnZ_Glob.slide_index);
1897        exception
1898          when E : My_BZip2.bad_header_magic | My_BZip2.bad_block_magic | My_BZip2.data_error =>
1899            raise Zip.Archive_corrupted with
1900              "BZip2 error: " & Exception_Name (E) & " - " & Exception_Message (E);
1901          when E : My_BZip2.randomized_not_yet_implemented =>
1902            raise UnZip.Unsupported_method with
1903              "BZip2: " & Exception_Name (E) & " - " & Exception_Message (E);
1904        end Bunzip2;
1905  
1906        --------[ Method: LZMA ]--------
1907  
1908        procedure LZMA_Decode is
1909          package My_LZMA_Decoding is new LZMA.Decoding (UnZ_IO.Read_Byte_Decrypted, Write_Single_Byte);
1910          b3, b4 : Unsigned_8;
1911        begin
1912          b3 := UnZ_IO.Read_Byte_Decrypted;  --  LZMA SDK major version (e.g.: 9)
1913          b3 := UnZ_IO.Read_Byte_Decrypted;  --  LZMA SDK minor version (e.g.: 20)
1914          b3 := UnZ_IO.Read_Byte_Decrypted;  --  LZMA properties size low byte
1915          b4 := UnZ_IO.Read_Byte_Decrypted;  --  LZMA properties size high byte
1916          if Natural (b3) + 256 * Natural (b4) /= 5 then
1917            raise Zip.Archive_corrupted with "Unexpected LZMA properties block size";
1918          end if;
1919          My_LZMA_Decoding.Decompress
1920            ((has_size               => False,  --  Data size is not part of the LZMA header.
1921              given_size             => LZMA.Data_Bytes_Count (UnZ_Glob.uncompsize),
1922              marker_expected        => explode_slide_8KB_LZMA_EOS,  --  End-Of-Stream marker?
1923              fail_on_bad_range_code => True));
1924          UnZ_IO.Flush (UnZ_Glob.slide_index);
1925        exception
1926          when E : My_LZMA_Decoding.LZMA_Error =>
1927            raise Zip.Archive_corrupted with
1928              "LZMA error: " & Exception_Name (E) & " - " & Exception_Message (E);
1929        end LZMA_Decode;
1930  
1931      end UnZ_Meth;
1932  
1933      procedure Process_descriptor (dd : out Zip.Headers.Data_Descriptor) is
1934        start : Integer;
1935        b : Unsigned_8;
1936        dd_buffer : Zip.Byte_Buffer (1 .. 30);
1937      begin
1938        UnZ_IO.Bit_buffer.Dump_to_byte_boundary;
1939        Set_Mode (local_crypto_pack, clear); -- We are after compressed data, switch off decryption.
1940        b := UnZ_IO.Read_Byte_Decrypted;
1941        if b = 75 then -- 'K' ('P' is before, this is a Java/JAR bug!)
1942          dd_buffer (1) := 80;
1943          dd_buffer (2) := 75;
1944          start := 3;
1945        else
1946          dd_buffer (1) := b; -- hopefully = 80 (will be checked)
1947          start := 2;
1948        end if;
1949        for i in start .. 16 loop
1950          dd_buffer (i) := UnZ_IO.Read_Byte_Decrypted;
1951        end loop;
1952        Zip.Headers.Copy_and_Check (dd_buffer, dd);
1953      exception
1954        when Zip.Headers.bad_data_descriptor =>
1955          raise Zip.Archive_corrupted;
1956      end Process_descriptor;
1957  
1958      work_index : Zip_Streams.ZS_Index_Type;
1959      use Zip, UnZ_Meth, Ada.Strings.Unbounded;
1960  
1961    begin  --  Decompress_Data
1962      if some_trace then
1963        Ada.Text_IO.Create (LZ77_dump, Ada.Text_IO.Out_File, "dump.lz77");
1964      end if;
1965      output_memory_access := null;
1966      --  ^ this is an 'out' parameter, we have to set it anyway
1967      case write_mode is
1968        when write_to_binary_file =>
1969           Ada.Streams.Stream_IO.Create (UnZ_IO.out_bin_file, Ada.Streams.Stream_IO.Out_File, output_file_name,
1970                                           Form => To_String (Zip_Streams.Form_For_IO_Open_and_Create));
1971        when write_to_text_file =>
1972           Ada.Text_IO.Create (UnZ_IO.out_txt_file, Ada.Text_IO.Out_File, output_file_name,
1973                                 Form => To_String (Zip_Streams.Form_For_IO_Open_and_Create));
1974        when write_to_memory =>
1975          output_memory_access := new
1976            Ada.Streams.Stream_Element_Array (
1977              1 .. Ada.Streams.Stream_Element_Offset (hint.dd.uncompressed_size)
1978            );
1979          UnZ_Glob.uncompressed_index := output_memory_access'First;
1980        when write_to_stream | just_test =>
1981          null;
1982      end case;
1983  
1984      UnZ_Glob.compsize   := hint.dd.compressed_size;
1985      UnZ_Glob.uncompsize := hint.dd.uncompressed_size;
1986      UnZ_IO.Init_Buffers;
1987      if is_encrypted then
1988        Set_Mode (local_crypto_pack, encrypted);
1989        work_index := Zip_Streams.Index (zip_file);
1990        password_passes : for pass in 1 .. tolerance_wrong_password loop
1991          begin
1992            Init_Decryption (To_String (password), hint.dd.crc_32);
1993            exit password_passes; -- the current password fits, then go on!
1994          exception
1995            when Wrong_password =>
1996              if pass = tolerance_wrong_password then
1997                raise;
1998              elsif get_new_password /= null then
1999                get_new_password (password);  --  ask for a new one
2000              end if;
2001          end;
2002          --  Go back to data beginning:
2003          begin
2004            Zip_Streams.Set_Index (zip_file, work_index);
2005          exception
2006            when others =>
2007              raise UnZip.Read_Error with "Failure after password interaction";
2008          end;
2009          UnZ_IO.Init_Buffers;
2010        end loop password_passes;
2011      else
2012        Set_Mode (local_crypto_pack, clear);
2013      end if;
2014  
2015      --  UnZip correct type
2016      begin
2017        case format is
2018          when store          => Copy_stored;
2019          when shrink         => Unshrink;
2020          when Reduce_Format  => Unreduce (1 + Reduce_Format'Pos (format) - Reduce_Format'Pos (reduce_1));
2021          when implode        =>
2022            UnZ_Meth.Explode (explode_literal_tree, explode_slide_8KB_LZMA_EOS);
2023          when deflate | deflate_e =>
2024            UnZ_Meth.deflate_e_mode := format = deflate_e;
2025            UnZ_Meth.Inflate;
2026          when Zip.bzip2_meth => UnZ_Meth.Bunzip2;
2027          when Zip.lzma_meth  => UnZ_Meth.LZMA_Decode;
2028          when others =>
2029            raise Unsupported_method with
2030              "Format/method " & Image (format) &
2031              " not supported for decompression";
2032        end case;
2033      exception
2034        when others =>
2035          UnZ_IO.Delete_output;
2036          raise;
2037      end;
2038      UnZ_Glob.crc32val := Zip.CRC_Crypto.Final (UnZ_Glob.crc32val);
2039      --  Decompression done !
2040  
2041      if data_descriptor_after_data then  --  Sizes and CRC at the end
2042        declare
2043          memo_uncomp_size : constant Zip.Zip_64_Data_Size_Type := hint.dd.uncompressed_size;
2044        begin
2045          Process_descriptor (hint.dd);  --  CRC is for checking; sizes are for informing user
2046          if memo_uncomp_size < Zip_64_Data_Size_Type (Zip_32_Data_Size_Type'Last) and then --
2047             memo_uncomp_size /= hint.dd.uncompressed_size
2048          then
2049            UnZ_IO.Delete_output;
2050            raise Uncompressed_Size_Error
2051              with "Uncompressed size mismatch: in catalogue:" & memo_uncomp_size'Image &
2052                   "; in post-data data descriptor:" & hint.dd.uncompressed_size'Image;
2053          end if;
2054        end;
2055      end if;
2056  
2057      if hint.dd.crc_32 /= UnZ_Glob.crc32val then
2058        UnZ_IO.Delete_output;
2059        raise CRC_Error with
2060          "CRC stored in archive: " & Hexadecimal (hint.dd.crc_32) &
2061          "; CRC computed now: " & Hexadecimal (UnZ_Glob.crc32val);
2062      end if;
2063  
2064      case write_mode is
2065        when write_to_binary_file =>
2066          Ada.Streams.Stream_IO.Close (UnZ_IO.out_bin_file);
2067        when write_to_text_file =>
2068          Ada.Text_IO.Close (UnZ_IO.out_txt_file);
2069        when write_to_memory | write_to_stream | just_test =>
2070          null;  --  Nothing to close!
2071      end case;
2072      if some_trace then
2073        Ada.Text_IO.Close (LZ77_dump);
2074      end if;
2075  
2076    exception
2077      when others =>  --  close the file in case of an error, if not yet closed
2078        case write_mode is  --  or deleted
2079          when write_to_binary_file =>
2080            if Ada.Streams.Stream_IO.Is_Open (UnZ_IO.out_bin_file) then
2081              Ada.Streams.Stream_IO.Close (UnZ_IO.out_bin_file);
2082            end if;
2083          when write_to_text_file =>
2084            if Ada.Text_IO.Is_Open (UnZ_IO.out_txt_file) then
2085              Ada.Text_IO.Close (UnZ_IO.out_txt_file);
2086            end if;
2087          when write_to_memory | write_to_stream | just_test =>
2088            null;  --  Nothing to close!
2089        end case;
2090        raise;
2091    end Decompress_Data;
2092  
2093  end UnZip.Decompress;

Web view of Ada source code generated by GNATHTML, project: ALI_Parse version 1.0.
Zip-Ada: Ada library for zip archive files (.zip). Ada programming.
Some news about Zip-Ada and other Ada projects on Gautier's blog.