* Base16/32/64/64URL encoders/decoders, not stream based

packages/fcl-base/examples/demobasenenc.lpr

@@ -0,0 +1,135 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2021 by Michael Van Canneyt,
+    member of the Free Pascal development team
+
+    Demo program for Base16,Base32,Base32-hex,Base32-crockford, Base64,Base64url encoding/decoding
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+program demobasenenc;
+
+uses sysutils, basenenc, typinfo, custapp, Classes;
+
+Type
+
+  { TDemoApp }
+
+  TDemoApp = Class(TCustomApplication)
+  private
+    FEncoder : TStandardEncoder;
+    FPadding,
+      FDoDecode : Boolean;
+    procedure ParseOptions;
+    procedure Usage(aError: String);
+  Protected
+    Procedure DoRun; override;
+  end;
+
+{ TDemoApp }
+
+procedure TDemoApp.Usage(aError : String);
+
+Var
+  Enc : TStandardEncoder;
+
+begin
+  if (aError<>'') then
+    Writeln('Error : ',aError);
+  Writeln('Usage ', ExtractFileName(Self.ExeName),' [options]');
+  Writeln('Where options is one or more of');
+  Writeln('-h --help            This message');
+  Writeln('-e --encode=ENC      Encode input to output using algorithm ENC, one of');
+  For Enc in TStandardEncoder do
+    Writeln('                   ',Copy(GetEnumName(TypeInfo(TStandardEncoder),Ord(Enc)),3,MaxInt));
+  Writeln('-d --decode=ENC      Encode input to output using algorithm ENC, one of the above');
+  Writeln('-i --input=FileName  Set input filename. Required.');
+  Writeln('-o --output=FileName Set input filename. Required.');
+  Writeln('-p --pad             Use Padding when encoding.');
+  ExitCode:=Ord(aError<>'');
+end;
+
+procedure TDemoApp.ParseOptions;
+
+Var
+  S : String;
+  I : Integer;
+
+begin
+  FDoDecode:=False;
+  S:=CheckOptions('hi:o:e:p',['help','input:','output:','encode:','decode:','pad']);
+  if Not (HasOption('i','input') and HasOption('o','output')) then
+    S:='Input and output filename are required';
+  if (S<>'') or HasOption('h','help') then
+    begin
+    Usage(S);
+    Exit;
+    end;
+  FPadding:=HasOption('p','pad');
+  S:=GetOptionValue('e','encode');
+  if S='' then
+    begin
+    S:=GetOptionValue('d','decode');
+    if S<>'' then
+      FDoDecode:=True;
+    end;
+  if (S='') then
+    S:='base64';
+  i:=GetEnumValue(TypeInfo(TStandardEncoder),S);
+  if I=-1 then
+    i:=GetEnumValue(TypeInfo(TStandardEncoder),'se'+S);
+  if I=-1 then
+    begin
+    Usage('Not a valid algorithm: '+s);
+    Exit;
+    end;
+  FEncoder:=TStandardEncoder(I);
+end;
+
+procedure TDemoApp.DoRun;
+
+
+Var
+  B,Res : TBytes;
+  F : TFileStream;
+  Coder : TAlphabetEncoder;
+
+begin
+  B:=[];
+  Terminate;
+  Parseoptions;
+  if ExitCode<>0 then
+    exit;
+  F:=TFileStream.Create(GetOptionValue('i','input'),fmOpenRead or fmShareDenyWrite);
+  try
+    SetLength(B,F.Size);
+    F.ReadBuffer(B,F.Size);
+  finally
+    F.Free;
+  end;
+  Coder:=GetStandardEncoder(FEncoder);
+  if FDoDecode then
+    Res:=Coder.Decode(PByte(B),Length(B))
+  else
+    Res:=TEncoding.UTF8.GetAnsiBytes(Coder.Encode(PByte(B),Length(B),FPadding));
+  F:=TFileStream.Create(GetOptionValue('o','output'),fmCreate);
+  try
+    F.WriteBuffer(Res,Length(Res))
+  finally
+    F.Free;
+  end;
+end;
+
+begin
+  CustomApplication:=TDemoApp.Create(Nil);
+  CustomApplication.Initialize;
+  CustomApplication.Run;
+  CustomApplication.Free;
+end.
+

packages/fcl-base/src/basenenc.pp

