////////////////////////////////////////////////////////////////////////////////
// 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 fast Base64 (Mime) Encoding and Decoding routines.     //
// 1) Lightening fast Base64 (Mime) Encoding and Decoding routines.           //
//    Coded by Ralf Junker (ralfjunker@gmx.de). Modified by Marcel van Brakel.//
//    Then modified by A.K. specially for CRW-DAQ and CRWLIB.                 //
// 2) Binary dump of scalar variables to string and back.                     //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20040807 - Derived to CRW32 from JEDI code library.                        //
// 20201123 - Converted to FPC (A.K.)                                         //
// 20240809 - Dump(var x; …) -> Dump(const x; …)                              //
////////////////////////////////////////////////////////////////////////////////

unit _crw_base64; // Fast Base64 (Mime) Encoding and Decoding routines.

{$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, math, base64,
 _crw_alloc;

 ///////////////////////////////////////////////////////////////////////////////
 // Easy to use mime encoding/decoding routines
 ///////////////////////////////////////////////////////////////////////////////
function  mime_encode(const S:LongString):LongString;{$IFDEF FPC}inline;{$ENDIF}
function  mime_decode(const S:LongString):LongString;{$IFDEF FPC}inline;{$ENDIF}
function  base64_encode(const S:LongString):LongString;
function  base64_decode(const S:LongString):LongString;

const                               // Use standard FPC algorithm,
 UseStdFpcBase64 : Boolean = false; // which over 10 times slower?

 ///////////////////////////////////////////////////////////////////////////////
 // Dump/undump routines to be used with MIME
 // For example:
 //  var x,y:double; i,j:integer; s:string;
 //  s:=mime_encode(dump(x)+dump(y)+dump(i)+dump(j));
 //  s:=mime_decode(s);
 //  x:=dump2r(copy(s,1,8));
 //  y:=dump2r(copy(s,9,8));
 //  i:=dump2i(copy(s,17,4));
 //  j:=dump2i(copy(s,21,4));
 ///////////////////////////////////////////////////////////////////////////////
function dump(const x:Boolean):LongString; overload;
function dump(const x:Char):LongString; overload;
function dump(const x:Byte):LongString; overload;
function dump(const x:Word):LongString; overload;
function dump(const x:SmallInt):LongString; overload;
function dump(const x:LongInt):LongString; overload;
function dump(const x:LongWord):LongString; overload;
function dump(const x:Int64):LongString; overload;
function dump(const x:QWord):LongString; overload;
function dump(const x:Single):LongString; overload;
function dump(const x:Double):LongString; overload;
{$IF SizeOf(Extended)<>SizeOf(Double)}
function dump(const x:Extended):LongString; overload;
{$ENDIF}
function dump(const x; Size:Integer):LongString; overload;
function dump2c(const x:LongString):Char;
function dump2b(const x:LongString):Boolean;
function dump2i(const x:LongString):Integer;
function dump2r(const x:LongString):Double;
function dump2q(const x:LongString):Int64;

 ///////////////////////////////////////////////////////////////////////////////
 // Primary mime encoding/decoding routines
 ///////////////////////////////////////////////////////////////////////////////
function  MimeEncodedSize(const I: Cardinal): Cardinal;
function  MimeDecodedSize(const I: Cardinal): Cardinal;
procedure MimeEncode(var InputBuffer; const InputByteCount: Cardinal; var OutputBuffer);
function  MimeDecode(var InputBuffer; const InputBytesCount: Cardinal; var OutputBuffer): Cardinal;
function  MimeDecodePartial(var InputBuffer; const InputBytesCount: Cardinal;
          var OutputBuffer; var ByteBuffer: Cardinal; var ByteBufferSpace: Cardinal): Cardinal;
function  MimeDecodePartialEnd(var OutputBuffer; const ByteBuffer: Cardinal;
          const ByteBufferSpace: Cardinal): Cardinal;

function test_crw_base64_text:LongString;

implementation

 ///////////////////////////////////////////////////////////////////////////////
 // Mime encodend and decoding implementation
 ///////////////////////////////////////////////////////////////////////////////
function base64_encode(const S:LongString):LongString;
var L,M:Cardinal;
begin
 if UseStdFpcBase64 then begin
  Result:=EncodeStringBase64(S);
  Exit;
 end;
 Result:='';
 L:=Length(S);
 if L > 0 then
 try
  M := MimeEncodedSize(L);
  SetLength(Result, M);
  if Length(Result) <> Integer(M)
  then RAISE EOutOfMemory.Create('base64_encode: Out of memory.');
  MimeEncode(PChar(S)^, L, PChar(Result)^)
 except
  on E:Exception do begin
   BugReport(E,nil,'base64_encode');
   Result:='';
  end;
 end;
end;

function base64_decode(const S:LongString):LongString;
var ByteBuffer,ByteBufferSpace,L,M:Cardinal;
begin
 if UseStdFpcBase64 then begin
  Result:=DecodeStringBase64(S);
  Exit;
 end;
 Result:='';
 L:=Length(S);
 if L > 0 then
 try
  M := MimeDecodedSize(L);
  SetLength(Result, M);
  if Length(Result) <> Integer(M)
  then RAISE EOutOfMemory.Create('base64_decode: Out of memory.');
  ByteBuffer := 0;
  ByteBufferSpace := 4;
  L := MimeDecodePartial(PChar(S)^, L, PChar(Result)^, ByteBuffer, ByteBufferSpace);
  Inc(L, MimeDecodePartialEnd((PChar(Result) + L)^, ByteBuffer, ByteBufferSpace));
  SetLength(Result, L);
  if Length(Result) <> Integer(L)
  then RAISE EOutOfMemory.Create('base64_decode: Out of memory.');
 except
  on E:Exception do begin
   BugReport(E,nil,'base64_decode');
   Result:='';
  end;
 end;
end;

function mime_encode(const S:LongString):LongString;
begin
 Result:=base64_encode(S);
end;

function mime_decode(const S:LongString):LongString;
begin
 Result:=base64_decode(S);
end;

 ///////////////////////////////////////////////////////////////////////////////
 // Dump / undump functions implementation
 ///////////////////////////////////////////////////////////////////////////////

function dump(const x:Boolean):LongString; overload;
begin
 SetString(Result,PChar(@x),sizeof(x));
end;

function dump(const x:Char):LongString; overload;
begin
 SetString(Result,PChar(@x),sizeof(x));
end;

function dump(const x:Byte):LongString; overload;
begin
 SetString(Result,PChar(@x),sizeof(x));
end;

function dump(const x:Word):LongString; overload;
begin
 SetString(Result,PChar(@x),sizeof(x));
end;

function dump(const x:SmallInt):LongString; overload;
begin
 SetString(Result,PChar(@x),sizeof(x));
end;

function dump(const x:LongInt):LongString; overload;
begin
 SetString(Result,PChar(@x),sizeof(x));
end;

function dump(const x:LongWord):LongString; overload;
begin
 SetString(Result,PChar(@x),sizeof(x));
end;

function dump(const x:Int64):LongString; overload;
begin
 SetString(Result,PChar(@x),sizeof(x));
end;

function dump(const x:QWord):LongString; overload;
begin
 SetString(Result,PChar(@x),sizeof(x));
end;

function dump(const x:Single):LongString; overload;
begin
 SetString(Result,PChar(@x),sizeof(x));
end;

function dump(const x:Double):LongString; overload;
begin
 SetString(Result,PChar(@x),sizeof(x));
end;

{$IF SizeOf(Extended)<>SizeOf(Double)}
function dump(const x:Extended):LongString; overload;
begin
 SetString(Result,PChar(@x),sizeof(x));
end;
{$ENDIF}

function dump(const x; Size:Integer):LongString; overload;
begin
 SetString(Result,PChar(@x),Size);
end;

function dump2b(const x:LongString):Boolean;
begin
 Result:=false;
 SafeMove(x[1],Result,min(sizeof(Result),Length(x)));
end;

function dump2c(const x:LongString):Char;
begin
 Result:=#0;
 SafeMove(x[1],Result,min(sizeof(Result),Length(x)));
end;

function dump2i(const x:LongString):Integer;
begin
 Result:=0;
 SafeMove(x[1],Result,min(sizeof(Result),Length(x)));
end;

function dump2r(const x:LongString):Double;
begin
 Result:=0;
 SafeMove(x[1],Result,min(sizeof(Result),Length(x)));
end;

function dump2q(const x:LongString):Int64;
begin
 Result:=0;
 SafeMove(x[1],Result,min(sizeof(Result),Length(x)));
end;

 ///////////////////////////////////////////////////////////////////////////////
 // Internal MIME coding types and constants
 ///////////////////////////////////////////////////////////////////////////////
type
 PByte  = ^Byte;
 PByte3 = ^TByte3;
 PByte4 = ^TByte4;
 TByte3 = packed record B1, B2, B3: Byte;  end;
 TByte4 = packed record B1, B2, B3, B4: Byte; end;
const
 EqualSign = Byte('=');
 MIME_ENCODE_TABLE: array [0..63] of Byte = (
     65,  66,  67,  68,  69,  70,  71,  72,  // 00 - 07
     73,  74,  75,  76,  77,  78,  79,  80,  // 08 - 15
     81,  82,  83,  84,  85,  86,  87,  88,  // 16 - 23
     89,  90,  97,  98,  99, 100, 101, 102,  // 24 - 31
    103, 104, 105, 106, 107, 108, 109, 110,  // 32 - 39
    111, 112, 113, 114, 115, 116, 117, 118,  // 40 - 47
    119, 120, 121, 122,  48,  49,  50,  51,  // 48 - 55
     52,  53,  54,  55,  56,  57,  43,  47); // 56 - 63
 MIME_DECODE_TABLE: array [Byte] of Cardinal = (
    255, 255, 255, 255, 255, 255, 255, 255, //  00 -  07
    255, 255, 255, 255, 255, 255, 255, 255, //  08 -  15
    255, 255, 255, 255, 255, 255, 255, 255, //  16 -  23
    255, 255, 255, 255, 255, 255, 255, 255, //  24 -  31
    255, 255, 255, 255, 255, 255, 255, 255, //  32 -  39
    255, 255, 255,  62, 255, 255, 255,  63, //  40 -  47
     52,  53,  54,  55,  56,  57,  58,  59, //  48 -  55
     60,  61, 255, 255, 255, 255, 255, 255, //  56 -  63
    255,   0,   1,   2,   3,   4,   5,   6, //  64 -  71
      7,   8,   9,  10,  11,  12,  13,  14, //  72 -  79
     15,  16,  17,  18,  19,  20,  21,  22, //  80 -  87
     23,  24,  25, 255, 255, 255, 255, 255, //  88 -  95
    255,  26,  27,  28,  29,  30,  31,  32, //  96 - 103
     33,  34,  35,  36,  37,  38,  39,  40, // 104 - 111
     41,  42,  43,  44,  45,  46,  47,  48, // 112 - 119
     49,  50,  51, 255, 255, 255, 255, 255, // 120 - 127
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255);

 ///////////////////////////////////////////////////////////////////////////////
 // Primary MIME coding functions
 ///////////////////////////////////////////////////////////////////////////////
function MimeEncodedSize(const I: Cardinal): Cardinal;
begin
 Result := (I + 2) div 3 * 4;
end;

function MimeDecodedSize(const I: Cardinal): Cardinal;
begin
 Result := (I + 3) div 4 * 3;
end;

procedure MimeEncode(var InputBuffer; const InputByteCount: Cardinal; var OutputBuffer);
var B,InMax3:Cardinal; InPtr,InLimitPtr:PByte; OutPtr:PByte4;
begin
 if InputByteCount > 0 then begin
  InPtr := @InputBuffer;
  InMax3 := InputByteCount div 3 * 3;
  OutPTr := @OutputBuffer;
  PChar(InLimitPtr) := PChar(InPtr) + InMax3;
  while InPtr <> InLimitPtr do begin
   B := InPtr^;
   B := B shl 8;
   Inc(InPtr);
   B := B or InPtr^;
   B := B shl 8;
   Inc(InPtr);
   B := B or InPtr^;
   Inc(InPtr);
   // Write 4 bytes to OutputBuffer (in reverse order).
   OutPtr.B4 := MIME_ENCODE_TABLE[B and $3F];
   B := B shr 6;
   OutPtr.B3 := MIME_ENCODE_TABLE[B and $3F];
   B := B shr 6;
   OutPtr.B2 := MIME_ENCODE_TABLE[B and $3F];
   B := B shr 6;
   OutPtr.B1 := MIME_ENCODE_TABLE[B];
   Inc(OutPtr);
  end;
  case InputByteCount - InMax3 of
   1: begin
       B := InPtr^;
       B := B shl 4;
       OutPtr.B2 := MIME_ENCODE_TABLE[B and $3F];
       B := B shr 6;
       OutPtr.B1 := MIME_ENCODE_TABLE[B];
       OutPtr.B3 := EqualSign; // Fill remaining 2 bytes.
       OutPtr.B4 := EqualSign;
      end;
   2: begin
       B := InPtr^;
       Inc(InPtr);
       B := B shl 8;
       B := B or InPtr^;
       B := B shl 2;
       OutPtr.B3 := MIME_ENCODE_TABLE[B and $3F];
       B := B shr 6;
       OutPTr.b2 := MIME_ENCODE_TABLE[B and $3F];
       B := B shr 6;
       OutPtr.B1 := MIME_ENCODE_TABLE[B];
       OutPtr.B4 := EqualSign; // Fill remaining byte.
      end;
  end;
 end;
end;

function MimeDecode(var InputBuffer; const InputBytesCount: Cardinal; var OutputBuffer): Cardinal;
var ByteBuffer, ByteBufferSpace: Cardinal;
begin
 ByteBuffer := 0;
 ByteBufferSpace := 4;
 Result := MimeDecodePartial(InputBuffer, InputBytesCount, OutputBuffer, ByteBuffer, ByteBufferSpace);
 Inc(Result, MimeDecodePartialEnd((PChar(OutputBuffer) + Result)^, ByteBuffer, ByteBufferSpace));
end;

function MimeDecodePartial(var InputBuffer; const InputBytesCount: Cardinal;
  var OutputBuffer; var ByteBuffer: Cardinal; var ByteBufferSpace: Cardinal): Cardinal;
var lByteBuffer,lByteBufferSpace,C:Cardinal; InPtr,InLimitPtr:PByte; OutPtr:PByte3;
begin
 if InputBytesCount > 0 then begin
  InPtr := @InputBuffer;
  PChar(InLimitPtr) := PChar(InPtr) + InputBytesCount;
  OutPtr := @OutputBuffer;
  lByteBuffer := ByteBuffer;
  lByteBufferSpace := ByteBufferSpace;
  while InPtr <> InLimitPtr do begin
   C := MIME_DECODE_TABLE[InPtr^];         // Read from InputBuffer.
   Inc(InPtr);
   if C = $FF then Continue;               // Pass all non-printable chars
   lByteBuffer := lByteBuffer shl 6;
   lByteBuffer := lByteBuffer or C;
   Dec(lByteBufferSpace);
   if lByteBufferSpace <> 0 then Continue; // Read 4 bytes from InputBuffer?
   OutPtr.B3 := Byte(lByteBuffer);         // Write 3 bytes to OutputBuffer (in reverse order).
   lByteBuffer := lByteBuffer shr 8;
   OutPtr.B2 := Byte(lByteBuffer);
   lByteBuffer := lByteBuffer shr 8;
   OutPtr.B1 := Byte(lByteBuffer);
   lByteBuffer := 0;
   Inc(OutPtr);
   lByteBufferSpace := 4;
  end;
  ByteBuffer := lByteBuffer;
  ByteBufferSpace := lByteBufferSpace;
  Result := SubtractPointersAsPtrUInt(OutPtr,@OutputBuffer);
 end else Result := 0;
end;

function MimeDecodePartialEnd(var OutputBuffer; const ByteBuffer: Cardinal;
  const ByteBufferSpace: Cardinal): Cardinal;
var lByteBuffer:Cardinal;
begin
 case ByteBufferSpace of
  1: begin
      lByteBuffer := ByteBuffer shr 2;
      PByte3(@OutputBuffer).B2 := Byte(lByteBuffer);
      lByteBuffer := lByteBuffer shr 8;
      PByte3(@OutputBuffer).B1 := Byte(lByteBuffer);
      Result := 2;
     end;
  2: begin
      lByteBuffer := ByteBuffer shr 4;
      PByte3(@OutputBuffer).B1 := Byte(lByteBuffer);
      Result := 1;
     end;
  else Result := 0;
 end;
end;

function test_crw_base64_text:LongString;
var a,b:LongString; i,j,len,n,m,nm:Integer;
var List:TStringList; ms:QWord; tpc,tps:Double;
begin
 Result:='';
 try
  List:=TStringList.Create;
  try
   List.Add('test_crw_base64:');
   a:=''; b:=''; n:=0; m:=0;
   nm:=100000;
   for i:=0 to nm-1 do begin
    len:=1+random(160);
    SetLength(a,len);
    for j:=1 to length(a) do a[j]:=Chr(random(256));
    b:=mime_encode(a);
    if a=mime_decode(b) then inc(n) else inc(m);
    if i mod 10000 = 0 then List.Add('b='+Copy(b,1,128));
    if i mod 10000 = 0 then begin
     if mime_encode(a)<>EncodeStringBase64(a) then inc(m);
     if mime_decode(b)<>DecodeStringBase64(b) then inc(m);
    end;
   end;
   List.Add('Success='+IntToStr(n)+', Error='+IntToStr(m));
   n:=0; m:=0;
   a:='This is test string for base64_encode/decode performance measure.';
   ms:=GetTickCount64;
   for i:=0 to nm-1 do begin
    b:=mime_decode(mime_encode(a));
    inc(n);
   end;
   if (b<>a) then inc(m);
   List.Add('Success='+IntToStr(n)+', Error='+IntToStr(m));
   ms:=GetTickCount64-ms; tpc:=(ms*1e6/nm); tps:=tpc/length(a);
   List.Add(Format('base64_encode/decode takes %.5g ns/call, %.5g ns/char',[tpc,tps]));
   a:=''; b:='';
   Result:=List.Text;
  finally
   Kill(List);
  end;
 except
  on E:Exception do BugReport(E,nil,'test_crw_base64_text');
 end;
end;

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

procedure Init_crw_base64;
begin
end;

procedure Free_crw_base64;
begin
end;

initialization

 Init_crw_base64;

finalization

 Free_crw_base64;

end.

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

