Solved

Base64 Encode/Decode UTF8 Delphi 2010

Posted on 2010-09-03
10
2 solutions
10,234 Views
Last Modified: 2012-05-10
Hello,

I have a Unit where in Delphi 2007 i was able to encode/decode strings being compatible with the PHP version of Base64...

So, a String base64 encoded in PHP, i was able to decode it in my Delphi app..

Now using Delphi 2010, i wanna make it compatible... but i really don't have idea where is the problem... when i try to encode a text, it comes like "Chinese Characters"... i can change all Strings from the Unit to AnsiString but then i don't have a base64 support for Unicode!

Attached is the Unit... somebody know how to make it compatible with Unicode?

I don't have enough knowledge to change things in this unit where will be able to support unicode... in the official website, it's just abandoned and since 2003 there is no updates!
but i know that its possible, since there are a lot of examples over the web but in .NET or javascript, C# not in Delphi :(

To test the unit, is something like

Example, 2 Edits over the form and 1 button

OnButton Click
Edit2.Text := SZFullEncodeBase64(Edit1.Text);

Best Regards,
Carlos SZCodeBaseX.pas
0
Comment
Question by:cebasso
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
Join The Community
  • 4
  • 4
  • 2
10 Comments
 
LVL 13

Expert Comment

by:aflarin
ID: 33596530
it seems the unit suppose that string is AnsiString, but in D2010 string is WideString.

so, I think you have to change all string types into unit to AnsiString

or maybe there is a compiler directive for that?

0
 
LVL 13

Expert Comment

by:aflarin
ID: 33596580
also you have to change PChar to PAnsiChar

try the attached unit. I've done these changes and checked it on your sample. 
{$O+} // Optimization must be ON
{$R-} // Range checking must be OFF

unit SZCodeBaseX;

/////////////////////////////
// Version 1.3.5
////////////////////////////

{

 The contents of this file are subject to the Mozilla Public License
 Version 1.1 (the "License"); you may not use this file except in compliance
 with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL/

 Software distributed under the License is distributed on an "AS IS" basis,
 WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the
 specific language governing rights and limitations under the License.

 The original code is SZCodeBaseX.pas, released 15. July, 2004.

 The initial developer of the original code is
 Sasa Zeman (public@szutils.net, www.szutils.net)

 Copyright(C) 2004-2007 Sasa Zeman. All Rights Reserved.
}

{--------------------------------------------------------------------

Encode/Decode algorithms for Base16, Base32 and Base64
Reference: RFC 3548

- Universal Encode/Decode algorithms for Base16, Base32 and Base64
- Standard Base16, Base32 and Base64 encoding/decoding functions
- Reference: RFC 3548, full compatibility
- Full MIME suppport
- Supported work with Memory, Stream, String and Files
- Optionally supported work with padding keys (required numbers
  of '=' at the end of the encoded array)
- Very flexible work - you may easily create your own Encode/Decode functions
  based on your own specific codes, from Base2 up to Base128

----------------------------------
Revision History:
----------------------------------

-------------------------
Version 1.3.5, 2007-07-02
-------------------------
  - Bugfix on SZCodeBaseXSetBufferSize;

-------------------------
Version 1.3.4, 2007-03-10
-------------------------
  - Cleaning some useless code
  - Some minor code tweaks
  - Demo update

-------------------------
Version 1.3.3, 2006-12-10
-------------------------
  - Better demo
  - Some minor code reorganization

-------------------------
Version 1.3.2, 2005-07-09
-------------------------
  - Added external functions to calculate Required Output Memory
    Thanks to Grant.

-------------------------
Version 1.3.1, 2005-06-18
-------------------------
  - fixed runtime error in decoding when range checking is ON.
    Thanks to Grant.

-------------------------
Version 1.3.0, 2005-05-03
-------------------------
  - Added MIME support

-------------------------
Version 1.2.1, 2004-11-19
-------------------------
  - Added support for Memory, Stream and Files
  - Added support for Delphi 5 and BCB - pByte issue

-------------------------
Version 1.1.0, 2004-08-21
-------------------------
  - Optimized version, more than 35 times speed acceleration,
    one of the fastest and the simplest universal Base16/32/64 encoder/decoder

-------------------------
Version 1.0.0, 2004-07-15
-------------------------
  - Initial version

----------------------------------

  Author   : Sasa Zeman
  E-mail   : public@szutils.net or sasaz72@mail.ru
  Web site : www.szutils.net
}

interface

uses Windows, SysUtils, Types, Classes;

//////////////////////////////////////////////////////////////////
// Universal Encode/Decode algorithms for Base16, Base32 and Base64
// Actualy, you can create any variation you need, even by your own
// codes from Base2 to Base128
//////////////////////////////////////////////////////////////////

const
  SZCodeBaseXver='1.3.5';

function SZEncodeBaseXMemory( pIN, pOUT: pByte; Size: integer; const Codes: AnsiString; BITS: integer; FullQuantum : integer; MIMELine: integer): integer;
function SZDecodeBaseXMemory( pIN, pOUT: pByte; Size: integer; const Codes: AnsiString; BITS: integer): integer;

function SZEncodeBaseXStream(sIN, sOUT: TStream; Size: integer; const Codes: AnsiString; BITS: integer; FullQuantum : integer; MIMELine: integer ): integer;
function SZDecodeBaseXStream(sIN, sOUT: TStream; const Codes: AnsiString; BITS: integer): integer;

function SZEncodeBaseXString(const S: AnsiString; const Codes: AnsiString; BITS: integer; FullQuantum : integer; MIMELine: integer): AnsiString;
function SZDecodeBaseXString(const S: AnsiString; const Codes: AnsiString; BITS: integer): AnsiString;

function SZEncodeBaseXFile(const FileName: AnsiString; sOUT: TStream; const Codes: AnsiString; BITS: integer; FullQuantum : integer; MIMELine: integer): integer;
// Decoding entire file is not supported, as is not logical - file may
// contain any data, or more than one encoded data
// Use the stream realization for precise and logical decoding - even
// for a part of a stream (fully supported)


//////////////////////////////////////////////////////////////////
// Calculates full reqired memory for output
// based on input size, BITS and needs for padding keys
//////////////////////////////////////////////////////////////////

function SZCalcRequireOutputMemory(TotalIn: integer; BITS, FullQuantum: integer; MIMELine: integer): integer;

// Calculates reqired ammount of padding keys based on output size
function SZCalcRequiredPaddingKeys(Size, FullQuantum: integer):Integer;

//////////////////////////////////////////////////////////////////
// ATTENTION!!!
// Next two functions are for testing purposes only.
// My be deleted in the future.
////////////////////////////////////////////////////////////////////
function SZFullEncodeOnlyBase64(const S: AnsiString; MIMELine: integer = 0): AnsiString;
function SZFullEncodeOnlyBase64_6(const S: AnsiString; MIMELine: integer = 0): AnsiString;

////////////////////////////////////////////////////////////////////
// Base 16
//////////////////////////////////////////////////////////////////

function SZEncodeBase16(pIN, pOUT: PByte; Size: integer; MIMELine: integer = 0): integer; overload;
function SZEncodeBase16(sIN, sOUT: TStream; Size: integer=-1; MIMELine: integer = 0): integer; overload;
function SZEncodeBase16(const S: AnsiString; MIMELine: integer = 0): AnsiString; overload;
function SZEncodeBase16(const FileName: AnsiString; sOUT: TStream; MIMELine: integer = 0): integer; overload;

