////////////////////////////////////////////////////////////////////////////////
// Copyright (c) 2001-2026 Alexey Kuryakin daqgroup@mail.ru under MIT license //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// This file is part of the CRW-DAQ project by DaqGroup - component CRWLIB.   //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Purpose:                                                                   //
// This unit containts Base32 encoder/decoder.                                //
// Base32 is binary data encoder/decoder to 32-chars alphabet. Encoder can    //
// produce human-readable & mail/tty compatible data stream & also produce    //
// data strings which can be used as filename/identifiers for program code    //
// and filename generation from any binary data source. Encoder has a size    //
// factor 8/5 (5 byte = 40 bit input converts to 8 byte = 64 bit output).     //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20170216 - Creation, first release                                         //
// 20170221 - Cosmetic changes (Base32_Alphabet_Id_xxx)                       //
// 20230505 - Modified for FPC(A.K.)                                          //
////////////////////////////////////////////////////////////////////////////////

unit _crw_base32;

{$I _crw_sysdef.inc}

{$I _crw_sysmode.inc}

{$WARN 5023 off : Unit "$1" not used in $2}

interface

uses
 //////////////////////////////////////////////////////
 {$I _crw_uses_first.inc} // NB: MUST BE FIRST USES !!!
 //////////////////////////////////////////////////////
 sysutils, classes,
 _crw_alloc, _crw_str;

 /////////////////////////////////////////////////////////////////////////////////////////////////////////////////
 // Base32 encoder/decoder. This encoder is string (memory) oriented. For stream conversion use 5-byte blocks
 // for forward convertion and 8-byte blocks for backward convertion operations.
 // Literature reference:
 //  [1]  https://tools.ietf.org/html/rfc4648                            base64,base64url,base32,base32hex,base16
 //  [2]  https://tools.ietf.org/html/rfc2938                                                           base32hex
 //  [3]  http://www.crockford.com/wrmg/base32.html                                                     crockford
 //  [4]  http://philzimmermann.com/docs/human-oriented-base-32-encoding.txt                                zooko
 //  [5]  https://tools.ietf.org/html/rfc3548                                                   obsolete standard
 //  [6]  https://habrahabr.ru/post/190054/
 /////////////////////////////////////////////////////////////////////////////////////////////////////////////////

const                                                             // Popular alphabets for Base32 encoders/decodes
 Base32_Alphabet_base32    = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ234567='; // [1] RFC4648 table 3 - default for GNU/base32 = 0
 Base32_Alphabet_base32hex = '0123456789ABCDEFGHIJKLMNOPQRSTUV='; // [1] RFC4648 table 4 - first 16 like base16   = 1
 Base32_Alphabet_crockford = '0123456789ABCDEFGHJKMNPQRSTVWXYZ';  // [3] Popular alternative, more human-readable = 2
 Base32_Alphabet_zooko     = 'ybndrfg8ejkmcpqxot1uwisza345h769';  // [4] Popular alternative, very human-readable = 3
 Base32_Alphabet_Alias_0   = '0 base32 rfc4648.3';                // Alias names of alphabet 0 - base32
 Base32_Alphabet_Alias_1   = '1 base32hex rfc4648.4';             // Alias names of alphabet 1 - base32hex
 Base32_Alphabet_Alias_2   = '2 crockford';                       // Alias names of alphabet 2 - crockford
 Base32_Alphabet_Alias_3   = '3 zooko human nice zbase32';        // Alias names of alphabet 3 - zooko
 Base32_Alphabet_Default   = Base32_Alphabet_zooko;               // Default alphabet

type
 TBase32Coder = class(TMasterObject)
 private
  myAlphabet      : packed array[0..31] of Char;
  myBackMap       : packed array[Char] of Byte;
  myPadChar       : Char;
  myNumChars      : Integer;
  myCaseSensitive : Boolean;
  function  GetPadChar:Char;
  procedure SetPadChar(aPadChar:Char);
  function  GetAlphabet:LongString;
  procedure SetAlphabet(const aAlphabet:LongString);
  function  GetCaseSensitive:Boolean;
  procedure SetCaseSensitive(aCaseSensitive:Boolean);
  function  GetUsesPadChar:Boolean;
  function  GetNumChars:Integer;
  procedure UpdateBackMap;
 public
  constructor Create(const aAlphabet:LongString=Base32_Alphabet_Default);
 public
  property PadChar       : Char        read GetPadChar       write SetPadChar;
  property Alphabet      : LongString  read GetAlphabet      write SetAlphabet;
  property CaseSensitive : Boolean     read GetCaseSensitive write SetCaseSensitive;
  property UsesPadChar   : Boolean     read GetUsesPadChar;
  property NumChars      : Integer     read GetNumChars;
 public
  function Encode(const Source:LongString):LongString;
  function Decode(const Source:LongString):LongString;
 end;

