 {
 ****************************************************************************
 CRW32 project
 Copyright (C) by Kuryakin Alexey, Sarov, Russia, 2004, <kouriakine@mail.ru>
 1) Lightening fast Mime (Base64) Encoding and Decoding routines.
    Coded by Ralf Junker (ralfjunker@gmx.de). Modified by Marcel van Brakel.
 2) Binary dump of scalar variables to string and back.
 Modifications:
 20040807 - Derived to CRW32 from JEDI code library.
 ****************************************************************************
 }
unit _mime;

{$I _sysdef}

interface

uses Windows, SysUtils, Math, _alloc;

 ///////////////////////////////////////////////////////////////////////////////
 // Easy to use mime encoding/decoding routines
 ///////////////////////////////////////////////////////////////////////////////
function  mime_encode(const S:LongString):LongString;
function  mime_decode(const S:LongString):LongString;

 ///////////////////////////////////////////////////////////////////////////////
 // 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:Char):LongString; overload;
function dump(const x:Boolean):LongString; overload;
function dump(const x:Integer):LongString; overload;
function dump(const x:Double):LongString; overload;
function dump(var 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;

 ///////////////////////////////////////////////////////////////////////////////
 // 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;

{$IFDEF Poligon}
procedure Test_Mime;
{$ENDIF Poligon}

implementation

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

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

 ///////////////////////////////////////////////////////////////////////////////
 // Dump / undump functions implementation
 ///////////////////////////////////////////////////////////////////////////////
function dump(const x:Char):LongString; overload;
begin
 SetString(Result,PChar(@x),sizeof(x));
end;

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

function dump(const x:Integer):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;

function dump(var 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;

 ///////////////////////////////////////////////////////////////////////////////
 // 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;
  Cardinal(InLimitPtr) := Cardinal(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(Cardinal(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;
  Cardinal(InLimitPtr) := Cardinal(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 := Cardinal(OutPtr) - Cardinal(@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;

{$IFDEF Poligon}
procedure Test_Mime;
var a,b:LongString; i,j,len,n,m:Integer;
begin
 a:='';
 b:='';
 n:=0;
 m:=0;
 for i:=0 to 1000000 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 writeln('b=',Copy(b,1,128));
 end;
 writeln('Success=',n,',Error=',m);
 a:='';
 b:='';
end;
{$ENDIF Poligon}

end.