function SZDecodeBase16(pIN, pOUT: PByte; Size: integer): integer; overload;
function SZDecodeBase16(sIN, sOUT: TStream): integer; overload;
function SZDecodeBase16(const S: AnsiString): AnsiString; overload;

//////////////////////////////////////////////////////////////////
// Base32, Full encoding mean adding padding keys
//////////////////////////////////////////////////////////////////

function SZFullEncodeBase32(pIN, pOUT: PByte; Size: integer; MIMELine: integer = 0): integer; overload;
function SZFullEncodeBase32(sIN, sOUT: TStream; Size: integer=-1; MIMELine: integer = 0): integer; overload;
function SZFullEncodeBase32(const S: AnsiString; MIMELine: integer = 0): AnsiString; overload;
function SZFullEncodeBase32(const FileName: AnsiString; sOUT: TStream; MIMELine: integer = 0): integer; overload;

function SZEncodeBase32(pIN, pOUT: PByte; Size: integer; MIMELine: integer = 0): integer; overload;
function SZEncodeBase32(sIN, sOUT: TStream; Size: integer=-1; MIMELine: integer = 0): integer; overload;
function SZEncodeBase32(const S: AnsiString; MIMELine: integer = 0): AnsiString; overload;
function SZEncodeBase32(const FileName: AnsiString; sOUT: TStream; MIMELine: integer = 0): integer; overload;

function SZDecodeBase32(pIN, pOUT: PByte; Size: integer): integer; overload;
function SZDecodeBase32(sIN, sOUT: TStream): integer; overload;
function SZDecodeBase32(const S: AnsiString): AnsiString; overload;

//////////////////////////////////////////////////////////////////
// Base 64, Full encoding mean adding padding keys
//////////////////////////////////////////////////////////////////

function SZFullEncodeBase64(pIN, pOUT: PByte; Size: integer; MIMELine: integer = 0): integer; overload;
function SZFullEncodeBase64(sIN, sOUT: TStream; Size: integer=-1; MIMELine: integer = 0): integer; overload;
function SZFullEncodeBase64(const S: AnsiString; MIMELine: integer = 0): AnsiString; overload;
function SZFullEncodeBase64(const FileName: AnsiString; sOUT: TStream; MIMELine: integer = 0): integer; overload;

function SZEncodeBase64(pIN, pOUT: PByte; Size: integer; MIMELine: integer = 0): integer; overload;
function SZEncodeBase64(sIN, sOUT: TStream; Size: integer=-1; MIMELine: integer = 0): integer; overload;
function SZEncodeBase64(const S: AnsiString; MIMELine: integer = 0): AnsiString; overload;
function SZEncodeBase64(const FileName: AnsiString; sOUT: TStream; MIMELine: integer = 0): integer; overload;

function SZDecodeBase64(pIN, pOUT: PByte; Size: integer): integer; overload;
function SZDecodeBase64(sIN, sOUT: TStream): integer; overload;
function SZDecodeBase64(const S: AnsiString): AnsiString; overload;

//////////////////////////////////////////////////////////////////
// Base64 URL, Full encoding mean adding padding keys
//////////////////////////////////////////////////////////////////

function SZFullEncodeBase64URL(pIN, pOUT: PByte; Size: integer; MIMELine: integer = 0): integer; overload;
function SZFullEncodeBase64URL(sIN, sOUT: TStream; Size: integer=-1; MIMELine: integer = 0): integer; overload;
function SZFullEncodeBase64URL(const S: AnsiString; MIMELine: integer = 0): AnsiString; overload;
function SZFullEncodeBase64URL(const FileName: AnsiString; sOUT: TStream; MIMELine: integer = 0): integer; overload;

function SZEncodeBase64URL(pIN, pOUT: PByte; Size: integer; MIMELine: integer = 0): integer; overload;
function SZEncodeBase64URL(sIN, sOUT: TStream; Size: integer=-1; MIMELine: integer = 0): integer; overload;
function SZEncodeBase64URL(const S: AnsiString; MIMELine: integer = 0): AnsiString; overload;
function SZEncodeBase64URL(const FileName: AnsiString; sOUT: TStream; MIMELine: integer = 0): integer; overload;

function SZDecodeBase64URL(pIN, pOUT: PByte; Size: integer): integer; overload;
function SZDecodeBase64URL(sIN, sOUT: TStream): integer; overload;
function SZDecodeBase64URL(const S: AnsiString): AnsiString; overload;


//////////////////////////////////////////////////////////////////
// Calculating Required Output Memory
//////////////////////////////////////////////////////////////////

function SZCalcRequiredOutputMemoryForFullEncodeBase64(Size: integer; MIMELine: integer=0): integer;
function SZCalcRequiredOutputMemoryForFullEncodeBase32(Size: integer; MIMELine: integer=0): integer;

function SZCalcRequiredOutputMemoryForEncodeBase64(Size: integer; MIMELine: integer=0): integer;
function SZCalcRequiredOutputMemoryForEncodeBase32(Size: integer; MIMELine: integer=0): integer;

function SZCalcRequiredOutputMemoryForEncodeBase16(Size: integer; MIMELine: integer=0): integer;

//////////////////////////////////////////////////////////////////
// Setting Buffer Size procedure
//////////////////////////////////////////////////////////////////

procedure SZCodeBaseXSetBufferSize(Size:integer);
procedure SZCodeBaseXSetOrigBufferSize;

//////////////////////////////////////////////////////////////////

implementation

const

  // Basic size for buffer is 64KB
  SZORIGBUFFSIZE = 64*1024;

///////////////////////////////////////////
/// Base 64 definitions
///////////////////////////////////////////

  SZCodes64    = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
  SZCodes64URL = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_';
  SZBITS64 = 6;

  // Resulted number of chars must be integral multiple of
  // 24 input bits div 6 output group bits
  SZFullQuantum64 = 24 div 6;

///////////////////////////////////////////

///////////////////////////////////////////
/// Base 32 definitions
///////////////////////////////////////////

  SZCodes32 = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ234567';
  SZBITS32 = 5;

  // Resulted number of chars must be integral multiple of
  // 40 input bits div 5 output group bits
  SZFullQuantum32 = 40 div 5;

  // If there is no need for padding keys
  SZFullQuantum0 = 0;

///////////////////////////////////////////
/// Base 16 definitions
///////////////////////////////////////////

  SZCodes16 = '0123456789ABCDEF';
  SZBITS16 = 4;

///////////////////////////////////////////

type
  TFastDecodeTable=array[0..255] of byte;

var
  // Optimized buffer length for encoding files up to 64KB
  // Important for speed-up works with large streams

  SZBUFFSIZE: integer;

  SZFastDecodeTable: TFastDecodeTable;

////////////////////////////
// Basic Functions
////////////////////////////

procedure SZUpdateFastDecodeTable(const Codes: AnsiString);
var
  i: integer;
