Base64 natives functions in Clipper !

[Badara Thiam]

Hello,

I put here in public domain, for Clipper and [x]Harbour developpers,
some functions i have created to translate strings in Base64 encodage
and reverse. This will help you in some cases, like to create your own
TSMTP class with Autentification support, necessary to communicate
with more in more SMTP providers...

To help me, you can if this please you, and if you have a web site,
put a link to my site to improve my google ratio. Thanks in advance.

Best Regards.

Code: Select all

* BASE64.PRG
* Creation le 30/12/2008
* Auteur Badara Thiam

*******************
FUNCTION StrToBase64( cTexte )
*******************
* Conversion en base 64 de la chaine cTexte
LOCAL cTexte64 := ""
LOCAL X
LOCAL cHex
DO WHILE !( cTexte == "" )
  cHex := ""
  FOR X := 1 TO 3
    * Conversion de chaque caractère en chaine binaire de 8 octets
    cHex += CarToBin( LEFT(cTexte, 1) )
    IF LEN(cTexte) > 1
      cTexte := SUBSTR(cTexte, 2)
    ELSE
      cTexte := ""
      EXIT
    ENDIF
  NEXT X
  FOR X := 1 TO 4
    IF SUBSTR(cHex, ( (X - 1) * 6) + 1 ) == ""
      cTexte64 += "="
    ELSE
      cTexte64 += Carac64( "00" + SUBSTR(cHex, ( (X - 1) * 6) + 1, 6 ) )
    ENDIF
  NEXT X
ENDDO
RETURN cTexte64

*********************
FUNCTION Base64ToStr( cTexte64 )
*********************
* décodage d'un texte codé en base 64
LOCAL cTexte := ""
LOCAL X
LOCAL cHex
LOCAL cCar
DO WHILE !( cTexte64 == "" )
  cCar := LEFT(cTexte64,4)
  cHex := ""
  FOR X := 1 TO 4
    IF SUBSTR(cCar, X, 1 ) != "="
      cHex += Hex64( SUBSTR(cCar, X, 1 ) )
    ELSE
      EXIT
    ENDIF
  NEXT X

  FOR X := 1 TO 3
    IF SUBSTR(cHex, ( (X - 1) * 8) + 1 ) == ""
      EXIT
    ELSE
      cTexte += BinToCar( SUBSTR(cHex, ( (X - 1) * 8) + 1, 8 ) )
    ENDIF
  NEXT X

  IF LEN(cTexte64) > 4
    cTexte64 := SUBSTR(cTexte64, 5)
  ELSE
    cTexte64 := ""
  ENDIF
ENDDO
RETURN cTexte

****************
FUNCTION Carac64( cBin )
****************
* Renvoie le caractère correspondant en base 64
LOCAL nPos := ASC( BinToCar( @cBin ) ) + 1
RETURN SUBSTR( "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/", nPos, 1)

**************
FUNCTION Hex64( carac64 )
**************
* Renvoie le caractère correspondant en base 64
LOCAL cCodeAsc := CHR( AT(carac64, "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" ) -1 )
RETURN SUBSTR( CarToBin( @cCodeAsc ) , 3, 6)

*****************
FUNCTION CarToBin( carac, lInverse )
*****************
* Renvoie le caractère correspondant dans une chaine binaire (composée de 0 et 1) de 8 bits

#define cHexa  "0123456789ABCDEF"
#define aBin  {"0000", "0001", "0010", "0011", "0100", "0101", "0110", "0111", ;
          "1000", "1001", "1010", "1011", "1100", "1101", "1110", "1111" }
LOCAL cToHex

IF EMPTY( lInverse )
* Retourne la chaine binaire en ayant reçu le caractère ASCII
  cToHex := str2Hex( carac )
  RETURN aBin[ AT( LEFT(cToHex,1), cHexa ) ] + aBin[ AT( SUBSTR(cToHex,2), cHexa ) ]
ELSE
* Retourne le caractère ASCII en ayant reçu la chaine binaire
  cToHex := SUBSTR(cHexa, ASCAN(aBin, LEFT(carac,4 ) ), 1 ) ;
  + SUBSTR(cHexa, ASCAN(aBin, SUBSTR(carac,5,4 ) ), 1 )
  RETURN Hex2str( cToHex )
ENDIF
RETURN NIL

*****************
FUNCTION BinToCar( cBin )
*****************
RETURN CarToBin( @cBin, .T. )

[vailtom]

Thank you for your contribution! This helped me today in a project ...

Regards

[Badara Thiam]

I am happy for you...

Regards.

[Badara Thiam]

Hello,
I have upgraded StrToBase64() today. One bug fixed.
No changes in others functions.

Regards.

Code: Select all

* BASE64.PRG
* Creation le 30/12/2008
* Auteur Badara Thiam
* Derniere modification le 25/09/2009 à 16:35:37

* Modification du 25/09/2009 effectuée dans StrToBase64()
* Résout une erreur de conversion apparaissant lorsque :
* ( le nombre de caractères dans la chaine multiplié par 8) n'est pas un multiple de 6

*******************
FUNCTION StrToBase64( cTexte )
*******************
* Conversion en base 64 de la chaine cTexte

* Un alphabet de 65 caractères est utilisé pour permettre la représentation de 6 bits par caractère :
* "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"

* Le '=' (65e caractère) est utilisé dans le processus de codage pour les caractères finaux.

