Back to...

   1  --  Legal licensing note:
   2  
   3  --  Copyright (c) 1999 .. 2019 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  package body Zip.CRC_Crypto is
  28  
  29    CRC32_Table : array (Unsigned_32'(0) .. 255) of Unsigned_32;
  30  
  31    procedure Prepare_table is
  32      --  CRC-32 algorithm, ISO-3309
  33      Seed : constant := 16#EDB88320#;
  34      l : Unsigned_32;
  35    begin
  36      for i in CRC32_Table'Range loop
  37        l := i;
  38        for bit in 0 .. 7 loop
  39          if (l and 1) = 0 then
  40            l := Shift_Right (l, 1);
  41          else
  42            l := Shift_Right (l, 1) xor Seed;
  43          end if;
  44        end loop;
  45        CRC32_Table (i) := l;
  46      end loop;
  47    end Prepare_table;
  48  
  49    procedure Update (CRC : in out Unsigned_32; InBuf : Zip.Byte_Buffer) is
  50      local_CRC : Unsigned_32;
  51    begin
  52      local_CRC := CRC;
  53      for i in InBuf'Range loop
  54        local_CRC :=
  55          CRC32_Table (16#FF# and (local_CRC xor Unsigned_32 (InBuf (i))))
  56          xor
  57          Shift_Right (local_CRC, 8);
  58      end loop;
  59      CRC := local_CRC;
  60    end Update;
  61  
  62    table_empty : Boolean := True;
  63  
  64    procedure Init (CRC : out Unsigned_32) is
  65    begin
  66      if table_empty then
  67        Prepare_table;
  68        table_empty := False;
  69      end if;
  70      CRC := 16#FFFF_FFFF#;
  71    end Init;
  72  
  73    function Final (CRC : Unsigned_32) return Unsigned_32 is
  74    begin
  75      return not CRC;
  76    end Final;
  77  
  78    --
  79  
  80    procedure Set_Mode (obj : in out Crypto_Pack; new_mode : Crypto_Mode) is
  81    begin
  82      obj.current_mode := new_mode;
  83    end Set_Mode;
  84  
  85    function Get_Mode (obj : Crypto_Pack) return Crypto_Mode is
  86    begin
  87      return obj.current_mode;
  88    end Get_Mode;
  89  
  90    procedure Update_keys (obj : in out Crypto_Pack; by : Zip.Byte) is
  91    begin
  92      Update (obj.keys (0), (0 => by));
  93      obj.keys (1) := obj.keys (1) + (obj.keys (0) and 16#000000ff#);
  94      obj.keys (1) := obj.keys (1) * 134775813 + 1;
  95      Update (
  96        obj.keys (2),
  97        (0 => Zip.Byte (Shift_Right (obj.keys (1), 24)))
  98      );
  99    end Update_keys;
 100  
 101    --  Crypto_code: Pseudo-random byte to be XOR'ed with.
 102    function Crypto_code (obj : Crypto_Pack) return Zip.Byte is
 103    pragma Inline (Crypto_code);
 104      temp : Unsigned_16;
 105    begin
 106      temp := Unsigned_16 (obj.keys (2) and 16#ffff#) or 2;
 107      return Zip.Byte (Shift_Right (temp * (temp xor 1), 8));
 108    end Crypto_code;
 109  
 110    procedure Init_Keys (obj : in out Crypto_Pack; password : String) is
 111    begin
 112      obj.keys := (16#12345678#, 16#23456789#, 16#34567890#);
 113      for i in password'Range loop
 114        Update_keys (obj, Character'Pos (password (i)));
 115      end loop;
 116    end Init_Keys;
 117  
 118    procedure Encode (obj : in out Crypto_Pack; buf : in out Zip.Byte_Buffer) is
 119      bc : Zip.Byte;
 120    begin
 121      if obj.current_mode = encrypted then
 122        for i in buf'Range loop
 123          bc := buf (i);
 124          buf (i) := bc xor Crypto_code (obj);
 125          Update_keys (obj, bc);  --  Keys are updated with the unencrypted byte
 126        end loop;
 127      end if;
 128    end Encode;
 129  
 130    procedure Decode (obj : in out Crypto_Pack; b : in out Unsigned_8) is
 131    begin
 132      if obj.current_mode = encrypted then
 133        b := b xor Crypto_code (obj);
 134        Update_keys (obj, b);     --  Keys are updated with the unencrypted byte
 135      end if;
 136    end Decode;
 137  
 138  end Zip.CRC_Crypto;