begin
  FillChar(SZFastDecodeTable,256,#0);

  for i := 1 to length(Codes) do
    SZFastDecodeTable[ byte( Codes[i] ) ] := i;
end;

function SZCalcRequiredPaddingKeys(Size, FullQuantum: integer):Integer;
{
  Adding necessary padding keys to create a full
  RFC 3548 compatibility string
}
var
  IM: integer;
begin

  if FullQuantum>0 then
    IM:=Size mod FullQuantum
  else
    IM:=0;

  if IM>0 then
    Result:=FullQuantum-IM
  else
    Result:=0
end;

function SZCalcRequireOutputMemory(TotalIn: integer; BITS, FullQuantum: integer; MIMELine: integer): integer;
var
  TotalOut, IM, MIMEOut: integer;
begin

  TotalOut := TotalIn shl 3; // * 8

  if TotalOut mod BITS > 0 then
    TotalOut:= TotalOut div BITS +1
  else
    TotalOut:= TotalOut div BITS;

  if MIMELine>0 then
    MIMEOut:= ( (TotalOut-1) div (MIMELine) ) shl 1 // * 2
  else
    MIMEOut:= 0;

  if FullQuantum>0 then
  begin
    IM:=TotalOut mod FullQuantum;

    if IM>0 then
      TotalOut:= TotalOut + FullQuantum-IM;
  end;

  // Additional space for CRLF (2 bytes) if MIME encoding is required
  if MIMELine>0 then
    TotalOut:= TotalOut + MIMEOut;

  result:=TotalOut;
end;


procedure GetRelevantData(TotalIn: integer; var TotalOut: integer;
        BITS, FullQuantum: integer; var IM: integer; MIMELine: integer);
var
  MIMEOut: integer;
begin

  TotalOut:=TotalIn shl 3; // * 8

  if TotalOut mod BITS > 0 then
    TotalOut:= TotalOut div BITS +1
  else
    TotalOut:= TotalOut div BITS;

  if MIMELine>0 then
    MIMEOut:= ( (TotalOut-1) div (MIMELine) ) shl 1 // * 2
  else
    MIMEOut:=0;

  if FullQuantum>0 then
  begin
    IM:=TotalOut mod FullQuantum;

    if IM>0 then
      TotalOut:= TotalOut + FullQuantum-IM;
  end
  else
    IM:=0;

  // Additional space for CRLF (2 bytes) if MIME encoding is required
  if MIMELine>0 then
    TotalOut:= TotalOut + MIMEOut
end;


////////////////////////////
// Memory
////////////////////////////

function SZEncodeBaseXMemoryUpdate(pIN: PByte; var pOUT: PByte; Size: integer; const Codes: AnsiString; BITS: integer; var vB8, VI8: integer; MIMELine: integer; Var MIMECountdown, MIMEBytesCount: integer): integer;
{
  Universal Encode algorithm for Base16, Base32 and Base64
  Reference: RFC 3548
  RFC incompatibility: No padding keys
}

const Mask: array [0..16] of Word=
(  0, 1, 3, 7, 15, 31, 63,
   127,   255,  511,  1023,   2047,
  4095,  8191, 16383, 32767, 65535
);

var
  i,B8, I8, Count: integer;
  MIME: Boolean;
begin

  MIME:=MIMELine > 0;

  Count:=0;

  B8 := vB8;
  I8 := vI8;

  for i := 1 to Size do
  begin
    B8 := B8 shl 8;
    B8 := B8 or pIN^;
    I8 := I8 + 8;

    while I8 >= BITS do
    begin

      I8 := (I8 - BITS);

      // Get first BITS of bits
      PAnsiChar(pOUT)^ := Codes[(B8 shr I8)+1];
      inc(pOUT);

      inc(Count);

      if MIME then
      begin

        MIMECountdown := MIMECountdown - 1;

        if MIMECountdown <= 0 then
        begin
           MIMECountdown := MIMELine;
           MIMEBytesCount := MIMEBytesCount + 2;

           // Put CRLF
           pOUT^ := 13; inc(pOUT);
           pOUT^ := 10; inc(pOUT);

           inc(Count,2);

        end;

      end;

      //Return position back for BITS bits
      //B8 := B8 - ((B8 shr I8) shl I8);

      // The same result as upper code, a bit faster
      B8 := B8 and MASK[I8];

    end;

    inc(pIN);

  end;

  vB8 := B8;
  vI8 := I8;

  result:=Count;
end;
                 
function SZEncodeBaseXMemoryFinalyze(var pOUT: PByte; const Codes: AnsiString; BITS: integer; B8, I8: integer): integer;
// Finalyzing encoding with last left bites (if any)
begin
  // If something left
  if I8 > 0 then
  begin
    PAnsiChar(pOUT)^ := Codes[ (B8 shl (BITS-I8)) + 1];
    inc(pOUT);
    result:=1;
  end else
    result:=0;
end;

function SZEncodeBaseXMemory(pIN, pOUT: pByte; Size: integer; const Codes: AnsiString; BITS: integer; FullQuantum : integer; MIMELine : integer): integer;
var
  B8,I8: integer;

  TotalOut : integer;
  IM       : integer;

  MIMECountdown  : integer;
  MIMEBytesCount : integer;

  ppIN, ppOUT: pByte;
begin
  B8:=0;
  I8:=0;

  ppIN  := pIN;
  ppOUT := pOut;

  MIMECountdown  := MIMELine;
  MIMEBytesCount := 0;

  TotalOut:=SZEncodeBaseXMemoryUpdate(ppIN, ppOUT, Size, Codes, BITS, B8, I8, MIMELine, MIMECountdown, MIMEBytesCount);

  // If something left
  if I8>0 then
    TotalOut:=TotalOut+
      SZEncodeBaseXMemoryFinalyze(ppOut, Codes, BITS, B8, I8);

  if FullQuantum>0 then
  begin

    // Calculate relevant data
    //GetRelevantData(TotalIn, TotalOut, BITS, FullQuantum, IM);

    // Get required padding keys
    IM:=SZCalcRequiredPaddingKeys(TotalOut - MIMEBytesCount, FullQuantum);

    if IM>0 then
    begin
      FillChar( ppOUT^, IM,'=');
      PAnsiChar(ppOut):=PAnsiChar(ppOut)+IM;

      TotalOut:=TotalOut + IM
    end
  end;

  result:=TotalOut;
end;


function SZDecodeBaseXMemoryUpdate(pIN,pOUT: pByte; Size: integer; const FastDecodeTable: TFastDecodeTable; BITS: integer; var B8, I8 : integer): integer;
{
  Universal Decode algorithm for Base16, Base32 and Base64
  Reference: RFC 3548 - full compatibility
}

var
  i: Integer;
  TotalIN, Count: integer;

begin

  TotalIN  := Size;

  // Start decoding
  count := 0;
  for i := 1 to TotalIN do
  begin

    if SZFastDecodeTable[pIN^] > 0 then
    begin

      B8 := B8 shl BITS;
      B8 := B8 or (SZFastDecodeTable[pIN^]-1);

      I8 := I8 + BITS;

      while I8 >= 8 do
      begin
        I8 := I8 - 8;

        pOUT^ := Byte(B8 shr I8);
        inc( pOUT );

        inc(count)
      end;

      inc(pIN);
    end
    else if pIN^=13 then inc(pIN)
    else if pIN^=10 then inc(pIN)
    else
      break
  end;

  result:=Count;
end;

function SZDecodeBaseXMemory(pIN,pOUT: pByte; Size: integer; const Codes: AnsiString; BITS: integer): integer;
{
  Universal Decode algorithm for Base16, Base32 and Base64
  Reference: RFC 3548 - full compatibility
}

var
  B8, I8 : integer;
begin
  B8:=0;
  I8:=0;

  SZUpdateFastDecodeTable(Codes);

  result:=SZDecodeBaseXMemoryUpdate( pIN, pOUT, Size, SZFastDecodeTable, BITS, B8, I8);
end;

function SZDecodeBaseXString(const S: AnsiString; const Codes: AnsiString; BITS: integer): AnsiString;
var
  TotalIn  : integer;
  TotalOut : integer;

  pIN,pOUT: pByte;

begin

  TotalIn  := length(S);
  TotalOut := (TotalIn * BITS) shr 3; // div 8;

  Setlength(Result,TotalOut);

  pIN  := @S[1];
  pOUT := @Result[1];

  TotalOut:=SZDecodeBaseXMemory( pIN, pOUT, TotalIn, Codes, BITS);

  if length(Result)<> TotalOut then
    Setlength(Result,TotalOut);
end;

function SZEncodeBaseXString(const S: AnsiString; const Codes: AnsiString; BITS: integer; FullQuantum : integer ; MIMELine : integer): AnsiString;
// Universal Encode algorithm for Base16, Base32 and Base64
var
  pIN, pOUT: pByte;

  TotalIn, TotalOut: integer;
  IM: integer;
  LOut: integer;
begin
  TotalIn  := length(S);

  // Calculate relevant data
  GetRelevantData(TotalIn, TotalOut, BITS, FullQuantum, IM, MIMELine);

  SetLength(Result,TotalOut);

  pIN :=@S[1];
  pOUT:=@Result[1];

  LOut:=SZEncodeBaseXMemory(pIn,pOut, TotalIn, Codes, BITS, FullQuantum, MIMELine);

  if Lout<>TotalOut then
    SetLength(Result,LOut);
end;

//////////////////////////
// Stream
//////////////////////////

function SZEncodeBaseXStreamUpdate(sIN, sOUT: TStream; Size: integer; const Codes: AnsiString; BITS: integer; var vB8, vI8: integer; MIMELine: integer; Var MIMECountdown, MIMEByteCount: integer): integer;
var
  pBuffIn, pBuffOut: pByte;
  Res,BUFF : Integer;
  pIn,pOut: pByte;
  LOut,Count,TotalIn, TotalOut, MIMEOut: integer;
begin

  BUFF := SZBUFFSIZE;

  TotalIn:=Size;

  if BUFF > TotalIn  then
    BUFF := TotalIn + 1;

  TotalOut := BUFF shl 3; // * 8

  if TotalOut mod BITS > 0 then
    TotalOut := TotalOut div BITS +1
  else
    TotalOut := TotalOut div BITS;

  if MIMELine>0 then
    MIMEOut := ( (TotalOut-1) div (MIMELine) ) shl 1 // * 2
  else
    MIMEOut := 0;

  TotalOut := TotalOut + MIMEOut;

  // Get memory for it
  GetMem(pBuffIn,BUFF);
  GetMem(pBuffOut,TotalOut);

  Count := 0;

  repeat
    Res := sIn.Read(pBuffIn^, BUFF);

    pIn  := pBuffIn;
    pOut := pBuffOut;

    LOut:=SZEncodeBaseXMemoryUpdate(pIn,pOut, Res, Codes, BITS, vB8, vI8, MIMELine, MIMECountdown, MIMEByteCount);
    sOut.Write(pBuffOut^,LOut);

    Count := Count + LOut;

  until (Res <> LongInt(BUFF));

  FreeMem(pBuffIn);
  FreeMem(pBuffOut);

  result:=Count;
end;

function SZEncodeBaseXStreamFinalyze(sOUT: TStream; const Codes: AnsiString; BITS: integer; var B8, I8: integer): integer;
var
  pOut: pByte;
  b: byte;
begin
  pOut:=@b;

  Result:=SZEncodeBaseXMemoryFinalyze(pOUT, Codes, BITS, B8, I8);

  if Result>0 then
    sOut.Write(b,Result);
end;

function SZEncodeBaseXStream(sIN, sOUT: TStream; Size: integer; const Codes: AnsiString; BITS: integer; FullQuantum : integer; MIMELine : integer): integer;
var
  B8, I8: integer;

  TotalIn  : integer;
  TotalOut : integer;
  IM       : integer;

  MIMECountdown : integer;
  MIMEBytesCount: integer;
begin

  if size=0 then
  begin
    result:=0;
    exit
  end;

  // This is important code if you encode just part of a stream
  if size<0 then
    TotalIn:= sIn.Size-sIn.Position
  else
    TotalIn:= Size;

  B8:=0;
  I8:=0;

  MIMECountdown  := MIMELine;
  MIMEBytesCount := 0;

  TotalOut:=SZEncodeBaseXStreamUpdate(sIN, sOUT, TotalIn, Codes, BITS, B8, I8, MIMELine, MIMECountdown, MIMEBytesCount);

  // If something left
  if I8>0 then
    TotalOut:=TotalOut + SZEncodeBaseXStreamFinalyze(sOUT, Codes, BITS, B8, I8);

  if FullQuantum>0 then
  begin

    // Calculate relevant data
    // GetRelevantData(TotalIn, TotalOut, BITS, FullQuantum, IM);

    // Get required padding keys
    IM:=SZCalcRequiredPaddingKeys(TotalOut-MIMEBytesCount, FullQuantum);

    if IM > 0 then
    begin
      sOut.Write(PAnsiChar(StringOfChar('=',IM))^,IM);
      TotalOut:=TotalOut+IM
    end

  end;

  result:=TotalOut;
end;

function SZDecodeBaseXStream(sIN, sOUT: TStream;  const Codes: AnsiString; BITS: integer): integer;
var
  TotalIn  : integer;
  TotalOut : integer;

  pIn,pOut: pByte;

  pBuffIn, pBuffOut: pByte;
  Res,BUFF : Integer;
  LOut,Count: integer;

  B8, I8: integer;
begin

  BUFF := SZBUFFSIZE;

  // This is important code if you encode just a part of a stream
  TotalIn := sIn.Size - SIn.Position;

  if BUFF > TotalIn  then
    BUFF := TotalIn + 1;

  TotalOut := BUFF;

  // Get memory for it
  GetMem(pBuffIn,BUFF);
  GetMem(pBuffOut,TotalOut);

  Count := 0;

  B8 := 0;
  I8 := 0;

  SZUpdateFastDecodeTable(Codes);

  repeat
    Res := sIn.Read(pBuffIn^, BUFF);

    pIn  := pBuffIn;
    pOut := pBuffOut;

    Lout := SZDecodeBaseXMemoryUpdate(pIN, pOUT, Res, SZFastDecodeTable, BITS, B8, I8);

    sOut.Write(pBuffOut^,LOut);

    Count := Count + LOut;

  until (Res <> LongInt(BUFF));

  FreeMem(pBuffOut);
  FreeMem(pBuffIn);

  result := Count;
end;

function SZEncodeBaseXFile(const FileName: AnsiString; sOUT: TStream; const Codes: AnsiString; BITS: integer; FullQuantum : integer; MIMELine: integer ): integer;
var
  sIn: TFileStream;
  Size: integer;
begin
  sIn := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);

  Size:= sIn.Size;

  try
    result:= SZEncodeBaseXStream(sIN, sOUT, Size, Codes, BITS, FullQuantum, MIMELine);
  finally
    sIn.Free;
  end;