function NewBase32Coder(const aAlphabet:LongString=Base32_Alphabet_Default):TBase32Coder;
procedure Kill(var TheObject:TBase32Coder); overload;

///////////////////////////////////////////////////////////
// Easy to use base32 API
///////////////////////////////////////////////////////////
const                              // nAlphabet identifiers
 Base32_Alphabet_Id_base32    = 0; // Identify base32
 Base32_Alphabet_Id_base32hex = 1; // Identify base32hex
 Base32_Alphabet_Id_crockford = 2; // Identify crockford
 Base32_Alphabet_Id_zbase32   = 3; // Identify zbase32
 Base32_Alphabet_Id_Default   = 3; // Default alphabet ID

function base32_encode(const sData:LongString; nAlphabet:Integer=Base32_Alphabet_Id_Default):LongString;
function base32_decode(const sData:LongString; nAlphabet:Integer=Base32_Alphabet_Id_Default):LongString;

function TestBase32Coder:Boolean;

implementation
 
function NewBase32Coder(const aAlphabet:LongString=Base32_Alphabet_Default):TBase32Coder;
begin
 Result:=TBase32Coder.Create(aAlphabet);
end;

procedure Kill(var TheObject:TBase32Coder); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E,nil,'Kill');
 end; 
end;

constructor TBase32Coder.Create(const aAlphabet:LongString=Base32_Alphabet_Default);
begin
 inherited Create;
 Alphabet:=aAlphabet;
end;

function TBase32Coder.GetNumChars:Integer;
begin
 if Assigned(Self) then Result:=myNumChars else Result:=0;
end;

function TBase32Coder.GetUsesPadChar:Boolean;
begin
 if Assigned(Self) then Result:=myPadChar<>#0 else Result:=False;
end;

function TBase32Coder.GetPadChar:Char;
begin
 if Assigned(Self) then Result:=myPadChar else Result:=#0;
end;

procedure TBase32Coder.SetPadChar(aPadChar:Char);
begin
 if Assigned(Self) then
 try
  myPadChar:=aPadChar;
  UpdateBackMap;
 except
  on E:Exception do BugReport(E,Self,'SetPadChar');
 end;
end;

function TBase32Coder.GetCaseSensitive:Boolean;
begin
 if Assigned(Self) then Result:=myCaseSensitive else Result:=False;
end;

procedure TBase32Coder.SetCaseSensitive(aCaseSensitive:Boolean);
begin
 if Assigned(Self) then
 try
  if myCaseSensitive<>aCaseSensitive then begin
   myCaseSensitive:=aCaseSensitive;
   UpdateBackMap;
  end;
 except
  on E:Exception do BugReport(E,Self,'SetCaseSensitive');
 end;
end;

function TBase32Coder.GetAlphabet:LongString;
begin
 Result:='';
 if Assigned(Self) then
 try
  SetString(Result,myAlphabet,SizeOf(myAlphabet));
  if UsesPadChar then Result:=Result+PadChar;
 except
  on E:Exception do BugReport(E,Self,'GetAlphabet');
 end;
end;


procedure TBase32Coder.SetAlphabet(const aAlphabet:LongString);
 function Match(patt,list:String):Boolean;
 begin
  patt:=LowerCase(' '+Trim(patt)+' ');
  list:=LowerCase(' '+Trim(list)+' ');
  Result:=(Pos(patt,list)>0);
 end;
begin
 if Assigned(Self) then
 try
  if Length(aAlphabet)>=SizeOf(myAlphabet) then begin
   Move(PChar(aAlphabet)^,myAlphabet,SizeOf(myAlphabet));
   if Length(aAlphabet)>SizeOf(myAlphabet)
   then myPadChar:=PChar(aAlphabet)[SizeOf(myAlphabet)]
   else myPadChar:=#0;
   UpdateBackMap;
  end else
  if Match(aAlphabet,Base32_Alphabet_Alias_0) then SetAlphabet(Base32_Alphabet_base32)    else
  if Match(aAlphabet,Base32_Alphabet_Alias_1) then SetAlphabet(Base32_Alphabet_base32hex) else
  if Match(aAlphabet,Base32_Alphabet_Alias_2) then SetAlphabet(Base32_Alphabet_crockford) else
  if Match(aAlphabet,Base32_Alphabet_Alias_3) then SetAlphabet(Base32_Alphabet_zooko);
 except
  on E:Exception do BugReport(E,Self,'SetAlphabet');
 end;
end;