@@ -0,0 +1,327 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2021 by Michael Van Canneyt,
+    member of the Free Pascal development team
+
+    Base16,Base32,Base32-hex,Base32-crockford, Base64,Base64url encoding/decoding, with or without padding
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+unit basenenc;
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses Types, SysUtils;
+
+Type
+
+  { TAlphabetEncoder }
+  TReverseAlphabet = Array[0..255] of Byte;
+  TStandardEncoder = (seBase16,
+                      seBase32,seBase32hex,seBase32CrockFord,
+                      seBase64,seBase64URL);
+  TAlphabetEncoder = Class (TObject)
+  protected
+    Const
+      StdBits : Array[TStandardEncoder] of Byte  = (4,5,5,5,6,6);
+      StdPads : Array[TStandardEncoder] of Byte  = (0,8,8,8,4,4);
+      StdAlpha : Array[TStandardEncoder] of String = (
+        '0123456789ABCDEF',
+        'ABCDEFGHIJKLMNOPQRSTUVWXYZ234567',
+        '0123456789ABCDEFGHIJKLMNOPQRSTUV',
+        '0123456789ABCDEFGHJKMNPQRSTVWZYZ',
+        'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/',
+        'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_');
+  Private
+    FBits : Byte;
+    FAlphabet : TByteDynArray;
+    FReverse : TReverseAlphabet;
+    FPadding : Integer;
+    class var StdEncoders : Array[TStandardEncoder] of TAlphabetEncoder;
+    class function GetStdEncoder(AIndex: Integer): TAlphabetEncoder; static;
+  public
+    // Construct an encoder with alphabet, bits per letter, padding size in bits
+    Constructor Create(aAlphabet : AnsiString; aBits : Byte; aPadding : Integer); virtual;
+    // Destroy all standard encoders
+    Class Destructor Done;
+    // Create a standard encoder. You must free the result
+    Class Function CreateStdEncoder(Std: TStandardEncoder): TAlphabetEncoder;
+    // Encode data in buffer aBuffer with length aLen. If doPad is true, add padding if needed.
+    Function Encode(aBuffer : PByte; aLen : Cardinal; doPad : Boolean = True) : AnsiString; virtual; overload;
+    // Encode data in buffer aBuffer. If doPad is true, add padding if needed.
+    Function Encode(aBuffer : TBytes; doPad : Boolean = True) : AnsiString; overload;
+    // Encode data in string aBuffer. If doPad is true, add padding if needed.
+    Function Encode(aBuffer : AnsiString; doPad : Boolean = True) : AnsiString; overload;
+    // Decode aSrcBuffer with length aLen.
+    // Buffer must have enough room. Calculate maximum needed room with GetDecodeLen
+    Function Decode(const aSrcBuffer : PByte; aLen : Integer; ABuffer : PByte) : Integer; virtual; overload;
+    // Buffer must have enough room. Calculate maximum needed room with GetDecodeLen
+    Function Decode(const S : AnsiString; ABuffer : PByte) : Integer; overload;
+    // Return a buffer with decoded data.
+    Function Decode(const S : AnsiString) : TBytes; overload;
+    // Return a buffer with decoded data, starting with buffer.
+    Function Decode(const aBuffer: PByte; aLen : Integer) : TBytes; overload;
+    // Get a decoding length for the encoded string S. May be oversized due to padding.
+    Function GetDecodeLen(const S : AnsiString) : Integer;
+    // Bits per characters
+    Property Bits : Byte Read FBits;
+    // ASCII value of characters
+    Property Alphabet : TByteDynArray Read FAlphabet;
+    // Reverse byte->character map
+    Property Reverse : TReverseAlphabet Read FReverse;
+    // Bits of padding
+    Property Padding : Integer Read FPadding;
+    // Standard encoders.
+    Class Property Base16 : TAlphabetEncoder Index Ord(seBase16) Read GetStdEncoder;
+    Class Property Base32 : TAlphabetEncoder Index Ord(seBase32) Read GetStdEncoder;
+    Class Property Base32Hex : TAlphabetEncoder Index Ord(seBase32Hex)  Read GetStdEncoder;
+    Class Property Base32Crockford : TAlphabetEncoder Index Ord(seBase32Crockford)  Read GetStdEncoder;
+    Class Property Base64 : TAlphabetEncoder  Index Ord(seBase64)  Read GetStdEncoder;
+    Class Property Base64URL : TAlphabetEncoder  Index Ord(seBase64Url)  Read GetStdEncoder;
+  end;
+
+// Shortcut access to standard encoders.
+// Do not free the results !
+Function Base16 : TAlphabetEncoder;
+Function Base32 : TAlphabetEncoder;
+Function Base32Hex : TAlphabetEncoder;
+Function Base32Crockford : TAlphabetEncoder;
+Function Base64 : TAlphabetEncoder;
+Function Base64URL : TAlphabetEncoder;
+Function GetStandardEncoder(aEncoder : TStandardEncoder): TAlphabetEncoder;
+
+implementation
+
+Function TAlphabetEncoder.Encode(aBuffer : TBytes; doPad : Boolean = True) : AnsiString;
+
+begin
+  Result:=Encode(PByte(aBuffer),Length(aBuffer),DoPad);
+end;
+
+
+function TAlphabetEncoder.Encode(aBuffer: AnsiString; doPad : Boolean = True): AnsiString;
+
+begin
+  Result:=Encode(TEncoding.UTF8.GetAnsiBytes(aBuffer),DoPad);
+end;
+
+
+Constructor TAlphabetEncoder.Create(aAlphabet: AnsiString; aBits: Byte; aPadding: Integer);
+
+Var
+  I : Integer;
+
+begin
+  if (Length(aAlphabet)<2) or (Length(aAlphabet)>255) then
+    Raise Exception.Create('Invalid alphabet length');
+  FBits:=ABits;
+  FPadding:=aPadding;
+  SetLength(FAlphaBet,Length(aAlphabet));
+  Move(aAlphabet[1],FAlphaBet[0],Length(aAlphabet));
+  for I:=1 to Length(aAlphabet) do
+    FReverse[Ord(aAlphaBet[i])]:=I;
+end;
+
+
+class destructor TAlphabetEncoder.Done;
+
+Var
+  Std : TStandardEncoder;
+
+begin
+  For Std in TStandardEncoder do
+    FreeAndNil(StdEncoders[Std]);
+end;
+
+
+class function TAlphabetEncoder.CreateStdEncoder(Std : TStandardEncoder) : TAlphabetEncoder;
+
+begin
+  Result:=TAlphaBetEncoder.Create(StdAlpha[Std],StdBits[Std],StdPads[Std]);
+end;
+
+
+class function TAlphabetEncoder.GetStdEncoder(AIndex: Integer): TAlphabetEncoder; static;
+
+Var
+  Std : TStandardEncoder;
+
+begin
+  Std:=TStandardEncoder(aIndex);
+  if (StdEncoders[Std]=Nil) then
+    StdEncoders[Std]:=CreateStdEncoder(Std);
+  Result:=StdEncoders[Std];
+end;
+
+
+function TAlphabetEncoder.Encode(aBuffer: PByte; Alen : Cardinal; doPad : Boolean = True): Ansistring;
+
+var
+  pSrc, pDest: pByte;
+  I, Reg, lBits, PadLen,OutLen: integer;
+
+
+begin
+  Result:='';
+  Reg:=0;
+  lBits:=0;
+  PadLen:=0;
+  OutLen:=aLen*8;
+  OutLen:=(OutLen div Bits)+Ord((OutLen mod Bits) > 0 );
+  if DoPad and (Padding>0) then
+    begin
+    PadLen:=OutLen mod Padding;
+    if PadLen>0 then
+      Inc(OutLen,(Padding-PadLen));
+    end;
+  SetLength(Result,OutLen);
+  pSrc:=aBuffer;
+  pDest:=@Result[1];
+  for i:=1 to aLen do
+    begin
+    Reg:=Reg shl 8;
+    Reg:=Reg or pSrc^;
+    Inc(lBits,8);
+    inc(pSrc);
+    while (lBits>=Bits) do
+      begin
+      Dec(lBits,Bits);
+      pDest^:=Alphabet[(Reg shr lBits)];
+      Reg:= Reg-((Reg shr lBits) shl lBits);
+      inc(pDest);
+      end;
+    end;
+  if (lBits>0) then
+    begin
+    pDest^:=Alphabet[Reg shl (Bits-lBits)];
+    inc(pDest);
+    end;
+  if DoPad and (PadLen>0) then
+    FillChar(pDest^,Padding-PadLen,'=');
+end;
+
+
+Function TAlphabetEncoder.Decode(const aSrcBuffer : PByte; aLen : Integer; ABuffer : PByte) : Integer;
+
+var
+  i, Reg, lBits : Integer;
+  pSrc, pDest: pByte;
+
+begin
+  Reg:=0;
+  lBits:=0;
+  Result:=0;
+  while (aLen>0) and (aSrcBuffer[aLen-1]=Ord('=')) do
+    Dec(aLen);
+  if Alen=0 then exit;
+  pSrc:=@aSrcBuffer[0];
+  pDest:=aBuffer;
+  for i:=1 to aLen do
+    begin
+    if Reverse[pSrc^] <= 0 then
+      break;
+    Reg:=Reg shl Bits;
+    Reg:=Reg or (Reverse[pSrc^]-1);
+    Inc(lBits,Bits);
+    while (lBits>=8) do
+      begin
+      Dec(lBits,8);
+      pDest^:=Reg shr lBits;
+      inc(pDest);
+      end;
+    inc(pSrc);
+    end;
+  Result:=pDest-aBuffer;
+end;
+
+
+Function TAlphabetEncoder.GetDecodeLen(const S : AnsiString) : Integer;
+
+begin
+  Result:=(length(s)*Bits) div 8;
+end;
+
+
+function TAlphabetEncoder.Decode(const S: AnsiString): TBytes;
+
+begin
+  Result:=[];
+  SetLength(Result,GetDecodeLen(S));
+  SetLength(Result,Decode(S,PByte(Result)));
+end;
+
+
+function TAlphabetEncoder.Decode(const aBuffer: PByte; aLen: Integer): TBytes;
+
+begin
+  Result:=[];
+  SetLength(Result,(aLen*Bits) div 8);
+  SetLength(Result,Decode(aBuffer,aLen,PByte(Result)));
+end;
+
+
+Function TAlphabetEncoder.Decode(const S : AnsiString; ABuffer : PByte) : Integer; overload;
+
+begin
+  Result:=Decode(PByte(S),Length(S),ABuffer);
+end;
+
+
+Function Base16 : TAlphabetEncoder;
+
+begin
+  Result:=TAlphabetEncoder.Base16;
+end;
+
+
+Function Base32 : TAlphabetEncoder;
+
+begin
+  Result:=TAlphabetEncoder.Base32;
+end;
+
+
+Function Base32Hex : TAlphabetEncoder;
+
+begin
+  Result:=TAlphabetEncoder.Base32Hex;
+end;
+
+
+Function Base32CrockFord : TAlphabetEncoder;
+
+begin
+  Result:=TAlphabetEncoder.Base32CrockFord;
+end;
+
+
+Function Base64 : TAlphabetEncoder;
+
+begin
+  Result:=TAlphabetEncoder.Base64;
+end;
+
+
+Function Base64URL : TAlphabetEncoder;
+
+begin
+  Result:=TAlphabetEncoder.Base64URL;
+end;
+
+
+Function GetStandardEncoder(aEncoder : TStandardEncoder): TAlphabetEncoder;
+
+begin
+  Result:=TAlphabetEncoder.GetStdEncoder(Ord(aEncoder));
+end;
+
+end.
+