LOCAL cTexte64 := ""
LOCAL X
LOCAL cHex
DO WHILE !( cTexte == "" )
  cHex := ""

  * Le processus de codage représente des groupes de 24 bits de données en entrée par une chaîne en sortie de 4 caractères codés.
  * En procédant de gauche à droite, un groupe de 24 bits est créé en concaténant 3 octets (8 bits par octet).
  FOR X := 1 TO 3
    * Conversion de chaque caractère en chaine binaire de 8 octets
    cHex += CarToBin( LEFT(cTexte, 1) )
    IF LEN(cTexte) > 1
      cTexte := SUBSTR(cTexte, 2)
    ELSE
      cTexte := ""
      EXIT
    ENDIF
  NEXT X

  * Ces 24 bits (ici contenus dans cHex, ou au moins un multiple) sont traités comme 4 groupes concaténés de 6 bits chacun convertis
  * en un unique caractère dans l'alphabet de la base 64.

  * Chaque groupe de 6 bits est utilisé comme index dans la table des caractères de la base 64.
  * Le caractère référencé par l'index correspondant est utilisé comme codage de ce groupe de 6 bits.

  FOR X := 1 TO 4

    IF SUBSTR(cHex, ( (X - 1) * 6) + 1 ) == ""
        cTexte64 += REPLICATE("=", 4 - X + 1)
        EXIT
    ELSE

      * Un traitement spécial est effectué si moins de 24 bits sont disponibles à la fin des données
      * à coder. Aucun bit ne restant non-codé,
      * si moins de 24 bits sont disponibles alors des bits à zéro sont ajoutés à la droite des données
      *  pour former un nombre entier de groupes de 6 bits.
      IF LEN( cHex ) % 6 > 0
         * Ajout des bits à zéro
         cHex += REPLICATE("0", 6 - ( LEN( cHex ) % 6 ) )
      ENDIF


      cTexte64 += Carac64( "00" + SUBSTR(cHex, ( (X - 1) * 6) + 1, 6 ) )
    ENDIF
  NEXT X
ENDDO
RETURN cTexte64

*********************
FUNCTION Base64ToStr( cTexte64 )
*********************
* décodage d'un texte codé en base 64
LOCAL cTexte := ""
LOCAL X
LOCAL cHex
LOCAL cCar
DO WHILE !( cTexte64 == "" )
  cCar := LEFT(cTexte64,4)
  cHex := ""
  FOR X := 1 TO 4
    IF SUBSTR(cCar, X, 1 ) != "="
      cHex += Hex64( SUBSTR(cCar, X, 1 ) )
    ELSE
      EXIT
    ENDIF
  NEXT X

  FOR X := 1 TO 3
    IF SUBSTR(cHex, ( (X - 1) * 8) + 1 ) == ""
      EXIT
    ELSE
      cTexte += BinToCar( SUBSTR(cHex, ( (X - 1) * 8) + 1, 8 ) )
    ENDIF
  NEXT X

  IF LEN(cTexte64) > 4
    cTexte64 := SUBSTR(cTexte64, 5)
  ELSE
    cTexte64 := ""
  ENDIF
ENDDO
RETURN cTexte

****************
FUNCTION Carac64( cBin )
****************
* Renvoie le caractère correspondant en base 64
LOCAL nPos := ASC( BinToCar( @cBin ) ) + 1
RETURN SUBSTR( "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/", nPos, 1)

**************
FUNCTION Hex64( carac64 )
**************
* Renvoie le caractère correspondant en base 64
LOCAL cCodeAsc := CHR( AT(carac64, "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" ) -1 )
RETURN SUBSTR( CarToBin( @cCodeAsc ) , 3, 6)

*****************
FUNCTION CarToBin( carac, lInverse )
*****************
* Renvoie le caractère correspondant dans une chaine binaire (composée de 0 et 1) de 8 bits

#define cHexa  "0123456789ABCDEF"
#define aBin  {"0000", "0001", "0010", "0011", "0100", "0101", "0110", "0111", ;
          "1000", "1001", "1010", "1011", "1100", "1101", "1110", "1111" }
LOCAL cToHex

IF EMPTY( lInverse )
* Retourne la chaine binaire en ayant reçu le caractère ASCII
  cToHex := str2Hex( carac )
  RETURN aBin[ AT( LEFT(cToHex,1), cHexa ) ] + aBin[ AT( SUBSTR(cToHex,2), cHexa ) ]
ELSE
* Retourne le caractère ASCII en ayant reçu la chaine binaire
  cToHex := SUBSTR(cHexa, ASCAN(aBin, LEFT(carac,4 ) ), 1 ) ;
  + SUBSTR(cHexa, ASCAN(aBin, SUBSTR(carac,5,4 ) ), 1 )
  RETURN Hex2str( cToHex )
ENDIF
RETURN NIL

*****************
FUNCTION BinToCar( cBin )
*****************
RETURN CarToBin( @cBin, .T. )
 

[Wiegand]

Dear Badara Thiam

Thank you for your Contribution. It works well and helped me a lot.

Greatings

Peter Wiegand

[softruz]

The function Base64toStr, has a error, the change is, add this code on the end function:

cTexte:=str2hex(cTexte)
if right(cTexte,2)="00"
cTexte:=substr(cTexte,1,len(cTexte)-2)
end if
cTexte:=hex2str(cTexte)

return cTexte