Back to...

   1  --  Legal licensing note:
   2  
   3  --  Copyright (c) 1999 .. 2023 Gautier de Montmollin
   4  --  SWITZERLAND
   5  
   6  --  Permission is hereby granted, free of charge, to any person obtaining a copy
   7  --  of this software and associated documentation files (the "Software"), to deal
   8  --  in the Software without restriction, including without limitation the rights
   9  --  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  10  --  copies of the Software, and to permit persons to whom the Software is
  11  --  furnished to do so, subject to the following conditions:
  12  
  13  --  The above copyright notice and this permission notice shall be included in
  14  --  all copies or substantial portions of the Software.
  15  
  16  --  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  17  --  IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  18  --  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  19  --  AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  20  --  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  21  --  OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
  22  --  THE SOFTWARE.
  23  
  24  --  NB: this is the MIT License, as found on the site
  25  --  http://www.opensource.org/licenses/mit-license.php
  26  
  27  with Ada.Text_IO,
  28       Ada.Unchecked_Deallocation;
  29  with Interfaces;
  30  
  31  package body UnZip.Decompress.Huffman is
  32  
  33    --  Note from Pascal source:
  34    --  C code by info-zip group, translated to pascal by Christian Ghisler
  35    --  based on unz51g.zip
  36  
  37    --  Free huffman tables starting with table where t points to
  38  
  39    procedure HufT_free (tl : in out p_Table_list) is
  40  
  41      procedure  Dispose is new
  42        Ada.Unchecked_Deallocation (HufT_table, p_HufT_table);
  43      procedure  Dispose is new
  44        Ada.Unchecked_Deallocation (Table_list, p_Table_list);
  45  
  46      current : p_Table_list;
  47      tcount  : Natural := 0;  --  just a stat. Idea: replace table_list with an array
  48  
  49    begin
  50      if full_trace then
  51        Ada.Text_IO.Put ("[HufT_Free... ");
  52      end if;
  53      while tl /= null loop
  54        Dispose (tl.table);  --  destroy the Huffman table
  55        current := tl;
  56        tl     := tl.next;
  57        Dispose (current);   --  destroy the current node
  58        if full_trace then
  59          tcount := tcount + 1;
  60        end if;
  61      end loop;
  62      if full_trace then
  63        Ada.Text_IO.Put_Line (Integer'Image (tcount) & " tables]");
  64      end if;
  65    end HufT_free;
  66  
  67    --  Build huffman table from code lengths given by array b
  68  
  69    procedure HufT_build (b    : Length_array;
  70                          s    : Integer;
  71                          d, e : Length_array;
  72                          tl   :    out p_Table_list;
  73                          m    : in out Integer;
  74               huft_incomplete :    out Boolean)
  75    is
  76      use Interfaces;
  77  
  78      b_max   : constant := 16;
  79      b_maxp1 : constant := b_max + 1;
  80  
  81      --  bit length count table
  82      count : array (0 .. b_maxp1) of Integer := (others => 0);
  83  
  84      f   : Integer;                    --  i repeats in table every f entries
  85      g   : Integer;                    --  max. code length
  86      i,                                --  counter, current code
  87        j : Integer;                    --  counter
  88      kcc : Integer;                    --  number of bits in current code
  89  
  90      c_idx, v_idx : Natural;           --  array indices
  91  
  92      current_table_ptr : p_HufT_table := null;
  93      current_node_ptr  : p_Table_list := null;  --  curr. node for the curr. table
  94      new_node_ptr      : p_Table_list;          --  new node for the new table
  95  
  96      new_entry : HufT;                  --  table entry for structure assignment
  97  
  98      u : array (0 .. b_max) of p_HufT_table;   --  table stack
  99  
 100      n_max : constant := 288;
 101      --  values in order of bit length
 102      v : array (0 .. n_max) of Integer := (others => 0);
 103      el_v, el_v_m_s : Integer;
 104  
 105      w : Natural := 0;                        -- bits before this table
 106  
 107      offset, code_stack : array (0 .. b_maxp1) of Integer;
 108  
 109      table_level : Integer := -1;
 110      bits : array (Integer'(-1) .. b_maxp1) of Integer;
 111      --  ^bits (table_level) = # bits in table of level table_level
 112  
 113      y  : Integer;                     --  number of dummy codes added
 114      z  : Natural := 0;                --  number of entries in current table
 115      el : Integer;                     --  length of eob code=code 256
 116  
 117      no_copy_length_array : constant Boolean := d'Length = 0 or e'Length = 0;
 118  
 119    begin
 120      if full_trace then
 121        Ada.Text_IO.Put ("[HufT_Build...");
 122      end if;
 123      tl := null;
 124  
 125      if b'Length > 256 then -- set length of EOB code, if any
 126        el := b (256);
 127      else
 128        el := b_max;
 129      end if;
 130  
 131      --  Generate counts for each bit length
 132  
 133      for k in b'Range loop
 134        if b (k) > b_max then
 135          --  m := 0;  --  GNAT 2005 doesn't like it (warning).
 136          raise huft_error;
 137        end if;
 138        count (b (k)) := count (b (k)) + 1;
 139      end loop;
 140  
 141      if count (0) = b'Length then
 142        m := 0;
 143        huft_incomplete := False;  --  spotted by Tucker Taft, 19-Aug-2004
 144        return;  --  complete
 145      end if;
 146  
 147      --  Find minimum and maximum length, bound m by those
 148  
 149      j := 1;
 150      while j <= b_max and then count (j) = 0 loop
 151        j := j + 1;
 152      end loop;
 153      kcc := j;
 154      if m < j then
 155        m := j;
 156      end if;
 157      i := b_max;
 158      while i > 0 and then count (i) = 0 loop
 159        i := i - 1;
 160      end loop;
 161      g := i;
 162      if m > i then
 163        m := i;
 164      end if;
 165  
 166      --  Adjust last length count to fill out codes, if needed
 167  
 168      y := Integer (Shift_Left (Unsigned_32'(1), j)); -- y:= 2 ** j;
 169      while j < i loop
 170        y := y - count (j);
 171        if y < 0 then
 172          raise huft_error;
 173        end if;
 174        y := y * 2;
 175        j := j + 1;
 176      end loop;
 177  
 178      y := y - count (i);
 179      if y < 0 then
 180        raise huft_error;
 181      end if;
 182      count (i) := count (i) + y;
 183  
 184      --  Generate starting offsets into the value table for each length
 185  
 186      offset (1) := 0;
 187      j := 0;
 188      for idx in 2 .. i loop
 189        j := j + count (idx - 1);
 190        offset (idx) := j;
 191      end loop;
 192  
 193      --  Make table of values in order of bit length
 194  
 195      for idx in b'Range loop
 196        j := b (idx);
 197        if j /= 0 then
 198          v (offset (j)) := idx - b'First;
 199          offset (j) := offset (j) + 1;
 200        end if;
 201      end loop;
 202  
 203      --  Generate huffman codes and for each, make the table entries
 204  
 205      code_stack (0) := 0;
 206      i := 0;
 207      v_idx := v'First;
 208      bits (-1) := 0;
 209  
 210      --  go through the bit lengths (kcc already is bits in shortest code)
 211      for k in kcc .. g loop
 212  
 213        for am1 in reverse 0 .. count (k) - 1 loop  --  a counts codes of length k
 214  
 215          --  here i is the huffman code of length k bits for value v(v_idx)
 216          while k > w + bits (table_level) loop
 217  
 218            w := w + bits (table_level);    --  Length of tables to this position
 219            table_level := table_level + 1;
 220            z := g - w;                     --  Compute min size table <= m bits
 221            if z > m then
 222              z := m;
 223            end if;
 224            j := k - w;
 225            f := Integer (Shift_Left (Unsigned_32'(1), j)); -- f:= 2 ** j;
 226            if f > am1 + 2 then   --  Try a k-w bit table
 227              f := f - (am1 + 2);
 228              c_idx := k;
 229              loop                --  Try smaller tables up to z bits
 230                j := j + 1;
 231                exit when j >= z;
 232                f := f * 2;
 233                c_idx := c_idx + 1;
 234                exit when f - count (c_idx) <= 0;
 235                f := f - count (c_idx);
 236              end loop;
 237            end if;
 238  
 239            if w + j > el and then  w < el  then
 240              j := el - w;       --  Make EOB code end at table
 241            end if;
 242            if w = 0 then
 243              j := m;  --  Fix: main table always m bits!
 244            end if;
 245            z := Integer (Shift_Left (Unsigned_32'(1), j)); -- z:= 2 ** j;
 246            bits (table_level) := j;
 247  
 248            --  Allocate and link new table
 249  
 250            begin
 251              current_table_ptr := new HufT_table (0 .. z);
 252              new_node_ptr      := new Table_list'(current_table_ptr, null);
 253            exception
 254              when Storage_Error =>
 255                raise huft_out_of_memory;
 256            end;
 257  
 258            if current_node_ptr = null then  --  first table
 259              tl := new_node_ptr;
 260            else
 261              current_node_ptr.next := new_node_ptr;   --  not my first...
 262            end if;
 263  
 264            current_node_ptr := new_node_ptr;  --  always non-Null from there
 265  
 266            u (table_level) := current_table_ptr;
 267  
 268            --  Connect to last table, if there is one
 269  
 270            if table_level > 0 then
 271              code_stack (table_level) := i;
 272              new_entry.bits           := bits (table_level - 1);
 273              new_entry.extra_bits     := 16 + j;
 274              new_entry.next_table     := current_table_ptr;
 275  
 276              j := Integer (
 277                Shift_Right (Unsigned_32 (i) and
 278                  (Shift_Left (Unsigned_32'(1), w) - 1),
 279                  w - bits (table_level - 1))
 280                );
 281  
 282              --  Test against bad input!
 283  
 284              if j > u (table_level - 1)'Last then
 285                raise huft_error;
 286              end if;
 287              u (table_level - 1) (j) := new_entry;
 288            end if;
 289  
 290          end loop;
 291  
 292          --  Set up table entry in new_entry
 293  
 294          new_entry.bits      := k - w;
 295          new_entry.next_table := null;   --  Unused
 296  
 297          if v_idx >= b'Length then
 298            new_entry.extra_bits := invalid;
 299          else
 300            el_v := v (v_idx);
 301            el_v_m_s := el_v - s;
 302            if el_v_m_s < 0 then    --  Simple code, raw value
 303              if el_v < 256 then
 304                new_entry.extra_bits := 16;
 305              else
 306                new_entry.extra_bits := 15;
 307              end if;
 308              new_entry.n := el_v;
 309            else                    --  Non-simple -> lookup in lists
 310              if no_copy_length_array then
 311                raise huft_error;
 312              end if;
 313              new_entry.extra_bits := e (el_v_m_s);
 314              new_entry.n          := d (el_v_m_s);
 315            end if;
 316            v_idx := v_idx + 1;
 317          end if;
 318  
 319          --  fill code-like entries with new_entry
 320          f := Integer (Shift_Left (Unsigned_32'(1), k - w));
 321          --  i.e. f := 2 ** (k-w);
 322          j := Integer (Shift_Right (Unsigned_32 (i), w));
 323          while j < z loop
 324            current_table_ptr (j) := new_entry;
 325            j := j + f;
 326          end loop;
 327  
 328          --  backwards increment the k-bit code i
 329          j := Integer (Shift_Left (Unsigned_32'(1), k - 1));
 330          --  i.e.: j:= 2 ** (k-1)
 331          while (Unsigned_32 (i) and Unsigned_32 (j)) /= 0 loop
 332            i := Integer (Unsigned_32 (i) xor Unsigned_32 (j));
 333            j :=  j / 2;
 334          end loop;
 335          i := Integer (Unsigned_32 (i) xor Unsigned_32 (j));
 336  
 337          --  backup over finished tables
 338          while
 339            Integer (Unsigned_32 (i) and (Shift_Left (1, w) - 1)) /=
 340            code_stack (table_level)
 341          loop
 342            table_level := table_level - 1;
 343            w := w - bits (table_level);  --  Size of previous table!
 344          end loop;
 345  
 346        end loop;  --  am1
 347      end loop;  --  k
 348  
 349      if full_trace then
 350        Ada.Text_IO.Put_Line ("finished]");
 351      end if;
 352  
 353      huft_incomplete := y /= 0 and g /= 1;
 354  
 355    exception
 356      when others =>
 357        HufT_free (tl);
 358        raise;
 359    end HufT_build;
 360  
 361  end UnZip.Decompress.Huffman;