1. with Zip.Headers; 
  2.  
  3. with Ada.Characters.Handling; 
  4. with Ada.Unchecked_Deallocation; 
  5. with Ada.Exceptions; 
  6. with Ada.IO_Exceptions; 
  7. with Ada.Strings.Fixed; 
  8.  
  9. package body Zip is 
  10.  
  11.    use Interfaces; 
  12.  
  13.    procedure Dispose is new Ada.Unchecked_Deallocation (Dir_node, p_Dir_node); 
  14.    procedure Dispose is new Ada.Unchecked_Deallocation (String, p_String); 
  15.  
  16.    package Binary_tree_rebalancing is 
  17.       procedure Rebalance (root : in out p_Dir_node); 
  18.    end Binary_tree_rebalancing; 
  19.  
  20.    package body Binary_tree_rebalancing is 
  21.  
  22.       ------------------------------------------------------------------- 
  23.       -- Tree Rebalancing in Optimal Time and Space                    -- 
  24.       -- QUENTIN F. STOUT and BETTE L. WARREN                          -- 
  25.       -- Communications of the ACM September 1986 Volume 29 Number 9   -- 
  26.       ------------------------------------------------------------------- 
  27.       -- http://www.eecs.umich.edu/~qstout/pap/CACM86.pdf 
  28.       -- 
  29.       -- Translated by (New) P2Ada v. 15 - Nov - 2006 
  30.  
  31.       procedure Tree_to_vine (root : p_Dir_node; size : out Integer) is 
  32.          --  transform the tree with pseudo - root 
  33.          --   "root^" into a vine with pseudo - root 
  34.          --   node "root^", and store the number of 
  35.          --   nodes in "size" 
  36.  
  37.          vine_tail, remainder, temp : p_Dir_node; 
  38.  
  39.       begin 
  40.          vine_tail := root; 
  41.          remainder := vine_tail.all.right; 
  42.          size := 0; 
  43.          while remainder /= null loop 
  44.             if remainder.all.left = null then 
  45.                --  move vine - tail down one: 
  46.                vine_tail := remainder; 
  47.                remainder := remainder.all.right; 
  48.                size := size + 1; 
  49.             else 
  50.                --  rotate: 
  51.                temp := remainder.all.left; 
  52.                remainder.all.left := temp.all.right; 
  53.                temp.all.right := remainder; 
  54.                remainder := temp; 
  55.                vine_tail.all.right := temp; 
  56.             end if; 
  57.          end loop; 
  58.       end Tree_to_vine; 
  59.  
  60.       procedure Vine_to_tree (root : p_Dir_node; size_given : Integer) is 
  61.          --  convert the vine with "size" nodes and pseudo - root 
  62.          --  node "root^" into a balanced tree 
  63.          leaf_count : Integer; 
  64.          size  : Integer := size_given; 
  65.  
  66.          procedure Compression (Dir_Root : p_Dir_node; count : Integer) is 
  67.             --  compress "count" spine nodes in the tree with pseudo - root "root^" 
  68.             scanner, child : p_Dir_node; 
  69.          begin 
  70.             scanner := Dir_Root; 
  71.             for i in 1 .. count loop 
  72.                child := scanner.all.right; 
  73.                scanner.all.right := child.all.right; 
  74.                scanner := scanner.all.right; 
  75.                child.all.right := scanner.all.left; 
  76.                scanner.all.left := child; 
  77.             end loop; 
  78.          end Compression; 
  79.  
  80.          -- Returns n - 2 ** Integer (Float'Floor (log (Float (n)) / log (2.0))) 
  81.          -- without Float - Point calculation and rounding errors with too short floats 
  82.          function Remove_leading_binary_1 (n : Integer) return Integer is 
  83.             x : Integer := 2**16; -- supposed maximum 
  84.          begin 
  85.             if n < 1 then 
  86.                return n; 
  87.             end if; 
  88.             while n mod x = n loop 
  89.                x := x / 2; 
  90.             end loop; 
  91.             return n mod x; 
  92.          end Remove_leading_binary_1; 
  93.  
  94.       begin --  Vine_to_tree 
  95.          leaf_count := Remove_leading_binary_1 (size + 1); 
  96.          Compression (root, leaf_count); -- create deepest leaves 
  97.          -- use Perfect_leaves instead for a perfectly balanced tree 
  98.          size := size - leaf_count; 
  99.          while size > 1 loop 
  100.             Compression (root, size / 2); 
  101.             size := size / 2; 
  102.          end loop; 
  103.       end Vine_to_tree; 
  104.  
  105.       procedure Rebalance (root : in out p_Dir_node) is 
  106.          --  Rebalance the binary search tree with root "root.all", 
  107.          --  with the result also rooted at "root.all". 
  108.          --  Uses the Tree_to_vine and Vine_to_tree procedures. 
  109.          pseudo_root : p_Dir_node; 
  110.          size : Integer; 
  111.       begin 
  112.          pseudo_root := new Dir_node (name_len => 0); 
  113.          pseudo_root.all.right := root; 
  114.          Tree_to_vine (pseudo_root, size); 
  115.          Vine_to_tree (pseudo_root, size); 
  116.          root := pseudo_root.all.right; 
  117.          Dispose (pseudo_root); 
  118.       end Rebalance; 
  119.  
  120.    end Binary_tree_rebalancing; 
  121.  
  122.    -- 19 - Jun - 2001 : Enhanced file name identification 
  123.    --              a) when case insensitive  - > all UPPER (current) 
  124.    --              b) '\' and '/' identified - > all '/'   (new) 
  125.  
  126.    function Normalize (s : String; case_sensitive : Boolean) return String is 
  127.       sn : String (s'Range); 
  128.    begin 
  129.       if case_sensitive then 
  130.          sn := s; 
  131.       else 
  132.          sn := Ada.Characters.Handling.To_Upper (s); 
  133.       end if; 
  134.       for i in sn'Range loop 
  135.          if sn (i) = '\' then 
  136.             sn (i) := '/'; 
  137.          end if; 
  138.       end loop; 
  139.       return sn; 
  140.    end Normalize; 
  141.  
  142.    ------------------------------------------------------------- 
  143.    -- Load Zip_info from a stream containing the .zip archive -- 
  144.    ------------------------------------------------------------- 
  145.  
  146.    procedure Load (info            : out Zip_info; 
  147.                    from            :     Zip_Streams.Zipstream_Class; 
  148.                    case_sensitive  :     Boolean := False) is 
  149.  
  150.       procedure Insert (dico_name         :        String; -- UPPER if case - insensitive search 
  151.                         file_name         :        String; 
  152.                         file_index        :        Ada.Streams.Stream_IO.Positive_Count; 
  153.                         comp_size, 
  154.                         uncomp_size       :        File_size_type; 
  155.                         crc_32            :        Unsigned_32; 
  156.                         date_time         :        Time; 
  157.                         method            :        PKZip_method; 
  158.                         unicode_file_name :        Boolean; 
  159.                         node              : in out p_Dir_node) is 
  160.  
  161.       begin 
  162.          if node = null then 
  163.             node := new Dir_node' 
  164.               ((name_len          => file_name'Length, 
  165.                 left              => null, 
  166.                 right             => null, 
  167.                 dico_name         => dico_name, 
  168.                 file_name         => file_name, 
  169.                 file_index        => file_index, 
  170.                 comp_size         => comp_size, 
  171.                 uncomp_size       => uncomp_size, 
  172.                 crc_32            => crc_32, 
  173.                 date_time         => date_time, 
  174.                 method            => method, 
  175.                 unicode_file_name => unicode_file_name 
  176.                ) 
  177.               ); 
  178.          elsif dico_name > node.all.dico_name then 
  179.             Insert (dico_name, file_name, file_index, comp_size, uncomp_size, crc_32, date_time, method, unicode_file_name, node.all.right); 
  180.          elsif dico_name < node.all.dico_name then 
  181.             Insert (dico_name, file_name, file_index, comp_size, uncomp_size, crc_32, date_time, method, unicode_file_name, node.all.left); 
  182.          else 
  183.             raise Duplicate_name; 
  184.          end if; 
  185.       end Insert; 
  186.  
  187.       the_end : Zip.Headers.End_of_Central_Dir; 
  188.       header  : Zip.Headers.Central_File_Header; 
  189.       p       : p_Dir_node := null; 
  190.       zip_info_already_loaded : exception; 
  191.       main_comment : p_String; 
  192.       use Ada.Streams, Ada.Streams.Stream_IO; 
  193.    begin -- Load Zip_info 
  194.       if info.loaded then 
  195.          raise zip_info_already_loaded; 
  196.       end if; -- 15 - Apr - 2002 
  197.       Zip.Headers.Load (from, the_end); 
  198.       -- We take the opportunity to read the main comment, which is right 
  199.       -- after the end - of - central - directory block. 
  200.       main_comment := new String (1 .. Integer (the_end.main_comment_length)); 
  201.       String'Read (from, main_comment.all); 
  202.       -- Process central directory: 
  203.       Zip_Streams.Set_Index ( 
  204.                              from, 
  205.                              Positive ( 
  206.                                1 + 
  207.                                  the_end.offset_shifting + the_end.central_dir_offset 
  208.                               ) 
  209.                             ); 
  210.  
  211.       for i in 1 .. the_end.total_entries loop 
  212.          Zip.Headers.Read_and_check (from, header); 
  213.          declare 
  214.             this_name : String (1 .. Natural (header.short_info.filename_length)); 
  215.          begin 
  216.             String'Read (from, this_name); 
  217.             -- Skip extra field and entry comment. 
  218.             Zip_Streams.Set_Index ( 
  219.                                    from, Positive ( 
  220.                                      Ada.Streams.Stream_IO.Count (Zip_Streams.Index (from)) + 
  221.                                        Ada.Streams.Stream_IO.Count ( 
  222.                                          header.short_info.extra_field_length + 
  223.                                            header.comment_length 
  224.                                         )) 
  225.                                   ); 
  226.             -- Now the whole i_th central directory entry is behind 
  227.             Insert (dico_name   => Normalize (this_name, case_sensitive), 
  228.                     file_name   => Normalize (this_name, True), 
  229.                     file_index  => Ada.Streams.Stream_IO.Count 
  230.                       (1 + header.local_header_offset + the_end.offset_shifting), 
  231.                     comp_size   => header.short_info.dd.compressed_size, 
  232.                     uncomp_size => header.short_info.dd.uncompressed_size, 
  233.                     crc_32      => header.short_info.dd.crc_32, 
  234.                     date_time   => header.short_info.file_timedate, 
  235.                     method      => Method_from_code (header.short_info.zip_type), 
  236.                     unicode_file_name => 
  237.                       (header.short_info.bit_flag and 
  238.                          Zip.Headers.Language_Encoding_Flag_Bit) /= 0, 
  239.                     node        => p); 
  240.             -- Since the files are usually well ordered, the tree as inserted 
  241.             -- is very unbalanced; we need to rebalance it from time to time 
  242.             -- during loading, otherwise the insertion slows down dramatically 
  243.             -- for zip files with plenty of files - converges to 
  244.             -- O (total_entries ** 2) .. . 
  245.             if i mod 256 = 0 then 
  246.                Binary_tree_rebalancing.Rebalance (p); 
  247.             end if; 
  248.          end; 
  249.       end loop; 
  250.       Binary_tree_rebalancing.Rebalance (p); 
  251.       info := (loaded           => True, 
  252.                zip_file_name    => new String'("This is a stream, no direct file!"), 
  253.                zip_input_stream => from, 
  254.                dir_binary_tree  => p, 
  255.                total_entries    => Integer (the_end.total_entries), 
  256.                zip_file_comment => main_comment 
  257.               ); 
  258.    end Load; 
  259.  
  260.    ----------------------------------------------------------- 
  261.    -- Load Zip_info from a file containing the .zip archive -- 
  262.    ----------------------------------------------------------- 
  263.  
  264.    procedure Load (info            : out Zip_info; 
  265.                    from            :     String; -- Zip file name 
  266.                    case_sensitive  :     Boolean := False) is 
  267.  
  268.       use Zip_Streams; 
  269.  
  270.       MyStream    : aliased File_Zipstream; 
  271.       StreamFile  : constant Zipstream_Class := MyStream'Unchecked_Access; 
  272.  
  273.    begin 
  274.       Set_Name (StreamFile, from); 
  275.       begin 
  276.          Open (MyStream, Ada.Streams.Stream_IO.In_File); 
  277.       exception 
  278.          when others => 
  279.             Ada.Exceptions.Raise_Exception 
  280.               (Zip_file_open_Error'Identity, "Archive : [" & from & ']'); 
  281.       end; 
  282.       -- Call the stream version of Load ( .. .) 
  283.       Load ( 
  284.             info, 
  285.             StreamFile, 
  286.             case_sensitive 
  287.            ); 
  288.       Close (MyStream); 
  289.       Dispose (info.zip_file_name); 
  290.       info.zip_file_name := new String'(from); 
  291.       info.zip_input_stream := null; -- forget about the stream! 
  292.    end Load; 
  293.  
  294.    function Is_loaded (info : Zip_info) return Boolean is (info.loaded); 
  295.  
  296.    function Zip_name (info : Zip_info) return String is 
  297.  
  298.    begin 
  299.       if not info.loaded then 
  300.          raise Forgot_to_load_zip_info; 
  301.       end if; 
  302.       return info.zip_file_name.all; 
  303.    end Zip_name; 
  304.  
  305.    function Zip_comment (info : Zip_info) return String is 
  306.  
  307.    begin 
  308.       if not info.loaded then 
  309.          raise Forgot_to_load_zip_info; 
  310.       end if; 
  311.       return info.zip_file_comment.all; 
  312.    end Zip_comment; 
  313.  
  314.    function Zip_Stream (info : Zip_info) return Zip_Streams.Zipstream_Class is 
  315.  
  316.    begin 
  317.       if not info.loaded then 
  318.          raise Forgot_to_load_zip_info; 
  319.       end if; 
  320.       return info.zip_input_stream; 
  321.    end Zip_Stream; 
  322.  
  323.    function Entries (info : Zip_info) return Natural is (info.total_entries); 
  324.  
  325.    ------------ 
  326.    -- Delete -- 
  327.    ------------ 
  328.  
  329.    procedure Delete (info  : in out Zip_info) is 
  330.  
  331.       procedure Delete (p : in out p_Dir_node) is 
  332.       begin 
  333.          if p /= null then 
  334.             Delete (p.all.left); 
  335.             Delete (p.all.right); 
  336.             Dispose (p); 
  337.             p := null; 
  338.          end if; 
  339.       end Delete; 
  340.  
  341.    begin 
  342.       if not info.loaded then 
  343.          raise Forgot_to_load_zip_info; 
  344.       end if; 
  345.       Delete (info.dir_binary_tree); 
  346.       Dispose (info.zip_file_name); 
  347.       info.loaded := False; -- < -- added 14 - Jan - 2002 
  348.    end Delete; 
  349.  
  350.    -- Traverse a whole Zip_info directory in sorted order, giving the 
  351.    -- name for each entry to an user - defined "Action" procedure. 
  352.    -- Added 29 - Nov - 2002 
  353.    procedure Traverse (z : Zip_info) is 
  354.  
  355.       procedure Traverse (p : p_Dir_node) is 
  356.  
  357.       begin 
  358.          if p /= null then 
  359.             Traverse (p.all.left); 
  360.             Action (p.all.file_name); 
  361.             Traverse (p.all.right); 
  362.          end if; 
  363.       end Traverse; 
  364.  
  365.    begin 
  366.       Traverse (z.dir_binary_tree); 
  367.    end Traverse; 
  368.  
  369.    procedure Traverse_verbose (z : Zip_info) is 
  370.  
  371.       procedure Traverse_verbose_recursive (p : p_Dir_node) is 
  372.  
  373.       begin 
  374.          if p /= null then 
  375.             Traverse_verbose_recursive (p.all.left); 
  376.             Action (p.all.file_name, 
  377.                     Positive (p.all.file_index), 
  378.                     p.all.comp_size, 
  379.                     p.all.uncomp_size, 
  380.                     p.all.crc_32, 
  381.                     p.all.date_time, 
  382.                     p.all.method, 
  383.                     p.all.unicode_file_name); 
  384.             Traverse_verbose_recursive (p.all.right); 
  385.          end if; 
  386.       end Traverse_verbose_recursive; 
  387.  
  388.    begin 
  389.       Traverse_verbose_recursive (z.dir_binary_tree); 
  390.    end Traverse_verbose; 
  391.  
  392.    procedure Tree_stat (z         :     Zip_info; 
  393.                         total     : out Natural; 
  394.                         max_depth : out Natural; 
  395.                         avg_depth : out Float) is 
  396.  
  397.       sum_depth : Natural := 0; 
  398.  
  399.       procedure Traverse_stat_recursive (p : p_Dir_node; depth : Natural) is 
  400.  
  401.       begin 
  402.          if p /= null then 
  403.             total := total + 1; 
  404.             if depth > max_depth then 
  405.                max_depth := depth; 
  406.             end if; 
  407.             sum_depth := sum_depth + depth; 
  408.             Traverse_stat_recursive (p.all.left, depth + 1); 
  409.             Traverse_stat_recursive (p.all.right, depth + 1); 
  410.          end if; 
  411.       end Traverse_stat_recursive; 
  412.  
  413.    begin 
  414.       total := 0; 
  415.       max_depth := 0; 
  416.       Traverse_stat_recursive (z.dir_binary_tree, 0); 
  417.       if total = 0 then 
  418.          avg_depth := 0.0; 
  419.       else 
  420.          avg_depth := Float (sum_depth) / Float (total); 
  421.       end if; 
  422.    end Tree_stat; 
  423.  
  424.    -- 13 - May - 2001 : Find_first_offset 
  425.  
  426.    -- For an all - files unzipping of an appended (e.g. self - extracting) archive 
  427.    -- (not beginning with ZIP contents), we cannot start with 
  428.    -- index 1 in file. 
  429.    -- But the offset of first entry in ZIP directory is not valid either, 
  430.    -- as this excerpt of appnote.txt states: 
  431.  
  432.    -- "   4)  The entries in the central directory may not necessarily 
  433.    --         be in the same order that files appear in the zipfile.    " 
  434.  
  435.    procedure Find_first_offset (file            :     Zip_Streams.Zipstream_Class; 
  436.                                 file_index      : out Positive) is 
  437.  
  438.       the_end    : Zip.Headers.End_of_Central_Dir; 
  439.       header     : Zip.Headers.Central_File_Header; 
  440.       min_offset : File_size_type; 
  441.  
  442.       use Ada.Streams.Stream_IO, Zip_Streams; 
  443.  
  444.    begin 
  445.       Zip.Headers.Load (file, the_end); 
  446.       Set_Index ( 
  447.                  file, Positive (1 + the_end.offset_shifting + the_end.central_dir_offset) 
  448.                 ); 
  449.  
  450.       min_offset := the_end.central_dir_offset; -- will be lowered 
  451.  
  452.       for i in 1 .. the_end.total_entries loop 
  453.          declare 
  454.             TempStream  : constant Zip_Streams.Zipstream_Class := file; 
  455.          begin 
  456.             Zip.Headers.Read_and_check (TempStream, header); 
  457.          end; 
  458.  
  459.          Set_Index (file, Index (file) + 
  460.                       Positive 
  461.                         (header.short_info.filename_length + 
  462.                              header.short_info.extra_field_length + 
  463.                                header.comment_length)); 
  464.          -- Now the whole i_th central directory entry is behind 
  465.  
  466.          if header.local_header_offset < min_offset then 
  467.             min_offset := header.local_header_offset; 
  468.          end if; 
  469.       end loop; 
  470.  
  471.       file_index := Positive (1 + min_offset + the_end.offset_shifting); 
  472.  
  473.    end Find_first_offset; 
  474.  
  475.    -- Internal : find offset of a zipped file by reading sequentially the 
  476.    -- central directory : - ( 
  477.  
  478.    procedure Find_offset (file            :     Zip_Streams.Zipstream_Class; 
  479.                           name            :     String; 
  480.                           case_sensitive  :     Boolean; 
  481.                           file_index      : out Positive; 
  482.                           comp_size       : out File_size_type; 
  483.                           uncomp_size     : out File_size_type) is 
  484.  
  485.       the_end : Zip.Headers.End_of_Central_Dir; 
  486.  
  487.       header  : Zip.Headers.Central_File_Header; 
  488.  
  489.       use Ada.Streams, Ada.Streams.Stream_IO, Zip_Streams; 
  490.  
  491.    begin 
  492.       Zip.Headers.Load (file, the_end); 
  493.       Set_Index (file, Positive (1 + the_end.central_dir_offset + the_end.offset_shifting)); 
  494.       for i in 1 .. the_end.total_entries loop 
  495.          declare 
  496.             TempStream  : constant Zipstream_Class := file; 
  497.          begin 
  498.             Zip.Headers.Read_and_check (TempStream, header); 
  499.          end; 
  500.          declare 
  501.             this_name : String (1 .. Natural (header.short_info.filename_length)); 
  502.          begin 
  503.             String'Read (file, this_name); 
  504.             Set_Index (file, Index (file) + 
  505.                          Natural (Ada.Streams.Stream_IO.Count 
  506.                            (header.short_info.extra_field_length + 
  507.                                 header.comment_length))); 
  508.             -- Now the whole i_th central directory entry is behind 
  509.             if Normalize (this_name, case_sensitive) = 
  510.               Normalize (name, case_sensitive) 
  511.             then 
  512.                -- Name found in central directory ! 
  513.                file_index := Positive (1 + header.local_header_offset + the_end.offset_shifting); 
  514.                comp_size  := File_size_type (header.short_info.dd.compressed_size); 
  515.                uncomp_size := File_size_type (header.short_info.dd.uncompressed_size); 
  516.                return; 
  517.             end if; 
  518.          end; 
  519.       end loop; 
  520.       raise File_name_not_found; 
  521.    end Find_offset; 
  522.  
  523.    -- Internal : find offset of a zipped file using the zip_info tree 8 - ) 
  524.  
  525.    procedure Find_offset (info            :     Zip_info; 
  526.                           name            :     String; 
  527.                           case_sensitive  :     Boolean; 
  528.                           file_index      : out Ada.Streams.Stream_IO.Positive_Count; 
  529.                           comp_size       : out File_size_type; 
  530.                           uncomp_size     : out File_size_type) is 
  531.  
  532.       aux : p_Dir_node := info.dir_binary_tree; 
  533.       up_name : String := Normalize (name, case_sensitive); 
  534.  
  535.    begin 
  536.       if not info.loaded then 
  537.          raise Forgot_to_load_zip_info; 
  538.       end if; 
  539.       while aux /= null loop 
  540.          if up_name > aux.all.dico_name then 
  541.             aux := aux.all.right; 
  542.          elsif up_name < aux.all.dico_name then 
  543.             aux := aux.all.left; 
  544.          else  -- file found ! 
  545.             file_index := aux.all.file_index; 
  546.             comp_size  := aux.all.comp_size; 
  547.             uncomp_size := aux.all.uncomp_size; 
  548.             return; 
  549.          end if; 
  550.       end loop; 
  551.       Ada.Exceptions.Raise_Exception ( 
  552.                                       File_name_not_found'Identity, 
  553.                                       "Archive : [" & info.zip_file_name.all & "], entry : [" & name & ']' 
  554.                                      ); 
  555.    end Find_offset; 
  556.  
  557.    procedure Get_sizes (info            :     Zip_info; 
  558.                         name            :     String; 
  559.                         case_sensitive  :     Boolean; 
  560.                         comp_size       : out File_size_type; 
  561.                         uncomp_size     : out File_size_type) is 
  562.  
  563.       dummy_file_index : Ada.Streams.Stream_IO.Positive_Count; 
  564.  
  565.    begin 
  566.       Find_offset (info, name, case_sensitive, dummy_file_index, comp_size, uncomp_size); 
  567.       pragma Unreferenced (dummy_file_index); 
  568.    end Get_sizes; 
  569.  
  570.    -- Workaround for the severe xxx'Read xxx'Write performance 
  571.    -- problems in the GNAT and ObjectAda compilers (as in 2009) 
  572.    -- This is possible if and only if Byte = Stream_Element and 
  573.    -- arrays types are both packed and aligned the same way. 
  574.    -- 
  575.    subtype Size_test_a is Byte_Buffer (1 .. 19); 
  576.    subtype Size_test_b is Ada.Streams.Stream_Element_Array (1 .. 19); 
  577.    workaround_possible : constant Boolean := 
  578.      Size_test_a'Size = Size_test_b'Size and then 
  579.      Size_test_a'Alignment = Size_test_b'Alignment; 
  580.  
  581.    -- BlockRead - general - purpose procedure (nothing really specific 
  582.    -- to Zip / UnZip) : reads either the whole buffer from a file, or 
  583.    -- if the end of the file lays inbetween, a part of the buffer. 
  584.  
  585.    procedure BlockRead (file          :     Ada.Streams.Stream_IO.File_Type; 
  586.                         buffer        : out Byte_Buffer; 
  587.                         actually_read : out Natural) is 
  588.  
  589.       use Ada.Streams, Ada.Streams.Stream_IO; 
  590.  
  591.       SE_Buffer    : Stream_Element_Array (1 .. buffer'Length); 
  592.       for SE_Buffer'Address use buffer'Address; 
  593.       pragma Import (Ada, SE_Buffer); 
  594.  
  595.       Last_Read    : Stream_Element_Offset; 
  596.  
  597.    begin 
  598.       if workaround_possible then 
  599.          Read (Stream (file).all, SE_Buffer, Last_Read); 
  600.          actually_read := Natural (Last_Read); 
  601.       else 
  602.          if End_Of_File (file) then 
  603.             actually_read := 0; 
  604.          else 
  605.             actually_read := 
  606.               Integer'Min (buffer'Length, Integer (Size (file) - Index (file) + 1)); 
  607.             Byte_Buffer'Read ( 
  608.                               Stream (file), 
  609.                               buffer (buffer'First .. buffer'First + actually_read - 1) 
  610.                              ); 
  611.          end if; 
  612.       end if; 
  613.    end BlockRead; 
  614.  
  615.    procedure BlockRead (stream        :     Zip_Streams.Zipstream_Class; 
  616.                         buffer        : out Byte_Buffer; 
  617.                         actually_read : out Natural) is 
  618.  
  619.       use Ada.Streams, Ada.Streams.Stream_IO, Zip_Streams; 
  620.  
  621.       SE_Buffer    : Stream_Element_Array (1 .. buffer'Length); 
  622.       for SE_Buffer'Address use buffer'Address; 
  623.       pragma Import (Ada, SE_Buffer); 
  624.  
  625.       Last_Read    : Stream_Element_Offset; 
  626.  
  627.    begin 
  628.       if workaround_possible then 
  629.          Read (stream.all, SE_Buffer, Last_Read); 
  630.          actually_read := Natural (Last_Read); 
  631.       else 
  632.          if End_Of_Stream (stream) then 
  633.             actually_read := 0; 
  634.          else 
  635.             actually_read := Integer'Min (buffer'Length, Integer (Size (stream) - Index (stream) + 1)); 
  636.             Byte_Buffer'Read (stream, buffer (buffer'First .. buffer'First + actually_read - 1)); 
  637.          end if; 
  638.       end if; 
  639.    end BlockRead; 
  640.  
  641.    procedure BlockRead (stream  :     Zip_Streams.Zipstream_Class; 
  642.                         buffer  : out Byte_Buffer) is 
  643.  
  644.       actually_read : Natural; 
  645.  
  646.    begin 
  647.       BlockRead (stream, buffer, actually_read); 
  648.       if actually_read < buffer'Length then 
  649.          raise Ada.IO_Exceptions.End_Error; 
  650.       end if; 
  651.    end BlockRead; 
  652.  
  653.    procedure BlockWrite (stream  : in out Ada.Streams.Root_Stream_Type'Class; 
  654.                          buffer  :        Byte_Buffer) is 
  655.  
  656.       use Ada.Streams; 
  657.  
  658.       SE_Buffer    : Stream_Element_Array (1 .. buffer'Length); 
  659.       for SE_Buffer'Address use buffer'Address; 
  660.       pragma Import (Ada, SE_Buffer); 
  661.  
  662.    begin 
  663.       if workaround_possible then 
  664.          Ada.Streams.Write (stream, SE_Buffer); 
  665.       else 
  666.          Byte_Buffer'Write (stream'Access, buffer); 
  667.          -- ^This is 30x to 70x slower on GNAT 2009 ! 
  668.       end if; 
  669.    end BlockWrite; 
  670.  
  671.    function Method_from_code (x : Natural) return PKZip_method is 
  672.       -- An enumeration clause might be more elegant, but needs 
  673.       -- curiously an Unchecked_Conversion .. . (RM 13.4) 
  674.  
  675.    begin 
  676.       case x is 
  677.          when  0 => return store; 
  678.          when  1 => return shrink; 
  679.          when  2 => return reduce_1; 
  680.          when  3 => return reduce_2; 
  681.          when  4 => return reduce_3; 
  682.          when  5 => return reduce_4; 
  683.          when  6 => return implode; 
  684.          when  7 => return tokenize; 
  685.          when  8 => return deflate; 
  686.          when  9 => return deflate_e; 
  687.          when 12 => return bzip2; 
  688.          when 14 => return lzma; 
  689.          when 98 => return ppmd; 
  690.          when others => return unknown; 
  691.       end case; 
  692.    end Method_from_code; 
  693.  
  694.    function Method_from_code (x : Interfaces.Unsigned_16) return PKZip_method is 
  695.      (Method_from_code (Natural (x))); 
  696.  
  697.    -- This does the same as Ada 2005's Ada.Directories.Exists 
  698.    -- Just there as helper for Ada 95 only systems 
  699.    -- 
  700.    function Exists (name : String) return Boolean is 
  701.  
  702.       use Ada.Text_IO, Ada.Strings.Fixed; 
  703.  
  704.       f : File_Type; 
  705.  
  706.    begin 
  707.       if Index (name, "*") > 0 then 
  708.          return False; 
  709.       end if; 
  710.       Open (f, In_File, name, Form => Ada.Strings.Unbounded.To_String (Form_For_IO_Open_N_Create)); 
  711.       Close (f); 
  712.       return True; 
  713.  
  714.    exception 
  715.       when Name_Error => 
  716.          return False; -- The file cannot exist ! 
  717.       when Use_Error => 
  718.          return True;  -- The file exist and is already opened ! 
  719.    end Exists; 
  720.  
  721.    procedure Put_Multi_Line ( 
  722.                              out_file  :        Ada.Text_IO.File_Type; 
  723.                              text      :        String 
  724.                             ) 
  725.    is 
  726.       last_char : Character := ' '; 
  727.       c : Character; 
  728.    begin 
  729.       for i in text'Range loop 
  730.          c := text (i); 
  731.          case c is 
  732.             when ASCII.CR => 
  733.                Ada.Text_IO.New_Line (out_file); 
  734.             when ASCII.LF => 
  735.                if last_char /= ASCII.CR then 
  736.                   Ada.Text_IO.New_Line (out_file); 
  737.                end if; 
  738.             when others => 
  739.                Ada.Text_IO.Put (out_file, c); 
  740.          end case; 
  741.          last_char := c; 
  742.       end loop; 
  743.    end Put_Multi_Line; 
  744.  
  745.    procedure Write_as_text (out_file  :        Ada.Text_IO.File_Type; 
  746.                             buffer    :        Byte_Buffer; 
  747.                             last_char : in out Character) is -- track line - ending characters across writes 
  748.  
  749.       c : Character; 
  750.  
  751.    begin 
  752.       for i in buffer'Range loop 
  753.          c := Character'Val (buffer (i)); 
  754.          case c is 
  755.          when ASCII.CR => 
  756.             Ada.Text_IO.New_Line (out_file); 
  757.          when ASCII.LF => 
  758.             if last_char /= ASCII.CR then 
  759.                Ada.Text_IO.New_Line (out_file); 
  760.             end if; 
  761.          when others => 
  762.             Ada.Text_IO.Put (out_file, c); 
  763.          end case; 
  764.          last_char := c; 
  765.       end loop; 
  766.    end Write_as_text; 
  767.  
  768. end Zip;