procedure TBase32Coder.UpdateBackMap;
var c:Char; i:Integer; LoAlphabet,HiAlphabet:LongString;
begin
 if Assigned(Self) then
 try
  for c:=Low(myBackMap) to High(myBackMap) do myBackMap[c]:=$FF;
  for i:=0 to 31 do myBackMap[myAlphabet[i]]:=i;
  myNumChars:=0;
  for c:=Low(myBackMap) to High(myBackMap) do
  if myBackMap[c]<=31 then Inc(myNumChars);
  if not CaseSensitive then begin
   SetString(LoAlphabet,myAlphabet,SizeOf(myAlphabet)); LoAlphabet:=LowerCase(LoAlphabet);
   SetString(HiAlphabet,myAlphabet,SizeOf(myAlphabet)); HiAlphabet:=UpperCase(HiAlphabet);
   for i:=0 to 31 do myBackMap[PChar(LoAlphabet)[i]]:=i;
   for i:=0 to 31 do myBackMap[PChar(HiAlphabet)[i]]:=i;
  end;
  if UsesPadChar then myBackMap[myPadChar]:=32;
 except
  on E:Exception do BugReport(E,Self,'UpdateBackMap');
 end;
end;

function TBase32Coder.Encode(const Source:LongString):LongString;
type Octet = packed array[0..7] of Byte;
var SrcLeng,SrcBits,SrcOffs,DstLeng,DstBits,DstOffs:Integer;
    SrcBuff,DstBuff:PChar; Block:Int64; BlkOffs,Shift,Code:Byte;
begin
 Result:='';
 if Assigned(Self) then
 try
  SrcLeng:=Length(Source);
  if (SrcLeng>0) then begin
   SrcOffs:=0; DstOffs:=0;
   SrcBuff:=PChar(Source);
   SrcBits:=SrcLeng shl 3;
   DstBits:=0;
   DstLeng:=(SrcBits+4) div 5;
   if UsesPadChar then
   DstLeng:=((DstLeng+7) shr 3) shl 3;
   SetLength(Result,DstLeng);
   DstBuff:=PChar(Result);
   while SrcOffs < SrcLeng do begin
    Block:=0;
    for BlkOffs:=4 downto 0 do begin
     if SrcOffs < SrcLeng then
     Octet(Block)[BlkOffs]:=Byte(SrcBuff[SrcOffs]);
     Inc(SrcOffs);
    end;
    Shift:=40;
    while Shift>0 do begin
     Dec(Shift,5);
     if DstBits < SrcBits then begin
      Code:=(Block shr Shift) and 31;
      if DstOffs < DstLeng then
      DstBuff[DstOffs]:=myAlphabet[Code];
      Inc(DstOffs);
     end else begin
      if UsesPadChar then begin
       if DstOffs < DstLeng then
       DstBuff[DstOffs]:=PadChar;
       Inc(DstOffs);
      end;
     end;
     Inc(DstBits,5);
    end;
   end;
   if DstOffs<DstLeng then SetLength(Result,DstOffs);
  end;
 except
  on E:Exception do begin
   BugReport(E,Self,'Encode');
   Result:='';
  end;
 end;
end;

function TBase32Coder.Decode(const Source:LongString):LongString;
type Octet = packed array[0..7] of Byte;
var SrcLeng,SrcSize,SrcBits,SrcOffs,DstLeng,DstBits,DstOffs,i:Integer;
    SrcBuff,DstBuff:PChar; Block,Code64:Int64; BlkOffs,Shift,Code:Byte;
begin
 Result:='';
 if Assigned(Self) then
 try
  SrcLeng:=Length(Source);
  if (SrcLeng>0) then begin
   SrcOffs:=0; SrcSize:=0;
   SrcBuff:=PChar(Source);
   for i:=0 to SrcLeng-1 do
   if myBackMap[SrcBuff[i]]<=31
   then Inc(SrcSize);
   SrcBits:=((SrcSize * 5) shr 3) shl 3;
   if SrcSize>0 then begin
    DstOffs:=0; DstBits:=0;
    DstLeng:=(SrcBits+7) shr 3;
    SetLength(Result,DstLeng);
    DstBuff:=PChar(Result);
    Block:=0; Shift:=40;
    while SrcOffs < SrcLeng do begin
     if SrcOffs < SrcLeng
     then Code:=myBackMap[SrcBuff[SrcOffs]]
     else Code:=$FF;
     if Code<=31 then begin
      Dec(Shift,5);
      Code64:=Code;
      Block:=(Code64 shl Shift) or Block;
      if Shift=0 then begin
       for BlkOffs:=4 downto 0 do begin
        if DstOffs < DstLeng then
        DstBuff[DstOffs]:=Char(Octet(Block)[BlkOffs]);
        Inc(DstOffs); Inc(DstBits,8);
       end;
       Shift:=40;
       Block:=0;
      end;
     end;
     Inc(SrcOffs);
    end;
    if DstBits<SrcBits then begin
     for BlkOffs:=4 downto 0 do  
     if DstBits<SrcBits then begin
      if DstOffs < DstLeng then
      DstBuff[DstOffs]:=Char(Octet(Block)[BlkOffs]);
      Inc(DstOffs); Inc(DstBits,8);
     end;
    end;
    if DstOffs<DstLeng then SetLength(Result,DstOffs);
   end;
  end;
 except
  on E:Exception do begin
   BugReport(E,Self,'Decode');
   Result:='';
  end;
 end;
