Re: Base64 encoding and decoding (preferably public domain)

[Shark8 <onewingedshark@gmail.com>]

On Saturday, August 20, 2016 at 12:23:30 PM UTC-6, jo...@peppermind.com wrote:
> Hi!
> 
> Does anybody happen to have a source package for Base64 encoding and decoding of in-memory strings?
> 
> I'm writing a small package that I intend to release under an MIT license and therefore don't want to use any of the large libraries like Ada.utils or GNATcoll.

Pragma Ada_2012;
Pragma Assertion_Policy( Check );

With
Ada.Containers.Indefinite_Vectors,
Interfaces;

Package Base_64 is

    Type Base_64_Character is
      (	'A',	'B',	'C',	'D',	'E',
       	'F',	'G',	'H',	'I',	'J',
	'K',	'L',	'M',	'N',	'O',
	'P',	'Q',	'R',	'S',	'T',
	'U',	'V',	'W',	'X',	'Y',
	'Z',	'a',	'b',	'c',	'd',
	'e',	'f',	'g',	'h',	'i',
	'j',	'k',	'l',	'm',	'n',
	'o',	'p',	'q',	'r',	's',
	't',	'u',	'v',	'w',	'x',
	'y',	'z',	'0',	'1',	'2',
	'3',	'4',	'5',	'6',	'7',
	'8',	'9',	'+',	'/',	'='
      ) with Size => 8, Object_Size => 8;

    Subtype Nonpad_Character is Base_64_Character range
      Base_64_Character'First..Base_64_Character'Pred(Base_64_Character'Last);

    type Base_64_String is Array(Positive range <>) of Base_64_Character
      with Dynamic_Predicate =>
	-- Base64 Strings always have a length that is a multiple of 4.
	(Base_64_String'Length mod 4 = 0 or else raise Constraint_Error with "Illegal Base64 length:" & Natural'Image(Base_64_String'Length))
--        and then
--  	-- Only the last two characters can be padding.
--  	(for all Index in Base_64_String'First..Base_64_String'Last - 2 =>
--             Base_64_String(Index) in Nonpad_Character --or else raise Constraint_Error with "Malformed Base64 string."
--           )
       and then
        -- Pad characters must come at the end, if present.
    (if Base_64_String'Length > 1 and then Base_64_String(Base_64_String'Last-1) = '=' then
	 (if Base_64_String(Base_64_String'Last) /= '=' then raise Constraint_Error with "Nonterminal pad character detected."
	  else True)
    );
    
    
    Function Encode( Data : String ) return Base_64_String;
    Function Decode( Data : Base_64_String ) return String;
    
    -- Converts a Base_64_String to a String.
    -- NOTE: This does NOT entail decoding.
    Function To_String( Data : Base_64_String ) return String;

    Type Encoder is private;
    Procedure Feed( State : in out Encoder; Data : Interfaces.Integer_8 );
    Function  Get_Data( State : in Encoder ) return Base_64_String;
    Function  Reset( State : in out Encoder) return Base_64_String;
    Procedure Reset( State : in out Encoder; Data : Base_64_String );
    Procedure Reset( State : in out Encoder );

Private
    
    Package Internals is
	
	----------------------
	--  INTERNAL TYPES  --
        ----------------------
 
	Type Base_64_Chunk  is array(Positive range 1..4) of Base_64_Character;
	
	Type Internal_Count is range 1..3;

	Type Internal_Character is new Nonpad_Character
	  with Size => 6;

	Type Quad    is record 
	    A, B, C, D : Internal_Character;
	end record
	  with Size => 24, Object_Size => 24, Pack; --, Bit_Order => System.Low_Order_First; --, alignment => 0, Pack, 
	
	For Quad use record at mod 8;
	    D at 0 range 0..5;
	    C at 0 range 6..11;
	    B at 0 range 12..17;
	    A at 0 range 18..23;
	end record;
	
	
	Type Tripple is record
	    A, B, C : Interfaces.Integer_8;
	end record
	  with Size => 24, Object_Size => 24, Pack;--, Bit_Order => System.High_Order_First;
    
	For Tripple use record at mod 8;
	    A at 2 range 0..7;
	    B at 1 range 0..7;
	    C at 0 range 0..7;
	end record;
	
	-------------------------
	--  INTERNAL PACKAGES  --
        -------------------------
	
	Package Internal_Data_Vector is new Ada.Containers.Indefinite_Vectors(
	    Index_Type   => Positive,
 	    Element_Type => Quad,
	    "="          => "="
	);
	
	--------------------------
	--  INTERNAL FUNCTIONS  --
        --------------------------
	
	
	Function Convert( Source : Quad ) return Tripple with Inline, Pure_Function;
	Function Convert( Source : Tripple ) return Quad with Inline, Pure_Function;
	Function Convert( Source : Base_64_Chunk) return Quad with Inline, Pure_Function;
	Function Convert( Source : Quad) return Base_64_Chunk with Inline, Pure_Function;
    End Internals;
    
    Type Encoder is record -- new Ada.Finalization.Controlled with record
	Result : Internals.Internal_Data_Vector.Vector;
	B1, B2 : Interfaces.Integer_8:= Interfaces.Integer_8'First;

	Current : Internals.Internal_Count := Internals.Internal_Count'First;
    end record;


End Base_64;

-------------------------------
-------------------------------

Pragma Ada_2012;
Pragma Assertion_Policy( Check );

With
System,
Unchecked_Conversion;

Package Body Base_64 is

    Package Body Internals is
	
	Function Internal_Convert is new Unchecked_Conversion(
	    Source => Tripple,
	    Target => Quad
	   );
	
	Function Internal_Convert is new Unchecked_Conversion(
	    Source => Quad,
 	    Target => Tripple
	   );
	
	Function Convert( Source : Quad ) return Tripple is
	  ( Internal_Convert(Source) );
	Function Convert( Source : Tripple ) return Quad is
	  ( Internal_Convert(Source) );
	
	Function Convert (Source : Base_64_Chunk) return Quad is
	(if (for all C of Source => C in Nonpad_Character) then
	  (  Internal_Character( Source(1) ),
	     Internal_Character( Source(2) ),
	     Internal_Character( Source(3) ),
	     Internal_Character( Source(4) )
	  ) else raise Program_Error with "Cannot convert a chunk with padding."
	);
    
    
	Function Convert (Source : Quad) return Base_64_Chunk is
	  (Base_64_Character( Source.A ),
	   Base_64_Character( Source.B ),
	   Base_64_Character( Source.C ),
	   Base_64_Character( Source.D )
	  );
	
	Function Internal_Convert is new Unchecked_Conversion(
	    Source => Interfaces.Integer_8,
	    Target => Character
	   );
	
    end Internals;
    
    
    Function Convert is new Unchecked_Conversion(
       Source => Character,
       Target => Interfaces.Integer_8
      );

    Function Convert is new Unchecked_Conversion(
       Source => Interfaces.Integer_8,
       Target => Character
      );
    

    Function Encode( Data : String ) return Base_64_String is
	State : Encoder;
    begin
	for Item of Data loop
	    Feed( State, Convert(Item) );
	end loop;

	Return Get_Data( State );
    end Encode;

    Function Decode( Data : Base_64_String ) return String is
	Local_Encoder : Encoder;
	Chunk_Size : Constant := 3;
    begin
	if Data'Length not in Positive then
	    Return "";
	end if;

	Reset( Local_Encoder, Data );
	
	Decode_Process:
	Declare
	    Has_Pad : Constant Boolean := Data(Data'Last)   not in Nonpad_Character;
	    Two_Pad : Constant Boolean := Data(Data'Last-1) not in Nonpad_Character;
	    
	    Subtype Chunk_Range is Positive range 1 .. Data'Length/4
	        + (if Has_Pad then -1 else 0);
	    
	    Padding : Constant Natural := (
	       if    Two_Pad then 1
	       elsif Has_Pad then 2
	       else               0
	      );
	    
	    Result_Length : Constant Natural := Chunk_Range'Last*3 + Padding;
	Begin
	    Return Result : String(1..Result_Length) := (others => '?') do
		Handle_Nonpad_Characters:
		For Index in Chunk_Range loop
		    declare
			Use Internals;
			Chunk_Start : Constant Positive := Positive'Succ(Natural'Pred(Index)*4);
			Subtype Chunk is Positive range Chunk_Start..Chunk_Start+Chunk_Size;
			Start : Constant Positive := Natural'Pred(Index)*Chunk_Size + Result'First;
			Stop  : Constant Positive := Start + Chunk_Size - 1;
			
			Temp : Constant Base_64_Chunk := Base_64_Chunk(Data(Chunk));
			Four : Quad renames Convert( Temp );
			Three: Tripple renames Convert( Four );
		    begin
			Result(Start..Stop):= 
			  (Convert(Three.A),
			   Convert(Three.B),
			   Convert(Three.C)
			  );
		    end;
		End Loop Handle_Nonpad_Characters;
		
		if Has_Pad then
		    Handle_Padding:
		    Declare
			Use Internals;
			Tail : Base_64_String renames Data(Data'Last-3..Data'Last);
			B64C : Constant Base_64_Chunk := Base_64_Chunk(Tail);
			Q    : Constant Quad := 
			  (   Internal_Character( B64C(1) ),
			      Internal_Character( B64C(2) ),
			      (if Two_Pad then Internal_Character'First
			       else Internal_Character( B64C(3) )),
			      Internal_Character'First
			  );
			Three : Tripple renames Convert( Q );
		    Begin
			Result(Result'Last-1):= Convert(Three.A);
			Result(Result'Last  ):= Convert(Three.B);
		    End Handle_Padding;
		end if;
	    End return;
	End Decode_Process;
    End Decode;


    Function To_String( Data : Base_64_String ) return String is
    Begin
	Return Result : String( Data'Range ) do
	    for Index in Data'Range loop
		declare
		    B64C  : Base_64_Character renames Data(Index);
		    Pos   : Constant Natural := Base_64_Character'Pos( B64C );
		    Image : String renames Base_64_Character'Image( Base_64_Character'Val(Pos) );
		    CI    : Character renames Image(2);
		begin
		    Result(Index):= CI;
		end;
	    end loop;
	End return;
    End To_String;


    -------


    Procedure Feed( State : in out Encoder; Data : Interfaces.Integer_8 ) is
	Use Internals;
    begin
	case State.Current is
	when 1 =>
	    State.B1:= Data;
	    State.Current:= Internal_Count'Succ( State.Current );
	when 2 =>
	    State.B2:= Data;
	    State.Current:= Internal_Count'Succ( State.Current );
	when 3 =>
	    Process:
	    Declare
		Three_Bytes : Constant Tripple := (State.B1, State.B2, Data);
		Four_Chars  : Quad renames Convert(Three_Bytes);
	    Begin
		State.Result.Append( Four_Chars );
		State.Current:= Internal_Count'First;
	    End Process;
	end case;
    End Feed;

    Function  Get_Data( State : in Encoder ) return Base_64_String is
	Use Ada.Containers, Internals.Internal_Data_Vector, Internals;
	Chunk_Size : Constant := Base_64_Chunk'Length;
	Padding : Constant Natural := (if State.Current = 1 then 0 else 1);
	Subtype Result_Range is Positive range 1..Natural(State.Result.Length);
	Subtype Padded_Range is Positive range 1..(Result_Range'last+Padding)*Chunk_Size;
    begin
	Return Result : Base_64_String(Padded_Range) := (others => '=') do
	    Transpose_Result:
	    For Index in Result_Range loop
		declare
		    Offset : Constant Natural := Chunk_Size*Natural'Pred(Index);
		    Start  : Constant Positive:= Offset+1;
		    Stop   : Constant Positive:= Positive'Pred(Start+Chunk_Size);
		    Temp   : Base_64_Chunk renames Convert(State.Result(Index));
		begin
		    Result(Start..Stop):= Base_64_String( Temp );
		end;
	    End Loop Transpose_Result;

	    Handle_Tail:
	    declare
	    begin
		case State.Current is
		when 1 => null;
		when others =>
		    declare
			Three : Constant Tripple := (State.B1, State.B2, 0);
			Four  : Base_64_Chunk renames Convert(Convert(Three));
		    begin
			Result(Padded_Range'Last-3):= Four(1);
			Result(Padded_Range'Last-2):= Four(2);
			if State.Current = 3 then
			    Result(Padded_Range'Last-1):= Four(3);
			end if;
		    end;
		end case;
	    End Handle_Tail;
	end return;
    end Get_Data;

    Function  Reset( State : in out Encoder) return Base_64_String is
    Begin
	Return Result : constant Base_64_String := Get_Data(State) do
	    Reset(State);
	End return;
    End Reset;
    
    Procedure Reset( State : in out Encoder; Data : Base_64_String ) is
    begin
	Reset(State);
	if Data'Length not in Positive then
	    Return;
	else
	    Decode:
	    declare
		Use Internals;
		Has_Pad     : Constant Boolean := Data(Data'Last) not in Nonpad_Character;
		Two_Pad     : Constant Boolean := Data(Data'Last-1) not in Nonpad_Character;
		Data_Length : Constant Integer := Data'Length / 4 - (if Has_Pad then 1 else 0);
		Subtype Chunk_Index is Positive range Data'First..Data_Length;
	    begin
		Common_Portion:
		For Index in Chunk_Index loop
		    declare
			C : Constant Base_64_Chunk := Base_64_Chunk(Data(Index*4..Index*4+3));
			Q : Quad renames Convert(C);
		    begin			
			State.Result.Append( Q );
		    end;
		End Loop Common_Portion;
		
		if Has_Pad then
		    Handle_Padding:
		    Declare
			Tail : Base_64_String renames Data(Data'Last-3..Data'Last);
			B64C : Constant Base_64_Chunk := Base_64_Chunk(Tail);
			Q    : Constant Quad := 
			  (
			    Internal_Character( B64C(1) ),
			    Internal_Character( B64C(2) ),
			    (if Two_Pad then Internal_Character'First
			     else Internal_Character( B64C(3) )),
			    Internal_Character'First
			  );
			Three : Tripple renames Convert( Q );
		    Begin
			State.B1 := Three.A;
			if Two_Pad then 
			    State.B2:= Three.B;
			    State.Current:= 3;
			else
			    State.Current:= 2;
			end if;
		    End Handle_Padding;
		end if;
	    End Decode;
	end if;
    end Reset;
    
    Procedure Reset( State : in out Encoder ) is
    Begin
	State.Result.Clear;
	State.Current:= 1;
	State.B1 := Interfaces.Integer_8'First;
	State.B2 := Interfaces.Integer_8'First;
    End Reset;

End Base_64;