Coder un texte en base64

' Encodage base64 et base64URL
' Marc - Octobre 2021
dim base64$(63,1)

label convertir

creerTableBase64()

interfaceUtilisateur()

end


sub interfaceUtilisateur()
    caption 0,"Conversion de texte en base64"

    memo 1
    top 1,55
    left 1,70

    button 2
    top 2,300
    width 2,150
    left 2,217
    top 2,205
    caption 2,"Convertir en base64"
    on_click 2,convertir

    button 3
    top 3,260
    left 3,217
    width 3,150
    caption 3,"Convertir en base64URL"
    on_click 3,convertir

    memo 4
    left 4,330
    top 4,55
    
    alpha 5
    left 5,70
    top 5,40
    caption 5,"Tapez votre texte à convertir :"
    
    alpha 6
    left 6,333
    top 6,40
    caption 6,"Texte encodé en base64 :"
end_sub


convertir:
    if number_click = 2
        encodageBase64(0)
        caption 6,"Texte encodé en base64"
    else
        encodageBase64(1)
        caption 6,"Texte encodé en base64URL"
    end_if    
return


sub encodageBase64(type%)
    dim_local a$, b%, octet$, d$, e%, n%, m%, p%, groupe24Ascii$, groupe24binaire$, index%, texteBase64$, ajout$
    
    clear 4
    a$ = text$(1)
    
    ' lecture de la chaine a$ par groupes de 24 bits (3 octets)
    for index% = 1 to len(a$) step 3
        groupe24Ascii$ = mid$(a$,index%,3)

        ' conversion en binaire, de groupe24Ascii$ dans groupe24binaire$
        for n% = 1 to len(groupe24Ascii$)
            b% = asc(mid$(groupe24Ascii$,n%,1))

            while b% > 0
                if frac(b% / 2) = 0
                    octet$ = "0" + octet$
                else
                    octet$ = "1" + octet$
                end_if
                b% = INT(b% / 2)
           end_while
          
           while len(octet$) < 8
               octet$ = "0" + octet$
           end_while            

           groupe24Binaire$ = groupe24Binaire$ + octet$
           octet$ = ""
        next n%

        ' compléter groupe24Binaire$ jusqu'à concurrence de 24 bits
        if len(groupe24Binaire$) < 24
            if len(groupe24Binaire$) = 16
                groupe24Binaire$ = groupe24Binaire$ + "00"
                ajout$ = "="
            else
                groupe24Binaire$ = groupe24Binaire$ + "0000"
                ajout$ = "=="
            end_if
        end_if

        ' lecture par groupe de 6 bits + codage
        for p% = 1 to len(groupe24binaire$) step 6  
            e% = 0
            d$ = mid$(groupe24Binaire$,p%,6)
            WHILE d$ <> ""
                e% = (e% * 2) + INSTR("01",LEFT$(d$,1))-1
                d$ = RIGHT$(d$,LEN(d$)-1)
            END_WHILE
            texteBase64$ = texteBase64$ + base64$(e%,type%)
        next p%
        groupe24Binaire$ = ""
    next index%

    if type% = 0
        text 4,texteBase64$ + ajout$
    else
        text 4,texteBase64$
    end_if
    
end_sub



sub creerTableBase64()
    dim_local n%
    
    ' Deux bases 64 sont créées :
    ' base64 => base64$(_,0)
    ' base64URL => base64$(_,1)

    for n% = 0 to 25 :' lettres majuscules "A" à "Z"
        base64$(n%,0) = chr$(65 + n%)
        base64$(n%,1) = chr$(65 + n%)
    next n%

    for n% = 26 to 51 :' lettres minuscules "a" à "z"
        base64$(n%,0) = chr$(97 + n% - 26)
        base64$(n%,1) = chr$(97 + n% - 26)
    next n%

    for n% = 52 to 61 :' chiffres de "0" à "9"
        base64$(n%,0) = chr$(48 + n% - 52)
        base64$(n%,1) = chr$(48 + n% - 52)
    next n%

    base64$(62,0) = chr$(43) :' "+"
    base64$(62,1) = chr$(45) :' "-"
    base64$(63,0) = chr$(47) :' "/"
    base64$(63,1) = chr$(95) :' "_"
end_sub

namespace Base64
  static as string*64 B64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" _
                          & "abcdefghijklmnopqrstuvwxyz" _
                          & "0123456789+/"

  Function EncodeMemory(buffer as any ptr,size as long) As String
    #define E0 (S[j] shr 2)
    #define E1 (((S[j] and &H03) shl 4) + (S[j+1] shr 4))
    #define E2 (((S[j+1] and &H0F) shl 2) + (S[j+2] shr 6))
    #define E3 (S[j+2] and &H3F)
    dim as long nChars = size
    if nChars=0 then return ""
    dim as ubyte ptr S=buffer
    dim as long j,k,m = nChars mod 3
    dim as string r=string(((nChars+2)\3)*4,"=")
    nChars-= (m+1)
    For j = 0 To nChars Step 3
      r[k]=B64[e0] : r[k+1]=B64[e1] : r[k+2]=B64[e2] : r[k+3]=B64[e3]:k+=4
    Next
    if m then
      r[k]=B64[e0] : r[k+1]=B64[e1] : r[k+3]=61
      If m = 2 Then r[k+2]=B64[e2] Else  r[k+2]=61
    end if
    return r
    #undef E0
    #undef E1
    #undef E2
    #undef E3
  End Function

  Function DecodeMemory(s As String,byref nBytes as integer) As any ptr
    #define P0(p) instr(B64,chr(s[n+p]))-1
    dim as long nChars=Len(s)
    if nChars<1 then return 0
    nBytes=nChars : nChars-=1
    dim as ubyte ptr O,buffer=callocate(nBytes)
    O=buffer
    for n As long = 0 To nChars Step 4
      var b = P0(1), c = P0(2), d = P0(3)
      if b>-1 then
        var a = P0(0) : *O = (a shl 2 + b shr 4) : O+=1
      end if
      if c>-1 then *O = (b shl 4 + c shr 2) : O+=1
      if d>-1 then *O = (c shl 6 + d) : O+=1
    next
    return buffer
    #undef P0
  end function
end namespace  

' **********************************************************

dim as string a, a1
dim as zstring ptr b

a = "Bonjour les amis Panoramiciens"

? "Chaine initiale : "; a

a1 = Base64.EncodeMemory(strptr(a), len(a))

? "Chaine encodee  : "; a1

b = Base64.DecodeMemory(a1, len(a1))

? "Chaine decodee  : "; *b

sleep

Chaine initiale : Bonjour les amis Panoramiciens
Chaine encodee  : Qm9uam91ciBsZXMgYW1pcyBQYW5vcmFtaWNpZW5z
Chaine decodee  : Bonjour les amis Panoramiciens

Chaine initiale : Bonjour les amis Panoramiciens !
Chaine encodee  : Qm9uam91ciBsZXMgYW1pcyBQYW5vcmFtaWNpZW5zICE=
Chaine decodee  : Bonjour les amis Panoramiciens !