end;

const
 TheBase32Coder : array[0..3] of TBase32Coder = (nil,nil,nil,nil);

procedure TheBase32CoderInit;
var i:Integer;
begin
 try
  for i:=Low(TheBase32Coder) to High(TheBase32Coder) do
  if not Assigned(TheBase32Coder[i]) then begin
   TheBase32Coder[i]:=NewBase32Coder(IntToStr(i));
   TheBase32Coder[i].Master:=@TheBase32Coder[i];
  end;
 except
  on E:Exception do BugReport(E,nil,'TheBase32CoderInit');
 end;
end;

procedure TheBase32CoderFree;
var i:Integer;
begin
 try
  for i:=Low(TheBase32Coder) to High(TheBase32Coder) do Kill(TheBase32Coder[i]);
 except
  on E:Exception do BugReport(E,nil,'TheBase32CoderFree');
 end;
end;

function base32_encode(const sData:LongString; nAlphabet:Integer=Base32_Alphabet_Id_Default):LongString;
begin
 Result:='';
 try
  if (Low(TheBase32Coder)<=nAlphabet) and (nAlphabet<=High(TheBase32Coder)) then begin
   if not Assigned(TheBase32Coder[nAlphabet]) then TheBase32CoderInit;
   Result:=TheBase32Coder[nAlphabet].Encode(sData);
  end;
 except
  on E:Exception do BugReport(E,nil,'base32_encode');
 end;
end;

function base32_decode(const sData:LongString; nAlphabet:Integer=Base32_Alphabet_Id_Default):LongString;
begin
 Result:='';
 try
  if (Low(TheBase32Coder)<=nAlphabet) and (nAlphabet<=High(TheBase32Coder)) then begin
   if not Assigned(TheBase32Coder[nAlphabet]) then TheBase32CoderInit;
   Result:=TheBase32Coder[nAlphabet].Decode(sData);
  end;
 except
  on E:Exception do BugReport(E,nil,'base32_decode');
 end;
end;

function TestBase32Coder:Boolean;
var s,abc:LongString; i,l,n:Integer;
begin
 Result:=false;
 try
  n:=0;
  TheBase32CoderInit;
  abc:=Base32_Alphabet_base32;
  for i:=Low(TheBase32Coder) to High(TheBase32Coder) do begin
   Echo(Format('Base32.Alphabet = %s',[TheBase32Coder[i].Alphabet]));
   for l:=0 to 30 do begin
    s:=Copy(abc,1,l);
    inc(n,Ord(s<>Base32_Decode(Base32_Encode(s,i),i)));
    Echo(Format('%-32s - %-48s - %d - %-32s - %2d - %2d - %2d',
        [s,Base32_Encode(s,i),Ord(s=Base32_Decode(Base32_Encode(s,i),i)),Base32_Decode(Base32_Encode(s,i),i),
         Length(s),Length(Base32_Encode(s,i)),Length(Base32_Decode(Base32_Encode(s,i),i))]));
   end;
  end;
  // https://habrahabr.ru/post/190054/
  // UTF8('Надеюсь, статья вам была понятна и полезна. Спасибо за внимание!');
  Echo(Base32_Decode('4nq7bcgosuemmwcq4gy7ddbcrdeadwcn4napdysttuea6egosmembwfhrdemdwcm4n77bcby4n97bxsozzea9'
      +'wcn4n67bcby4nhnbwf94n9pbq6oszemxwf74nanhegow8em9wfo4gy7bqgos8emhegos9emyegosmem5wfa4n6pbcgozzemtwfirr',3));
  Result:=(n=0);
 except
  on E:Exception do BugReport(E,nil,'TestBase32Coder');
 end;
end;

///////////////////////////////////////
// Unit initialization and finalization
///////////////////////////////////////

procedure Init_crw_base32;
begin
end;
 
procedure Free_crw_base32;
begin
 TheBase32CoderFree;
end;

initialization

 Init_crw_base32;

finalization

 Free_crw_base32;

end.

//////////////
// END OF FILE
//////////////