end;

///////////////////////////////////////////////////
// File to stream
///////////////////////////////////////////////////

function SZFullEncodeBase64(const FileName: AnsiString; sOUT: TStream; MIMELine: integer = 0): integer; overload;
begin
  result:=SZEncodeBaseXFile(FileName, sOUT, SZCodes64, SZBITS64, SZFullQuantum64, MIMELine);
end;

function SZFullEncodeBase64URL(const FileName: AnsiString; sOUT: TStream; MIMELine: integer = 0): integer; overload;
begin
  result:=SZEncodeBaseXFile(FileName, sOUT, SZCodes64URL, SZBITS64, SZFullQuantum64, MIMELine);
end;

function SZEncodeBase64(const FileName: AnsiString; sOUT: TStream; MIMELine: integer = 0): integer; overload;
begin
  result:=SZEncodeBaseXFile(FileName, sOUT, SZCodes64, SZBITS64, SZFullQuantum0, MIMELine);
end;

function SZEncodeBase64URL(const FileName: AnsiString; sOUT: TStream; MIMELine: integer = 0): integer; overload;
begin
  result:=SZEncodeBaseXFile(FileName, sOUT, SZCodes64URL, SZBITS64, SZFullQuantum0, MIMELine);
end;

function SZFullEncodeBase32(const FileName: AnsiString; sOUT: TStream; MIMELine: integer = 0): integer; overload;
begin
  result:=SZEncodeBaseXFile(FileName, sOUT, SZCodes32, SZBITS32, SZFullQuantum32, MIMELine);
