{ +-------------------------------------------------------------+ }
{ |                                                             | }
{ |   GM-Software                                               | }
{ |   ===========                                               | }
{ |                                                             | }
{ |   Project: All Projects                                     | }
{ |                                                             | }
{ |   Description: Character encodings. Thread safe.            | }
{ |                Conforms to RFC 3548/4648                    | }
{ |                                                             | }
{ |   Copyright (C) - 2015 - Gerrit Moeller.                    | }
{ |                                                             | }
{ |   Source code dstributed under MIT license.                 | }
{ |                                                             | }
{ |   See: https://www.gm-software.de                           | }
{ |                                                             | }
{ +-------------------------------------------------------------+ }

{$INCLUDE GMCompilerSettings.inc}

unit GMCharCoding;

interface

uses GMStrDef, GMCommon;


function GMEncodeBase16Str(const ABinValueBytes: AnsiString): TGMString;
function GMDecodeBase16Str(const AValue: TGMString): AnsiString;

function GMEncodeBase32Str(const ABinValueBytes: AnsiString; const AAddPadding: Boolean = True): TGMString;
function GMDecodeBase32Str(const AValue: TGMString): AnsiString;

function GMEncodeBase32HexStr(const ABinValueBytes: AnsiString; const AAddPadding: Boolean = True): TGMString;
function GMDecodeBase32HexStr(const AValue: TGMString): AnsiString;

function GMEncodeBase64Str(const ABinValueBytes: AnsiString; const AAddPadding: Boolean = True): TGMString;
function GMDecodeBase64Str(const AValue: TGMString): AnsiString;

function GMEncodeBase64UrlStr(const ABinValueBytes: AnsiString; const AAddPadding: Boolean = True): TGMString;
function GMDecodeBase64UrlStr(const AValue: TGMString): AnsiString;


procedure BuildDecodeTable(var ADecodeTable: AnsiString; const AAlphabet: TGMString);

function GMEncodeBaseXX(const ABinValueBytes: AnsiString; const AAlphabet: TGMString; const ABitwidth: Integer; const AAppendPadding: Boolean; const APadAlignment: Integer): TGMString;
function GMDecodeBaseXX(const AValue: TGMString; const ADecodeTable: AnsiString; const ABitLen: Integer; const ACallingName: TGMString): AnsiString;


type

  EGMCharCodingError = class(EGMException);


const

  cBase16Alphabet = '0123456789ABCDEF';
  cBase32Alphabet = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ234567';
  cBase32HexAlphabet = '0123456789ABCDEFGHIJKLMNOPQRSTUV';
  cBase64Alphabet = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
  cBase64UrlAlphabet = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_';


implementation

uses GMIntf;

resourcestring

  RStrInvalidInputChar = 'Invalid input character "%s" at position %d';


{ ------------------ }
{ ---- Encoding ---- }
{ ------------------ }

function GMEncodeBaseXX(const ABinValueBytes: AnsiString; const AAlphabet: TGMString; const ABitwidth: Integer; const AAppendPadding: Boolean; const APadAlignment: Integer): TGMString;
const cBitMask: array [0..16] of Word= (0, 1, 3, 7, $f, $1f, $3f, $7f, $ff, $1ff, $3ff, $7ff, $fff, $1fff, $3fff, $7fff, $ffff);
var inChPos, val, bits: Integer;
begin
  SetLength(Result, 0); val := 0; bits := 0;

  for inChPos := 1 to Length(ABinValueBytes) do
   begin
    val := val shl 8;
    val := val or Ord(ABinValueBytes[inChPos]);
    Inc(bits, 8);

    while bits >= ABitwidth do
     begin
//    bits := (bits - ABitwidth);
      Dec(bits, ABitwidth);
      Result := Result + AAlphabet[(val shr bits) + 1];
      val := val and cBitMask[bits];
     end;
   end;

  if bits > 0 then
   begin
    val := val shl (ABitwidth - bits);
    Result := Result + AAlphabet[val + 1];
   end;

  if AAppendPadding and (APadAlignment > 0) then
    for inChPos := Length(Result) to GMAlignedValue(Length(Result), APadAlignment) - 1 do  Result := Result + '=';
end;

function GMEncodeBase16Str(const ABinValueBytes: AnsiString): TGMString;
begin
  Result := GMEncodeBaseXX(ABinValueBytes, cBase16Alphabet, 4, False, 0);
end;

function GMEncodeBase32Str(const ABinValueBytes: AnsiString; const AAddPadding: Boolean = True): TGMString;
begin
  Result := GMEncodeBaseXX(ABinValueBytes, cBase32Alphabet, 5, AAddPadding, 8);
end;

function GMEncodeBase32HexStr(const ABinValueBytes: AnsiString; const AAddPadding: Boolean = True): TGMString;
begin
  Result := GMEncodeBaseXX(ABinValueBytes, cBase32HexAlphabet, 5, AAddPadding, 8);
end;

function GMEncodeBase64Str(const ABinValueBytes: AnsiString; const AAddPadding: Boolean = True): TGMString;
begin
  Result := GMEncodeBaseXX(ABinValueBytes, cBase64Alphabet, 6, AAddPadding, 4);
end;

function GMEncodeBase64UrlStr(const ABinValueBytes: AnsiString; const AAddPadding: Boolean = True): TGMString;
begin
  Result := GMEncodeBaseXX(ABinValueBytes, cBase64UrlAlphabet, 6, AAddPadding, 4);
end;


{ ------------------ }
{ ---- Decoding ---- }
{ ------------------ }

var

  vCSBuildDecodeTable: IGMCriticalSection = nil;

  vBase16DecodeTable: AnsiString = '';
  vBase32DecodeTable: AnsiString = '';
  vBase32HexDecodeTable: AnsiString = '';
  vBase64DecodeTable: AnsiString = '';
  vBase64UrlDecodeTable: AnsiString = '';


procedure BuildDecodeTable(var ADecodeTable: AnsiString; const AAlphabet: TGMString);
var i: Integer;
begin
  GMEnterCriticalSection(vCSBuildDecodeTable);
  try
   if Length(ADecodeTable) <> 256 then
    begin
     SetLength(ADecodeTable, 256);
     FillByte(PAnsiChar(ADecodeTable)^, Length(ADecodeTable), 0);
     for i:=1 to Length(AAlphabet) do ADecodeTable[Byte(Ord(AAlphabet[i]))+1] := Chr(i);
    end;
  finally
   GMLeaveCriticalSection(vCSBuildDecodeTable);
  end;
end;

function GMDecodeBaseXX(const AValue: TGMString; const ADecodeTable: AnsiString; const ABitLen: Integer; const ACallingName: TGMString): AnsiString;
var i, val, bits, chVal: Integer; decodeVal: Byte;
  procedure InvalidInputError;
  begin
    raise EGMCharCodingError.ObjError(GMFormat(GMStringJoin(ACallingName, ': ', RStrInvalidInputChar), [AValue[i], i]), nil, ACallingName);
  end;
begin
  SetLength(Result, 0); val := 0; bits := 0;

  for i:=1 to Length(AValue) do
   begin
    chVal := Ord(AValue[i]);
    if chVal > 255 then InvalidInputError;
    decodeVal := Ord(ADecodeTable[chVal+1]);

    if decodeVal > 0 then
     begin
      val := val shl ABitLen;
      val := val or (decodeVal - 1);

      bits := bits + ABitLen;

      while bits >= 8 do
       begin
        bits := bits - 8;
        Result := Result + AnsiChar((val shr bits)); //  and $FF
       end;
     end
    else case AValue[i] of
          //#10, #13: ; Nothing, skip line breaks?
          '=': Break;
          else InvalidInputError;
         end;
   end;
end;

function GMDecodeBase16Str(const AValue: TGMString): AnsiString;
begin
  BuildDecodeTable(vBase16DecodeTable, cBase16Alphabet);
  Result := GMDecodeBaseXX(GMUpperCase(AValue), vBase16DecodeTable, 4, 'GMDecodeBase16Str');
end;

function GMDecodeBase32Str(const AValue: TGMString): AnsiString;
begin
  BuildDecodeTable(vBase32DecodeTable, cBase32Alphabet);
  Result := GMDecodeBaseXX(GMUpperCase(AValue), vBase32DecodeTable, 5, 'GMDecodeBase32Str');
end;

function GMDecodeBase32HexStr(const AValue: TGMString): AnsiString;
begin
  BuildDecodeTable(vBase32HexDecodeTable, cBase32HexAlphabet);
  Result := GMDecodeBaseXX(GMUpperCase(AValue), vBase32HexDecodeTable, 5, 'GMDecodeBase32HexStr');
end;

function GMDecodeBase64Str(const AValue: TGMString): AnsiString;
begin
  BuildDecodeTable(vBase64DecodeTable, cBase64Alphabet);
  Result := GMDecodeBaseXX(AValue, vBase64DecodeTable, 6, 'GMDecodeBase64Str'); // <- No Upper case here! Base 64 alphabet distunguishes upper and lower charachters!
end;

function GMDecodeBase64UrlStr(const AValue: TGMString): AnsiString;
begin
  BuildDecodeTable(vBase64UrlDecodeTable, cBase64UrlAlphabet);
  Result := GMDecodeBaseXX(AValue, vBase64UrlDecodeTable, 6, 'GMDecodeBase64UrlStr'); // <- No Upper case here! Base 64 alphabet distunguishes upper and lower charachters!
end;


initialization

  vCSBuildDecodeTable := TGMCriticalSection.Create;

end.