Back to...

   1  --  Legal licensing note:
   2  
   3  --  Copyright (c) 2024 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 BZip2.Encoding;
  28  
  29  procedure Zip.Compress.BZip2_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           :        BZip2_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 BZip2, BZip2.Encoding;
 109  
 110    procedure BZip2_Encode is
 111      new BZip2.Encoding.Encode (Read_Byte, More_Bytes, Put_Byte);
 112  
 113  begin
 114    Allocate_Buffers (IO_buffers, input_size_known, input_size);
 115    output_size := 0;
 116    begin
 117      Read_Block (IO_buffers, input);
 118      if input_size_known then
 119        feedback_milestone := Zip_Streams.ZS_Size_Type (input_size / feedback_steps);
 120      end if;
 121  
 122      BZip2_Encode
 123        ((case method is
 124           when BZip2_1 => block_100k,
 125           when BZip2_2 => block_400k,
 126           when BZip2_3 => block_900k),
 127         (if input_size_known then
 128            BZip2.Encoding.Stream_Size_Type (input_size) else
 129            BZip2.Encoding.unknown_size));
 130  
 131      Flush_Output;
 132      compression_ok := True;
 133    exception
 134      when Compression_inefficient =>
 135        compression_ok := False;
 136    end;
 137    Deallocate_Buffers (IO_buffers);
 138  exception
 139    when others =>
 140      Deallocate_Buffers (IO_buffers);
 141      raise;
 142  end Zip.Compress.BZip2_E;