Natools

natools-s_expressions-encodings.adb at [ecae1e85f4]
Login

File src/natools-s_expressions-encodings.adb artifact e78bc3f122 part of check-in ecae1e85f4


------------------------------------------------------------------------------
-- Copyright (c) 2013, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

package body Natools.S_Expressions.Encodings is

   --------------------------
   -- Hexadecimal Decoding --
   --------------------------

   function Is_Hex_Digit (Value : in Octet) return Boolean is
   begin
      case Value is
         when Digit_0 .. Digit_9 => return True;
         when Lower_A .. Lower_F => return True;
         when Upper_A .. Upper_F => return True;
         when others             => return False;
      end case;
   end Is_Hex_Digit;


   function Decode_Hex (Value : in Octet) return Octet is
   begin
      case Value is
         when Digit_0 .. Digit_9 => return Value - Digit_0;
         when Lower_A .. Lower_F => return Value - Lower_A + 10;
         when Upper_A .. Upper_F => return Value - Upper_A + 10;
         when others             => raise Constraint_Error;
      end case;
   end Decode_Hex;


   function Decode_Hex (High, Low : in Octet) return Octet is
   begin
      return Decode_Hex (High) * 16 + Decode_Hex (Low);
   end Decode_Hex;


   function Decode_Hex (Data : in Atom) return Atom is
      Length : Count := 0;
   begin
      for I in Data'Range loop
         if Is_Hex_Digit (Data (I)) then
            Length := Length + 1;
         end if;
      end loop;

      Length := (Length + 1) / 2;

      return Result : Atom (0 .. Length - 1) do
         declare
            O : Offset := Result'First;
            High : Octet := 0;
            Has_High : Boolean := False;
         begin
            for I in Data'Range loop
               if Is_Hex_Digit (Data (I)) then
                  if Has_High then
                     Result (O) := Decode_Hex (High, Data (I));
                     O := O + 1;
                     High := 0;
                     Has_High := False;
                  else
                     High := Data (I);
                     Has_High := True;
                  end if;
               end if;
            end loop;
            if Has_High then
               Result (O) := Decode_Hex (High, Digit_0);
               O := O + 1;
            end if;
            pragma Assert (O - 1 = Result'Last);
         end;
      end return;
   end Decode_Hex;



   --------------------------
   -- Hexadecimal Encoding --
   --------------------------

   function Encode_Hex (Value : in Octet; Casing : in Hex_Casing)
     return Octet is
   begin
      case Value is
         when 0 .. 9 =>
            return Digit_0 + Value;
         when 10 .. 15 =>
            case Casing is
               when Upper => return Upper_A + Value - 10;
               when Lower => return Lower_A + Value - 10;
            end case;
         when others =>
            raise Constraint_Error;
      end case;
   end Encode_Hex;


   procedure Encode_Hex
     (Value : in Octet;
      Casing : in Hex_Casing;
      High, Low : out Octet) is
   begin
      High := Encode_Hex (Value / 2**4 mod 2**4, Casing);
      Low  := Encode_Hex (Value mod 2**4, Casing);
   end Encode_Hex;


   function Encode_Hex (Data : in Atom; Casing : in Hex_Casing) return Atom is
      Result : Atom (0 .. Data'Length * 2 - 1);
      Cursor : Offset := Result'First;
   begin
      for I in Data'Range loop
         Encode_Hex (Data (I), Casing, Result (Cursor), Result (Cursor + 1));
         Cursor := Cursor + 2;
      end loop;
      pragma Assert (Cursor = Result'Last + 1);

      return Result;
   end Encode_Hex;



   ----------------------
   -- Base-64 Decoding --
   ----------------------

   function Is_Base64_Digit (Value : in Octet) return Boolean is
   begin
      return Value in Digit_0 .. Digit_9
        or Value in Lower_A .. Lower_Z
        or Value in Upper_A .. Upper_Z
        or Value = Plus
        or Value = Slash;
   end Is_Base64_Digit;


   function Decode_Base64 (Value : in Octet) return Octet is
   begin
      case Value is
         when Upper_A .. Upper_Z => return Value - Upper_A + 0;
         when Lower_A .. Lower_Z => return Value - Lower_A + 26;
         when Digit_0 .. Digit_9 => return Value - Digit_0 + 52;
         when Plus               => return 62;
         when Slash              => return 63;
         when others             => raise Constraint_Error;
      end case;
   end Decode_Base64;


   function Decode_Base64 (A, B : in Octet) return Atom is
      VA : constant Octet := Decode_Base64 (A);
      VB : constant Octet := Decode_Base64 (B);
   begin
      return (0 => VA * 2**2 + VB / 2**4);
   end Decode_Base64;


   function Decode_Base64 (A, B, C : in Octet) return Atom is
      VA : constant Octet := Decode_Base64 (A);
      VB : constant Octet := Decode_Base64 (B);
      VC : constant Octet := Decode_Base64 (C);
   begin
      return (0 => VA * 2**2 + VB / 2**4,
              1 => VB * 2**4 + VC / 2**2);
   end Decode_Base64;


   function Decode_Base64 (A, B, C, D : in Octet) return Atom is
      VA : constant Octet := Decode_Base64 (A);
      VB : constant Octet := Decode_Base64 (B);
      VC : constant Octet := Decode_Base64 (C);
      VD : constant Octet := Decode_Base64 (D);
   begin
      return (0 => VA * 2**2 + VB / 2**4,
              1 => VB * 2**4 + VC / 2**2,
              2 => VC * 2**6 + VD);
   end Decode_Base64;


   function Decode_Base64 (Data : in Atom) return Atom is
      Length : Count := 0;
   begin
      for I in Data'Range loop
         if Is_Base64_Digit (Data (I)) then
            Length := Length + 1;
         end if;
      end loop;

      declare
         Chunks : constant Count := Length / 4;
         Remains : constant Count := Length mod 4;
      begin
         if Remains >= 2 then
            Length := Chunks * 3 + Remains - 1;
         else
            Length := Chunks * 3;
         end if;
      end;

      return Result : Atom (0 .. Length - 1) do
         declare
            O : Count := Result'First;
            Buffer : Atom (0 .. 3);
            Accumulated : Count := 0;
         begin
            for I in Data'Range loop
               if Is_Base64_Digit (Data (I)) then
                  Buffer (Accumulated) := Data (I);
                  Accumulated := Accumulated + 1;
                  if Accumulated = 4 then
                     Result (O .. O + 2) := Decode_Base64 (Buffer (0),
                                                           Buffer (1),
                                                           Buffer (2),
                                                           Buffer (3));
                     O := O + 3;
                     Accumulated := 0;
                  end if;
               end if;
            end loop;

            if Accumulated = 2 then
               Result (O .. O) := Decode_Base64 (Buffer (0), Buffer (1));
               O := O + 1;
            elsif Accumulated = 3 then
               Result (O .. O + 1) := Decode_Base64 (Buffer (0),
                                                     Buffer (1),
                                                     Buffer (2));
               O := O + 2;
            end if;

            pragma Assert (O = Length);
         end;
      end return;
   end Decode_Base64;



   ----------------------
   -- Base-64 Encoding --
   ----------------------

   function Encode_Base64 (Value : in Octet) return Octet is
   begin
      case Value is
         when 0 .. 25 =>
            return Upper_A + Value;
         when 26 .. 51 =>
            return Lower_A + Value - 26;
         when 52 .. 61 =>
            return Digit_0 + Value - 52;
         when 62 =>
            return Plus;
         when 63 =>
            return Slash;
         when others =>
            raise Constraint_Error;
      end case;
   end Encode_Base64;


   procedure Encode_Base64 (Output : out Atom; A : in Octet) is
   begin
      Output (Output'First + 0) := Encode_Base64 (A / 2**2 mod 2**6);
      Output (Output'First + 1) := Encode_Base64 (A * 2**4 mod 2**6);
      Output (Output'First + 2) := Base64_Filler;
      Output (Output'First + 3) := Base64_Filler;
   end Encode_Base64;


   procedure Encode_Base64 (Output : out Atom; A, B : in Octet) is
   begin
      Output (Output'First + 0) := Encode_Base64 (A / 2**2 mod 2**6);
      Output (Output'First + 1) := Encode_Base64 ((A * 2**4 + B / 2**4)
                                                  mod 2**6);
      Output (Output'First + 2) := Encode_Base64 (B * 2**2 mod 2**6);
      Output (Output'First + 3) := Base64_Filler;
   end Encode_Base64;


   procedure Encode_Base64 (Output : out Atom; A, B, C : in Octet) is
   begin
      Output (Output'First + 0) := Encode_Base64 (A / 2**2 mod 2**6);
      Output (Output'First + 1) := Encode_Base64 ((A * 2**4 + B / 2**4)
                                                  mod 2**6);
      Output (Output'First + 2) := Encode_Base64 ((B * 2**2 + C / 2**6)
                                                  mod 2**6);
      Output (Output'First + 3) := Encode_Base64 (C mod 2**6);
   end Encode_Base64;


   function Encode_Base64 (Data : in Atom) return Atom is
      Chunks : constant Count := (Data'Length + 2) / 3;
      Result : Atom (0 .. Chunks * 4 - 1);
      Cursor : Offset := Result'First;
      I      : Offset := Data'First;
   begin
      while I in Data'Range loop
         if I + 2 in Data'Range then
            Encode_Base64
              (Result (Cursor .. Cursor + 3),
               Data (I),
               Data (I + 1),
               Data (I + 2));
            I := I + 3;
         elsif I + 1 in Data'Range then
            Encode_Base64
              (Result (Cursor .. Cursor + 3),
               Data (I),
               Data (I + 1));
            I := I + 2;
         else
            Encode_Base64
              (Result (Cursor .. Cursor + 3),
               Data (I));
            I := I + 1;
         end if;
         Cursor := Cursor + 4;
      end loop;

      return Result;
   end Encode_Base64;



   ---------------------------------
   -- Base-64 with other charsets --
   ---------------------------------

   function Decode_Base64 (Data : in Atom; Digit_62, Digit_63 : in Octet)
     return Atom
   is
      Recoded : Atom := Data;
   begin
      for I in Recoded'Range loop
         if Recoded (I) = Digit_62 then
            Recoded (I) := Plus;
         elsif Recoded (I) = Digit_63 then
            Recoded (I) := Slash;
         end if;
      end loop;

      return Decode_Base64 (Recoded);
   end Decode_Base64;


   function Encode_Base64 (Data : in Atom; Digit_62, Digit_63 : in Octet)
     return Atom
   is
      Result : Atom := Encode_Base64 (Data);
      Last : Count := Result'Last;
   begin
      for I in Result'Range loop
         if Result (I) = Plus then
            Result (I) := Digit_62;
         elsif Result (I) = Slash then
            Result (I) := Digit_63;
         elsif Result (I) = Base64_Filler then
            pragma Assert (Result (I + 1 .. Result'Last)
              = (I + 1 .. Result'Last => Base64_Filler));
            Last := I - 1;
            exit;
         end if;
      end loop;

      return Result (Result'First .. Last);
   end Encode_Base64;


   function Encode_Base64
     (Data : in Atom;
      Digit_62, Digit_63, Padding : in Octet)
     return Atom
   is
      Result : Atom := Encode_Base64 (Data);
   begin
      for I in Result'Range loop
         if Result (I) = Plus then
            Result (I) := Digit_62;
         elsif Result (I) = Slash then
            Result (I) := Digit_63;
         elsif Result (I) = Base64_Filler then
            Result (I) := Padding;
         end if;
      end loop;

      return Result;
   end Encode_Base64;

end Natools.S_Expressions.Encodings;