ADDED src/natools-s_expressions-encodings.adb Index: src/natools-s_expressions-encodings.adb ================================================================== --- src/natools-s_expressions-encodings.adb +++ src/natools-s_expressions-encodings.adb @@ -0,0 +1,338 @@ +------------------------------------------------------------------------------ +-- 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, 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; + +end Natools.S_Expressions.Encodings; ADDED src/natools-s_expressions-encodings.ads Index: src/natools-s_expressions-encodings.ads ================================================================== --- src/natools-s_expressions-encodings.ads +++ src/natools-s_expressions-encodings.ads @@ -0,0 +1,104 @@ +------------------------------------------------------------------------------ +-- 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 Natools.S_Expressions.Encodings is + pragma Pure (Natools.S_Expressions.Encodings); + + + ----------------------------- + -- Meaningful Octet Values -- + ----------------------------- + + -- S-expression Active Characters -- + + Base64_Atom_Begin : constant Octet := Character'Pos ('|'); + Base64_Atom_End : constant Octet := Character'Pos ('|'); + Base64_Expr_Begin : constant Octet := Character'Pos ('{'); + Base64_Expr_End : constant Octet := Character'Pos ('}'); + Base64_Filler : constant Octet := Character'Pos ('='); + Escape : constant Octet := Character'Pos ('\'); + Hex_Atom_Begin : constant Octet := Character'Pos ('#'); + Hex_Atom_End : constant Octet := Character'Pos ('#'); + List_Begin : constant Octet := Character'Pos ('('); + List_End : constant Octet := Character'Pos (')'); + Quoted_Atom_Begin : constant Octet := Character'Pos ('"'); + Quoted_Atom_End : constant Octet := Character'Pos ('"'); + Verbatim_Begin : constant Octet := Character'Pos (':'); + + + -- Blanks -- + + HT : constant Octet := 9; + LF : constant Octet := 10; + VT : constant Octet := 11; + FF : constant Octet := 12; + CR : constant Octet := 13; + Space : constant Octet := 32; + + + -- Encoding-related Values -- + + Digit_0 : constant Octet := Character'Pos ('0'); + Digit_9 : constant Octet := Character'Pos ('9'); + Lower_A : constant Octet := Character'Pos ('a'); + Lower_F : constant Octet := Character'Pos ('f'); + Lower_Z : constant Octet := Character'Pos ('z'); + Upper_A : constant Octet := Character'Pos ('A'); + Upper_F : constant Octet := Character'Pos ('F'); + Upper_Z : constant Octet := Character'Pos ('Z'); + Plus : constant Octet := Character'Pos ('+'); + Slash : constant Octet := Character'Pos ('/'); + + + + --------------------------------------- + -- Hexadecimal Encoding and Decoding -- + --------------------------------------- + + type Hex_Casing is (Upper, Lower); + + function Is_Hex_Digit (Value : in Octet) return Boolean; + function Decode_Hex (Value : in Octet) return Octet; + function Decode_Hex (High, Low : in Octet) return Octet; + function Decode_Hex (Data : in Atom) return Atom; + + function Encode_Hex (Value : in Octet; Casing : in Hex_Casing) return Octet; + procedure Encode_Hex + (Value : in Octet; + Casing : in Hex_Casing; + High, Low : out Octet); + function Encode_Hex (Data : in Atom; Casing : in Hex_Casing) return Atom; + + + + ----------------------------------- + -- Base-64 Encoding and Decoding -- + ----------------------------------- + + function Is_Base64_Digit (Value : in Octet) return Boolean; + function Decode_Base64 (Value : in Octet) return Octet; + function Decode_Base64 (A, B : in Octet) return Atom; + function Decode_Base64 (A, B, C : in Octet) return Atom; + function Decode_Base64 (A, B, C, D : in Octet) return Atom; + function Decode_Base64 (Data : in Atom) return Atom; + + function Encode_Base64 (Value : in Octet) return Octet; + procedure Encode_Base64 (Output : out Atom; A : in Octet); + procedure Encode_Base64 (Output : out Atom; A, B : in Octet); + procedure Encode_Base64 (Output : out Atom; A, B, C : in Octet); + function Encode_Base64 (Data : in Atom) return Atom; + +end Natools.S_Expressions.Encodings;