end;

function SZEncodeBase32(const FileName: AnsiString; sOUT: TStream; MIMELine: integer = 0): integer; overload;
begin
  result:=SZEncodeBaseXFile(FileName, sOUT, SZCodes32, SZBITS32, SZFullQuantum0, MIMELine);
end;

function SZEncodeBase16(const FileName: AnsiString; sOUT: TStream; MIMELine: integer = 0): integer; overload;
begin
  result:=SZEncodeBaseXFile(FileName, sOUT, SZCodes16, SZBITS16, SZFullQuantum0, MIMELine);
end;

////////////////////////////////////////////////////////////
///    Base16
////////////////////////////////////////////////////////////

function SZEncodeBase16(pIN, pOUT: PByte; Size: integer; MIMELine: integer = 0): integer; overload;
begin
  result:= SZEncodeBaseXMemory(pIN,pOUT, Size, SZCodes16, SZBITS16, SZFullQuantum0, MIMELine);
end;

function SZEncodeBase16(sIN, sOUT: TStream; Size: integer=-1; MIMELine: integer = 0): integer; overload;
begin
  result:=SZEncodeBaseXStream(sIN, sOUT, Size, SZCodes16, SZBITS16, SZFullQuantum0, MIMELine);
end;

function SZEncodeBase16(const S: AnsiString; MIMELine: integer = 0): AnsiString; overload;
begin
  Result:=SZEncodeBaseXString(S, SZCodes16, SZBITS16, SZFullQuantum0, MIMELine)
end;

function SZDecodeBase16(pIN, pOUT: PByte; Size: integer): integer; overload;
begin
  result:= SZDecodeBaseXMemory(pIN,pOUT, Size, SZCodes16, SZBITS16);
end;

function SZDecodeBase16(sIN, sOUT: TStream): integer; overload;
begin
  result:= SZDecodeBaseXStream(sIN,sOUT, SZCodes16, SZBITS16);
end;

function SZDecodeBase16(const S: AnsiString): AnsiString; overload;
begin
  Result:=SZDecodeBaseXString(S, SZCodes16, SZBITS16)
end;

////////////////////////////////////////////////////////////
/// Base32
////////////////////////////////////////////////////////////

function SZFullEncodeBase32(pIN, pOUT: PByte; Size: integer; MIMELine: integer = 0): integer;  overload;
begin
  result:=SZEncodeBaseXMemory(pIN,pOUT, Size, SZCodes32, SZBITS32, SZFullQuantum32, MIMELine);
end;

function SZFullEncodeBase32(sIN, sOUT: TStream; Size: integer=-1; MIMELine: integer = 0): integer; overload;
begin
  result:=SZEncodeBaseXStream(sIN,sOUT, Size, SZCodes32, SZBITS32, SZFullQuantum32, MIMELine);
end;

function SZFullEncodeBase32(const S: AnsiString; MIMELine: integer = 0): AnsiString; overload;
begin
  Result:=SZEncodeBaseXString(S, SZCodes32, SZBITS32, SZFullQuantum32, MIMELine);
end;

function SZEncodeBase32(pIN, pOUT: PByte; Size: integer; MIMELine: integer = 0): integer; overload;
begin
  result:=SZEncodeBaseXMemory(pIN,pOUT, Size, SZCodes32, SZBITS32, SZFullQuantum0, MIMELine);
end;

function SZEncodeBase32(sIN, sOUT: TStream; Size: integer=-1; MIMELine: integer = 0): integer; overload;
begin
  result:=SZEncodeBaseXStream(sIN,sOUT, Size, SZCodes32, SZBITS32, SZFullQuantum0, MIMELine);
end;

function SZEncodeBase32(const S: AnsiString; MIMELine: integer = 0): AnsiString; overload;
begin
  Result:=SZEncodeBaseXString(S, SZCodes32, SZBITS32, SZFullQuantum0, MIMELine)
end;

function SZDecodeBase32(pIN, pOUT: PByte; Size: integer): integer; overload;
begin
  result:=SZDecodeBaseXMemory(pIN,pOUT, Size, SZCodes32, SZBITS32);
end;

function SZDecodeBase32(sIN, sOUT: TStream): integer; overload;
begin
  result:=SZDecodeBaseXStream(sIN,sOUT, SZCodes32, SZBITS32);
end;

function SZDecodeBase32(const S: AnsiString): AnsiString; overload;
begin
  Result:=SZDecodeBaseXString(S, SZCodes32, SZBITS32)
end;

////////////////////////////////////////////////////////////
/// Base64
////////////////////////////////////////////////////////////

function SZFullEncodeBase64(pIN, pOUT: PByte; Size: integer; MIMELine: integer = 0): integer;  overload;
begin
  result:=SZEncodeBaseXMemory(pIN,pOUT, Size, SZCodes64, SZBITS64, SZFullQuantum64, MIMELine);
end;

function SZFullEncodeBase64(sIN, sOUT: TStream; Size: integer=-1; MIMELine: integer = 0): integer; overload;
begin
  result:=SZEncodeBaseXStream(sIN,sOUT, Size, SZCodes64, SZBITS64, SZFullQuantum64, MIMELine);
end;

function SZFullEncodeBase64(const S: AnsiString; MIMELine: integer = 0): AnsiString;  overload;
begin
  Result:=SZEncodeBaseXString(S, SZCodes64, SZBITS64, SZFullQuantum64, MIMELine)
end;

function SZEncodeBase64(pIN, pOUT: PByte; Size: integer; MIMELine: integer = 0): integer; overload;
begin
  result:=SZEncodeBaseXMemory(pIN,pOUT, Size, SZCodes64, SZBITS64, SZFullQuantum0, MIMELine);