packages/fcl-base/tests/testbasenenc.lpr

@@ -0,0 +1,165 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2021 by Michael Van Canneyt,
+    member of the Free Pascal development team
+
+    Test for Base 16,32,32hex,32-crockford, 64,64url encoding/decoding, with or without padding
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+program testbasenenc;
+
+uses sysutils, basenenc;
+
+
+Procedure AssertEquals(Const aActual,aExpected : TBytes; aMsg : String);
+
+  function ToStr(aBytes : TBytes) : string;
+
+  Var
+    I : Integer;
+
+  begin
+    Result:='';
+    For I:=0 to Length(aBytes) do
+      begin
+      if I>0 then
+        Result:=Result+',';
+      Result:=Result+IntToStr(aBytes[i]);
+      end;
+    Result:='['+Result+']';
+  end;
+
+begin
+  if (Length(aActual)<>Length(aExpected))
+     or Not CompareMem(PByte(aActual),PByte(aExpected),Length(aActual)) then
+    begin
+    Writeln(aMsg,': results differ, actual: "',ToStr(aActual),'" <> "',ToStr(aExpected),'" (expected)');
+    Halt(1);
+    end;
+end;
+
+Procedure AssertEquals(Const aActual,aExpected,aMsg : String);
+
+begin
+  if aActual<>aExpected then
+    begin
+    Writeln(aMsg,': results differ, actual: "',aActual,'" <> "',aExpected,'" (expected)');
+    Halt(1);
+    end;
+end;
+
+Procedure DoTest(B : Tbytes; aExpected : String; aURL : Boolean = False);
+
+Var
+  B2 : TBytes;
+  S : Ansistring;
+
+begin
+  if aURL then
+    S:=Base64URL.Encode(B)
+  else
+    S:=Base64.Encode(B);
+  AssertEquals(S,aExpected,'DoTest Wrong encode');
+  if aURL then
+    B2:=Base64URL.Decode(S)
+  else
+    B2:=Base64.Decode(S);
+  AssertEquals(B2,B,'DoTest Wrong decode');
+end;
+
+Procedure DoTest64(aValue, aExpected : String);
+
+begin
+  DoTest(TEncoding.UTF8.GetAnsiBytes(aValue),aExpected);
+end;
+
+Procedure DoTest32(aValue, aExpected : String);
+
+Var
+  B2 : TBytes;
+  S : Ansistring;
+
+begin
+  S:=Base32.Encode(aValue);
+  AssertEquals(S,aExpected,'base32 encode');
+  B2:=Base32.Decode(S);
+  AssertEquals(b2,TEncoding.UTF8.GetAnsiBytes(aValue),'Base32 Wrong encode for '+aValue);
+end;
+
+Procedure DoTest32Hex(aValue, aExpected : String);
+
+Var
+  B2 : TBytes;
+  S : Ansistring;
+
+begin
+  S:=Base32Hex.Encode(aValue);
+  AssertEquals(S,aExpected,'Base32-hex Wrong encode for '+aValue);
+  B2:=Base32Hex.Decode(S);
+  AssertEquals(B2,TEncoding.UTF8.GetAnsiBytes(aValue),'Base32Hex Wrong encode for '+aValue);
+end;
+
+Procedure DoTest16(aValue, aExpected : String);
+
+Var
+  B2 : TBytes;
+  S : Ansistring;
+
+begin
+  S:=Base16.Encode(aValue);
+  AssertEquals(S,aExpected,'Base16 Wrong encode for '+aValue);
+  B2:=Base16.Decode(S);
+  AssertEquals(B2,TEncoding.UTF8.GetAnsiBytes(aValue),'Base16 Wrong decode for '+aValue);
+end;
+
+
+
+begin
+  // From RFC 3548
+
+  DoTest([$14,$fb,$9c,$03,$d9,$7e],'FPucA9l+');
+  DoTest([$14,$fb,$9c,$03,$d9],'FPucA9k=');
+  DoTest([$14,$fb,$9c,$03],'FPucAw==');
+  DoTest([$14,$fb,$9c,$03,$d9,$7e],'FPucA9l-',True);
+
+  // From RFC 4648
+  DoTest64('','');
+  DoTest64('f','Zg==');
+  DoTest64('fo','Zm8=');
+  DoTest64('foo','Zm9v');
+  DoTest64('foob','Zm9vYg==');
+  DoTest64('fooba','Zm9vYmE=');
+  DoTest64('foobar','Zm9vYmFy');
+
+  DoTest32('','');
+  DoTest32('f','MY======');
+  DoTest32('fo','MZXQ====');
+  DoTest32('foo','MZXW6===');
+  DoTest32('foob','MZXW6YQ=');
+  DoTest32('fooba','MZXW6YTB');
+  DoTest32('foobar','MZXW6YTBOI======');
+
+  DoTest32HEX('','');
+  DoTest32HEX('f','CO======');
+  DoTest32HEX('fo','CPNG====');
+  DoTest32HEX('foo','CPNMU===');
+  DoTest32HEX('foob','CPNMUOG=');
+  DoTest32HEX('fooba','CPNMUOJ1');
+  DoTest32HEX('foobar','CPNMUOJ1E8======');
+
+  DoTest16('','');
+  DoTest16('f','66');
+  DoTest16('fo','666F');
+  DoTest16('foo','666F6F');
+  DoTest16('foob','666F6F62');
+  DoTest16('fooba','666F6F6261');
+  DoTest16('foobar','666F6F626172');
+end.
+