Back to...

   1  --  Legal licensing note:
   2  
   3  --  Copyright (c) 2016 .. 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 LZMA.Encoding;
  28  
  29  procedure Zip.Compress.LZMA_E
  30    (input,
  31     output           : in out Zip_Streams.Root_Zipstream_Type'Class;
  32     input_size_known :        Boolean;
  33     input_size       :        Zip_64_Data_Size_Type;   --  ignored if unknown
  34     feedback         :        Feedback_Proc;
  35     method           :        LZMA_Method;
  36     CRC              : in out Interfaces.Unsigned_32;  --  only updated here
  37     crypto           : in out CRC_Crypto.Crypto_pack;
  38     output_size      :    out Zip_64_Data_Size_Type;
  39     compression_ok   :    out Boolean)  --  indicates compressed < uncompressed
  40  is
  41    use Interfaces;
  42  
  43    ------------------
  44    -- Buffered I/O --
  45    ------------------
  46  
  47    IO_buffers : IO_Buffers_Type;
  48  
  49    procedure Put_Byte (B : Unsigned_8) is
  50    begin
  51      IO_buffers.OutBuf (IO_buffers.OutBufIdx) := B;
  52      IO_buffers.OutBufIdx := IO_buffers.OutBufIdx + 1;
  53      if IO_buffers.OutBufIdx > IO_buffers.OutBuf.all'Last then
  54        Write_Block (IO_buffers, input_size_known, input_size, output, output_size, crypto);
  55      end if;
  56    end Put_Byte;
  57  
  58    procedure Flush_Output is
  59    begin
  60      if IO_buffers.OutBufIdx > 1 then
  61        Write_Block (IO_buffers, input_size_known, input_size, output, output_size, crypto);
  62      end if;
  63    end Flush_Output;
  64  
  65    feedback_milestone,
  66    Bytes_in   : Zip_Streams.ZS_Size_Type := 0;   --  Count of input file bytes processed
  67    user_aborting : Boolean;
  68    PctDone : Natural;
  69  
  70    function Read_Byte return Byte is
  71      b : Byte;
  72      use Zip_Streams;
  73    begin
  74      b := IO_buffers.InBuf (IO_buffers.InBufIdx);
  75      IO_buffers.InBufIdx := IO_buffers.InBufIdx + 1;
  76      Zip.CRC_Crypto.Update (CRC, (1 => b));
  77      Bytes_in := Bytes_in + 1;
  78      if feedback /= null then
  79        if Bytes_in = 1 then
  80          feedback (0, False, user_aborting);
  81        end if;
  82        if feedback_milestone > 0 and then
  83           ((Bytes_in - 1) mod feedback_milestone = 0
  84            or Bytes_in = ZS_Size_Type (input_size))
  85        then
  86          if input_size_known then
  87            PctDone := Integer ((100.0 * Float (Bytes_in)) / Float (input_size));
  88            feedback (PctDone, False, user_aborting);
  89          else
  90            feedback (0, False, user_aborting);
  91          end if;
  92          if user_aborting then
  93            raise User_abort;
  94          end if;
  95        end if;
  96      end if;
  97      return b;
  98    end Read_Byte;
  99  
 100    function More_Bytes return Boolean with Inline is
 101    begin
 102      if IO_buffers.InBufIdx > IO_buffers.MaxInBufIdx then
 103        Read_Block (IO_buffers, input);
 104      end if;
 105      return not IO_buffers.InputEoF;
 106    end More_Bytes;
 107  
 108    use LZMA, LZMA.Encoding;
 109  
 110    type LZMA_Param_Bundle is record
 111      lc : Literal_Context_Bits_Range;
 112      lp : Literal_Position_Bits_Range;
 113      pb : Position_Bits_Range;
 114      lz : Compression_Level;
 115    end record;
 116  
 117    --  Set the LZMA parameters tuned depending on the data type.
 118    --  Hints by Stephan Busch (Squeeze Chart) - thanks!
 119    --  Parameters optimality tested with commands like "lzma_enc picture.jpg out -b".
 120  
 121    LZMA_param : constant array (LZMA_Method) of LZMA_Param_Bundle :=
 122        --  LZMA with default parameters (3, 0, 2) but various LZ77 levels:
 123       (LZMA_0                => (3, 0, 2, Level_0),
 124        LZMA_1                => (3, 0, 2, Level_1),
 125        LZMA_2                => (3, 0, 2, Level_2),
 126        LZMA_3                => (3, 0, 2, Level_3),
 127        --  Parameter sets for specific data types:
 128        LZMA_for_ARW          => (8, 4, 4, Level_2),
 129        LZMA_for_GIF          => (0, 0, 0, Level_1),
 130        LZMA_for_JPEG         => (8, 0, 0, Level_2),
 131        LZMA_for_MP3          => (8, 4, 4, Level_2),
 132        LZMA_for_MP4          => (8, 4, 4, Level_2),
 133        LZMA_for_ORF          => (8, 0, 0, Level_0),
 134        LZMA_for_PGM          => (8, 0, 0, Level_0),
 135        LZMA_for_PPM          => (4, 0, 0, Level_2),
 136        LZMA_for_PNG          => (8, 0, 2, Level_2),
 137        LZMA_for_WAV          => (0, 1, 1, Level_2),
 138        LZMA_for_AU           => (0, 2, 2, Level_2),
 139        LZMA_2_for_Zip_in_Zip => (8, 4, 0, Level_2),
 140        LZMA_3_for_Zip_in_Zip => (8, 4, 0, Level_3),
 141        LZMA_2_for_Source     => (3, 0, 0, Level_2),
 142        LZMA_3_for_Source     => (3, 0, 0, Level_3));
 143  
 144    procedure LZMA_Encode is
 145      new LZMA.Encoding.Encode (Read_Byte, More_Bytes, Put_Byte);
 146  
 147  begin
 148    Allocate_Buffers (IO_buffers, input_size_known, input_size);
 149    output_size := 0;
 150    begin
 151      Read_Block (IO_buffers, input);
 152      if input_size_known then
 153        feedback_milestone := Zip_Streams.ZS_Size_Type (input_size / feedback_steps);
 154      end if;
 155      Put_Byte (16);  --  LZMA SDK major version
 156      Put_Byte (02);  --  LZMA SDK minor version
 157      Put_Byte (5);   --  LZMA properties size low byte
 158      Put_Byte (0);   --  LZMA properties size high byte
 159      if input_size_known then
 160        LZMA_Encode
 161          (level                 => LZMA_param (method).lz,
 162           literal_context_bits  => LZMA_param (method).lc,
 163           literal_position_bits => LZMA_param (method).lp,
 164           position_bits         => LZMA_param (method).pb,
 165           dictionary_size       => Integer (input_size));
 166      else
 167        LZMA_Encode
 168          (level                 => LZMA_param (method).lz,
 169           literal_context_bits  => LZMA_param (method).lc,
 170           literal_position_bits => LZMA_param (method).lp,
 171           position_bits         => LZMA_param (method).pb);
 172      end if;
 173      Flush_Output;
 174      compression_ok := True;
 175    exception
 176      when Compression_inefficient =>
 177        compression_ok := False;
 178    end;
 179    Deallocate_Buffers (IO_buffers);
 180  exception
 181    when others =>
 182      Deallocate_Buffers (IO_buffers);
 183      raise;
 184  end Zip.Compress.LZMA_E;