end;

function SZEncodeBase64(sIN, sOUT: TStream; Size: integer=-1; MIMELine: integer = 0): integer; overload;
begin
  result:=SZEncodeBaseXStream(sIN,sOUT, Size, SZCodes64, SZBITS64, SZFullQuantum0, MIMELine);
end;

function SZEncodeBase64(const S: AnsiString; MIMELine: integer = 0): AnsiString; overload;
begin
  Result:=SZEncodeBaseXString(S, SZCodes64, SZBITS64, SZFullQuantum0, MIMELine)
end;

function SZDecodeBase64(pIN, pOUT: PByte; Size: integer): integer; overload;
begin
  result:=SZDecodeBaseXMemory(pIN,pOUT, Size, SZCodes64, SZBITS64);
end;

function SZDecodeBase64(sIN, sOUT: TStream): integer; overload;
begin
  result:=SZDecodeBaseXStream(sIN,sOUT, SZCodes64, SZBITS64);
end;

function SZDecodeBase64(const S: AnsiString): AnsiString; overload;
begin
  Result:=SZDecodeBaseXString(S, SZCodes64, SZBITS64)
end;

////////////////////////////////////////////////////////////
///  Base64 URL table
////////////////////////////////////////////////////////////

function SZFullEncodeBase64URL(pIN, pOUT: PByte; Size: integer; MIMELine: integer = 0): integer; overload;
begin
  result:=SZEncodeBaseXMemory(pIN, pOUT, Size, SZCodes64URL, SZBITS64, SZFullQuantum64, MIMELine);
end;

function SZFullEncodeBase64URL(sIN, sOUT: TStream; Size: integer=-1; MIMELine: integer = 0): integer; overload;
begin
  result:=SZEncodeBaseXStream(sIN,sOUT, Size, SZCodes64URL, SZBITS64, SZFullQuantum64, MIMELine);
end;

function SZFullEncodeBase64URL(const S: AnsiString; MIMELine: integer = 0): AnsiString; overload;
begin
  Result:=SZEncodeBaseXString(S, SZCodes64URL, SZBITS64, SZFullQuantum64, MIMELine)
end;

function SZEncodeBase64URL(pIN, pOUT: PByte; Size: integer; MIMELine: integer = 0): integer; overload;
begin
  result:=SZEncodeBaseXMemory(pIN, pOUT, Size, SZCodes64URL, SZBITS64, SZFullQuantum0, MIMELine);
end;

function SZEncodeBase64URL(const S: AnsiString; MIMELine: integer = 0): AnsiString; overload;
begin
  Result:=SZEncodeBaseXString(S, SZCodes64URL, SZBITS64, SZFullQuantum0, MIMELine)
end;

function SZEncodeBase64URL(sIN, sOUT: TStream; Size: integer=-1; MIMELine: integer = 0): integer; overload;
begin
  result:=SZEncodeBaseXStream(sIN,sOUT, Size, SZCodes64URL, SZBITS64, SZFullQuantum0, MIMELine);
end;

function SZDecodeBase64URL(pIN, pOUT: PByte; Size: integer): integer; overload;
begin
  result:=SZDecodeBaseXMemory(pIN,pOUT, Size, SZCodes64URL, SZBITS64);
end;

function SZDecodeBase64URL(sIN, sOUT: TStream): integer; overload;
begin
  result:=SZDecodeBaseXStream(sIN,sOUT, SZCodes64URL, SZBITS64);
end;

function SZDecodeBase64URL(const S: AnsiString): AnsiString; overload;
begin
  Result:=SZDecodeBaseXString(S, SZCodes64URL, SZBITS64)
end;

//////////////////////////////////////////////////////////////

procedure SZCodeBaseXSetBufferSize(Size:integer);
begin
  // Do not allow Buffers size less than original
  // to avoid drastic performace decresing with streams

  if size < SZORIGBUFFSIZE then
    SZBUFFSIZE := Size
  else
    SZBUFFSIZE := SZORIGBUFFSIZE;
end;

procedure SZCodeBaseXSetOrigBufferSize;
begin
  SZCodeBaseXSetBufferSize(SZORIGBUFFSIZE);
end;

//////////////////////////////////////////////////////////////////
// Calculating Required Output Memory
//////////////////////////////////////////////////////////////////

function SZCalcRequiredOutputMemoryForFullEncodeBase64(Size: integer; MIMELine: integer=0): integer;
begin
  Result:=SZCalcRequireOutputMemory(Size, SZBITS64, SZFullQuantum64, MIMELine);
end;

function SZCalcRequiredOutputMemoryForFullEncodeBase32(Size: integer; MIMELine: integer=0): integer;
begin
  Result:=SZCalcRequireOutputMemory(Size, SZBITS32, SZFullQuantum32, MIMELine);
end;

function SZCalcRequiredOutputMemoryForFullEncodeBase16(Size: integer; MIMELine: integer=0): integer;
begin
  Result:=SZCalcRequireOutputMemory(Size, SZBITS16, SZFullQuantum0, MIMELine);
end;

function SZCalcRequiredOutputMemoryForEncodeBase64(Size: integer; MIMELine: integer=0): integer;
begin
  Result:=SZCalcRequireOutputMemory(Size, SZBITS64, SZFullQuantum0, MIMELine);
end;

function SZCalcRequiredOutputMemoryForEncodeBase32(Size: integer; MIMELine: integer=0): integer;
begin
  Result:=SZCalcRequireOutputMemory(Size, SZBITS32, SZFullQuantum0, MIMELine);
end;

function SZCalcRequiredOutputMemoryForEncodeBase16(Size: integer; MIMELine: integer=0): integer;
begin
  Result:=SZCalcRequireOutputMemory(Size, SZBITS16, SZFullQuantum0, MIMELine);
end;

//////////////////////////////////////////////////////////////
///      END OF ACTUAL CODE
//////////////////////////////////////////////////////////////

//////////////////////////////////////////////////////////////
//Additional code may be deleted in the future
//////////////////////////////////////////////////////////////

const
  codes64: array[0..63] of byte = (
    065, 066, 067, 068, 069, 070, 071, 072,
    073, 074, 075, 076, 077, 078, 079, 080,
    081, 082, 083, 084, 085, 086, 087, 088,
    089, 090, 097, 098, 099, 100, 101, 102,
    103, 104, 105, 106, 107, 108, 109, 110,
    111, 112, 113, 114, 115, 116, 117, 118,
    119, 120, 121, 122, 048, 049, 050, 051,
    052, 053, 054, 055, 056, 057, 043, 047);

function SZFullEncodeOnlyBase64(const S: AnsiString; MIMELine: integer = 0): AnsiString;
{
 Encode algorithm for Base64
 Reference: RFC 3548 - full compatibility

 ATTENTION! MIMELine here in not in use!
}

type
  TBI3= packed array [0..2] of byte;
  pBI3= ^TBI3;

  TBO4= packed array [0..3] of byte;
  pBO4= ^TBO4;
var
  i: integer;

  pIN: pBI3;
  pOUT: pBO4;

  TotalIn, TotalOut, TotalInRest: integer;
  B32: longword;

begin

  TotalIn  := length(s);
  TotalOut := (TotalIn + 2) div 3 * 4 ;
  TotalINRest:= TotalIn - TotalIN div 3 * 3;

  SetLength(Result, TotalOut);

  pIN  := @S[1];
  pOUT := @Result[1];

  // Start coding
  for i := 1 to TotalIn Div 3 do
  begin

    // Set new DWORD value in format
    // 00000000 11111111 22222222 33333333

    B32 := (pIN[0] shl 16) or (pIN[1] shl 8) or (pIn[2]);
    inc(pIN);

    pOUT[3] := Codes64[ B32  and $3F ]; B32:=B32 shr 6;
    pOUT[2] := Codes64[ B32  and $3F ]; B32:=B32 shr 6;
    pOUT[1] := Codes64[ B32  and $3F ]; B32:=B32 shr 6;
    pOUT[0] := Codes64[ B32          ];

    inc(pOUT);

  end;

  if TotalINRest = 1 then
  begin
    B32:= (pIn[0] shl 4) ;

    pOUT[1] := Codes64[ B32 and $3F ]; B32:= B32 shr 6;
    pOUT[0] := Codes64[ B32         ];

    pOUT[3] := byte('=');
    pOUT[2] := byte('=');
  end
  else
  if TotalINRest = 2
  then
  begin
    B32:= ((pIn[0] shl 8) or pIn[1]) shl 2 ;

    pOUT[2] := Codes64[ B32 and $3F ]; B32:= B32 shr 6;
    pOUT[1] := Codes64[ B32 and $3F ]; B32:= B32 shr 6;
    pOUT[0] := Codes64[ B32         ];

    pOUT[3] := byte('=');

  end

end;


function SZFullEncodeOnlyBase64_6(const S: AnsiString; MIMELine: integer = 0): AnsiString;
{
 Encode algorithm for Base64
 Reference: RFC 3548 - full compatibility

 ATTENTION! MIMELine here in not in use!
}

type

  TBI3= packed array [0..2] of byte;
  pBI3= ^TBI3;

  TBO4= packed array [0..3] of byte;
  pBO4= ^TBO4;

var
  i: integer;

  pIN: pBI3;
  pOUT: pBO4;

  TotalIn, TotalOut, TotalINRest: integer;
  B32: longword;

begin

  TotalIn  := length(s);
  TotalOut := (TotalIn + 2) div 3 * 4 ;
  TotalINRest:= TotalIn - TotalIN div 3 * 3;

  SetLength(Result, TotalOut);

  pIN  := @S[1];
  pOUT := @Result[1];

  // This variation encode directly form input DWORD

  // Start coding
  for i := 1 to TotalIn Div 3 do
  begin

    B32:=pLongWord(pIN)^;
    inc(pIN);

    pOUT[0] := Codes64[((B32 shr  2) and $3F)];
    pOUT[1] := Codes64[((B32 shl  4) and $3F) or ((B32 shr 12) and $0F)];
    pOUT[2] := Codes64[((B32 shr  6) and $3C) or ((B32 shr 22) and $03)];
    pOUT[3] := Codes64[((B32 shr 16) and $3F)];

    inc(pOUT);

  end;

  if TotalINRest = 1 then
  begin
    B32:= (pIn[0] shl 4) ;

    pOUT[1] := Codes64[ B32 and $3F ]; B32:= B32 shr 6;
    pOUT[0] := Codes64[ B32         ];

    pOUT[3] := byte('=');
    pOUT[2] := byte('=');
  end
  else
  if TotalINRest = 2
  then
  begin
    B32:= ((pIn[0] shl 8) or pIn[1]) shl 2 ;

    pOUT[2] := Codes64[ B32 and $3F ]; B32:= B32 shr 6;
    pOUT[1] := Codes64[ B32 and $3F ]; B32:= B32 shr 6;
    pOUT[0] := Codes64[ B32         ];

    pOUT[3] := byte('=');
  end

end;


Initialization
  SZCodeBaseXSetOrigBufferSize;

end.

Open in new window

0
 
LVL 13

Expert Comment

by:aflarin
ID: 33596737
>> or maybe there is a compiler directive for that?

I know D2009 has not it, but maybe it appears in D2010/Delphi XE?
0
Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Take Survey Now!
 
LVL 25

Expert Comment

by:epasquier
ID: 33596761
when encoding WideString -> Base64 String, that Base64 string is ANSIString.
And when decoding, you have to consider the same : source Base64 is ANSIString, and result is widestring.

So it is not just so simple as to change String into AnsiString. You have to choose which need to be changed.

I have a smaller unit for base64, I've upgraded it for Unicode so that you can either use it or see how to change your own unit. Beware, I haven't tested it (don't have Delphi >2009...)
unit Code64;

interface

function Encode64(S: string): string;
function Decode64(S: string): string;
function Encode64Unicode(S: string): string;
function Decode64Unicode(S: string): string;

implementation

const
  Codes64 = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';

function Encode64(S: string): string;
var
  i: Integer;
  a: Integer;
  x: Integer;
  b: Integer;
begin
  Result := '';
  a := 0;
  b := 0;
  for i := 1 to Length(s) do
  begin
    x := Ord(s[i]);
    b := b * 256 + x;
    a := a + 8;
    while a >= 6 do
    begin
      a := a - 6;
      x := b SHR a;//div (1 shl a);
      b := b AND ((1 SHL a)-1); //mod (1 shl a);
      Result := Result + Codes64[x + 1];
    end;
  end;
  if a > 0 then
  begin
    x := b shl (6 - a);
    Result := Result + Codes64[x + 1];
  end;
end;

function Decode64(S: string): string;
var
  i: Integer;
  a: Integer;
  x: Integer;
  b: Integer;
begin
  Result := '';
  a := 0;
  b := 0;
  for i := 1 to Length(s) do
  begin
    x := Pos(s[i], codes64) - 1;
    if x >= 0 then
    begin
      b := b * 64 + x;
      a := a + 6;
      if a >= 8 then
      begin
        a := a - 8;
        x := b shr a;
        b := b AND ((1 SHL a)-1);
        Result := Result + chr(x);
      end;
    end
    else
      Exit;
  end;
end;

function Encode64Unicode(S: WideString): ANSIString;
var
  i: Integer;
  a: Integer;
  x: Integer;
  b: Integer;
  p : pByte;
  l :Integer;
begin
  Result := '';
  a := 0;
  b := 0;
  l:=Length(s)*SizeOf(WideChar);
  p:=pByte(@s[1]);
  for i := 0 to L-1 do
  begin    
    x := p^;
    Inc(p);
    b := b * 256 + x;
    a := a + 8;
    while a >= 6 do
    begin
      a := a - 6;
      x := b SHR a;//div (1 shl a);
      b := b AND ((1 SHL a)-1); //mod (1 shl a);
      Result := Result + Codes64[x + 1];
    end;
  end;
  if a > 0 then
  begin
    x := b shl (6 - a);
    Result := Result + Codes64[x + 1];
  end;
end;

function Decode64Unicode(S: ANSIString): WideString;
var
  i: Integer;
  a: Integer;
  x: Integer;
  b: Integer;
  p : pByte;
begin
  Result := '';
  a := 0;
  b := 0;
  SetLength(Result, (length(s)+ 2) div 3 * 4);
  p:=pByte(@Result[1]);
  for i := 1 to Length(s) do
  begin
    x := Pos(s[i], codes64) - 1;
    if x >= 0 then
    begin
      b := b * 64 + x;
      a := a + 6;
      if a >= 8 then
      begin
        a := a - 8;
        x := b shr a;
        b := b AND ((1 SHL a)-1);
        p^:= x;
        Inc(p);
        //Result := Result + chr(x);
      end;
    end
    else
      Exit;
  end;
end;

end.

Open in new window

0
 
LVL 25

Accepted Solution

by:
epasquier earned 250 total points
ID: 33596883
In your unit, you can note that all overloaded functions that works on memory pointers or stream will work as well as they should. Only the string versions need to be changed.

As such, especially
SZDecodeBaseXString
and
SZEncodeBaseXString

need some fixing, and others that call them to specialize (base 16,32,64)
function SZDecodeBaseXString(const S: ANSIString; const Codes: String; BITS: integer): WideString;
var
  TotalIn  : integer;
  TotalOut : integer;

  pIN,pOUT: pByte;

begin

  TotalIn  := length(S);
  TotalOut := (TotalIn * BITS) shr 3; // div 8;

  Setlength(Result,(TotalOut+1) Div 2);

  pIN  := @S[1];
  pOUT := @Result[1];

  TotalOut:=SZDecodeBaseXMemory( pIN, pOUT, TotalIn, Codes, BITS);

  if length(Result)<> TotalOut then
    Setlength(Result,TotalOut);
end;

function SZEncodeBaseXString(const S: WideString; const Codes: string; BITS: integer; FullQuantum : integer ; MIMELine : integer): ANSIString;
// Universal Encode algorithm for Base16, Base32 and Base64
var
  pIN, pOUT: pByte;

  TotalIn, TotalOut: integer;
  IM: integer;
  LOut: integer;
begin
  TotalIn  := length(S)*SizeOf(WideChar);

  // Calculate relevant data
  GetRelevantData(TotalIn, TotalOut, BITS, FullQuantum, IM, MIMELine);

  SetLength(Result,TotalOut);

  pIN :=@S[1];
  pOUT:=@Result[1];

  LOut:=SZEncodeBaseXMemory(pIn,pOut, TotalIn, Codes, BITS, FullQuantum, MIMELine);

  if Lout<>TotalOut then
    SetLength(Result,LOut);
end;


function SZDecodeBase64(const S: ANSIString): WideString; overload;
begin
  Result:=SZDecodeBaseXString(S, SZCodes64, SZBITS64)
end;

function SZEncodeBase64(const S: WideString; MIMELine: integer = 0): ANSIString; overload;
begin
  Result:=SZEncodeBaseXString(S, SZCodes64, SZBITS64, SZFullQuantum0, MIMELine)
end;

Open in new window

0
 
LVL 4

Author Comment

by:cebasso
ID: 33598348
Hey, thanks both for reply!
But then, the final conclusion is that for "Arabic, Chineses characters" there is not support?
Example, i can convert to base64 only ANSI characters and not UTF-8(Unicode) characters?
Both examples works perfectly, but i tried to encode and decode arabic chars and of course, returning AnsiString will lost data (wide chars) hehe
0
 
LVL 25

Expert Comment

by:epasquier
ID: 33598563
no, my functions should be able to encode unicode to b64(ansi) and back to unicode. i am gone now and cannot check. aflarin code do have the restriction you are talking about because he did not mix ansi & wide strings (he used ansi everywhere)
0
 
LVL 13

Assisted Solution

by:aflarin
aflarin earned 250 total points
ID: 33599345
>> Only the string versions need to be changed.

I don't think so. If you changed those - What will you do if the encoded text was ANSI? You decoded unicode string will contain rubbish.

So, if you would like to modify the original code, you can ADD new epasquier's functions. Then you will have two ones:

// original
// if your encoded string is ANSI
function SZDecodeBaseXString(const S: ANSIString; const Codes: AnsiString; BITS: integer): AnsiString;
// epasquier's function
// if your encoded string is UNICODE
function SZDecodeBaseXStringW(const S: AnsiString; const Codes: AnsiString; BITS: integer): WideString;
// amd the same for Base64, Base32, Base16

But then it would be worse if they duplicate code. It would be better if the Unicode function will call Ansi function. In addition it will be shorter:

function SZDecodeBaseXStringW(const S: AnsiString; const Codes: AnsiString; BITS: integer): WideString;
begin
  Result:= RawByteString( SZDecodeBaseXStringW(S, Codes, BITS) );
end;


But you can manage your encoded unicode string ("Arabic, Chineses characters") without adding Unicode functions, like this:

procedure TForm1.Button2Click(Sender: TObject);
var
  original: WideString;
  encoded: AnsiString;
  decoded: WideString;
begin
  // Test unicode string
  original:= 'You can write here your Arabic, Chineses characters';

  { encoding }
  // Result is AnsiString
  encoded:= SzFullEncodeBase64( RawByteString(original) );

  { decoding }
  // SzDecodeBase64 returns AnsiString, but it really contains Unicode, so we save it to Unicode variable
  decoded:= RawByteString( SzDecodeBase64( encoded ) );

  { testing }
  ShowMessage( decoded );
end;

0
 
LVL 25

Expert Comment

by:epasquier
ID: 33607650
> I don't think so. If you changed those - What will you do if the encoded text was ANSI?
> You decoded unicode string will contain rubbish.
No, if you call a function needing unicode parameter with an ANSI string, Delphi will first convert the ANSI string with its Unicode equivalent. Then the encoding would work and produce an ANSI string (twice the size of the one that an encoding function working with ANSI param would) and then the decode would produce again the same Unicode string that Delphi converted. And if you copy that to an ANSIString variable, you will get the original ANSI string, without problems. But yes, it is better to have 2 set of functions to avoid unnecessary conversions
0
 
LVL 4

Author Closing Comment

by:cebasso
ID: 33639331
Thanks both!
I'll split the points since every comment gave me ideas and helped me!

Best Regards,
Carlos
0

Featured Post

Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Take Survey Now!
Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

[Delphi Code] Number to Word
Article by: b10w01f
Objective: - This article will help user in how to convert their numeric value become words. How to use 1. You can copy this code in your Unit as function 2. than you can perform your function by type this code The Code   (CODE) The Im…
Creating an auto free string list
Article by: Ephraim
Creating an auto free TStringList The TStringList is a basic and frequently used object in Delphi. On many occasions, you may want to create a temporary list, process some items in the list and be done with the list. In such cases, you have to…
What makes NetCrunch network monitoring system unique?
Video by: AdRem
There's a multitude of different network monitoring solutions out there, and you're probably wondering what makes NetCrunch so special. It's completely agentless, but does let you create an agent, if you desire. It offers powerful scalability …
display Triangles! and Circles! in a Microsoft Access Query -- Get Previous Record too
Video by: crystal
Visualize your data even better in Access queries. Given a date and a value, this lesson shows how to compare that value with the previous value, calculate the difference, and display a circle if the value is the same, an up triangle if it increased…
Advertise Here
Suggested Courses
Earn Certification
HTML5 Specialist - Certification
Free withPremium
Course of the Month10 days, 11 hours left to enroll
Cryptography
$49.00$44.10
Earn Certification
CompTIA IT Fundamentals
$49.00$44.10

628 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Advertise Here