share/stringproc/base64.lisp

   1
   2 #|
   3    This program is free software; you can redistribute it and/or modify
   4    it under the terms of the GNU General Public License as published by
   5    the Free Software Foundation; either version 2 of the License, or
   6    (at your option) any later version.
   7
   8    This program is distributed in the hope that it will be useful,
   9    but WITHOUT ANY WARRANTY; without even the implied warranty of
  10    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11    GNU General Public License for more details.
  12
  13    You should have received a copy of the GNU General Public License
  14    along with this program; if not, write to the Free Software
  15    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
  16    MA 02110-1301, USA.
  17
  18
  19 **** base64 ********************************************************************
  20
  21    Copyright Volker van Nek, 2013 - 2015
  22
  23    base64 returns a base 64 representation of a string, a non-negative integer
  24    or a list of octets.
  25
  26    base64_decode decodes a base 64 string. The default return value is a string.
  27    An optional argument allows base64_decode to return the corresponding number
  28    or list of octets.
  29
  30    (%i1) base64: base64("foo bar baz");
  31    (%o1)                          Zm9vIGJhciBiYXo=
  32    (%i2) string: base64_decode(base64);
  33    (%o2)                            foo bar baz
  34    (%i3) obase: 16.$
  35    (%i4) integer: base64_decode(base64, 'number);
  36    (%o4)                       666f6f206261722062617a
  37    (%i5) octets: base64_decode(base64, 'list);
  38    (%o5)            [66, 6F, 6F, 20, 62, 61, 72, 20, 62, 61, 7A]
  39
  40    Note that if the string contains umlauts the base64 string is platform
  41    dependent. But in every case the decoded string is equal to the original.
  42
  43 |#
  44
  45 (in-package :maxima)
  46
  47 (eval-when
  48     (:compile-toplevel :execute)
  49   (defvar old-ibase-base64 *read-base*)
  50   (setq *read-base* 10.) )
  51
  52
  53 (defvar *str64* "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
  54
  55
  56 ;; encode :  0 (6bit) --> base64 = *chr64*[0] = 'A' = 65  : number --> character
  57
  58 (defvar *chr64* (make-array 64. :element-type 'character :initial-element #\0))
  59
  60 (do ((i 0 (1+ i)) (ch (coerce *str64* 'list) (cdr ch)))
  61     ((= i 64.))
  62   (setf (char *chr64* i) (car ch)) )
  63
  64
  65 ;; decode :  'A' = 65 --> *num64*[65] = 0 (6bit)  : character --> number
  66
  67 ;; range of *num64* :  '+' = 43 ... 'z' = 122
  68
  69 (defvar *num64* (make-array 123. :element-type 'integer :initial-element -1))
  70
  71 (do ((i 0 (1+ i)))
  72     ((= i 64.))
  73   (setf (svref *num64* (char-code (char *chr64* i))) i) )
  74
  75
  76 (defmfun $base64 (s)
  77   (let (bytes len base64 k b ind)
  78     (cond
  79       ((stringp s)
  80         (setq bytes (string-to-octets s)) )
  81       ((and (integerp s) (>= s 0))
  82         (setq bytes (number-to-octets s)) )
  83       (($listp s)
  84         (setq bytes (cdr s)) )
  85       (t
  86         (gf-merror (intl:gettext
  87           "`base64': Argument must be a string, a non-negative integer or a list of octets." ))))
  88     (setq len (length bytes)
  89           base64 (make-array (* 4. (floor (+ len 2.) 3.)) :element-type 'character :initial-element #\0)
  90           k 0 )
  91     (do ()
  92         ((null bytes))
  93       (setq b `#(,(pop bytes)
  94                  ,(if (null bytes) 0 (pop bytes))
  95                  ,(if (null bytes) 0 (pop bytes)) ))
  96       (setq ind `#(
  97                                                   ,(ash (svref b 0) -2)
  98         ,(logior (logand (ash (svref b 0) 4) #x30) (ash (svref b 1) -4))
  99         ,(logior (logand (ash (svref b 1) 2) #x3c) (ash (svref b 2) -6))
 100                 ,(logand      (svref b 2)    #x3f)                                    ))
 101       (do ((i 0 (1+ i)))
 102           ((= i 4.))
 103         (setf (char base64 k) (char *chr64* (svref ind i)))
 104         (incf k) ))
 105     (setq len (mod len 3))
 106     (unless (= len 0) (setf (char base64 (decf k)) #\=))
 107     (when (= len 1) (setf (char base64 (decf k)) #\=))
 108     (coerce base64 'string) ))
 109
 110
 111 (defmfun $base64_decode (s &optional (rtype '$string))
 112   (let ((err-str "`base64_decode': Argument must be a base64 encoded string."))
 113     (unless (stringp s) (merror err-str))
 114     (let* ((len (length s))
 115            (nrof= (count-if #'(lambda (c) (char= c #\=)) (subseq s (- len 2.))))
 116            (size (- (ash (* 3. len) -2.) nrof=))
 117            (res (make-array size :element-type 'integer :initial-element 0))
 118            (w (make-array 4. :element-type 'integer :initial-element 0))
 119            (bytes (mapcar #'char-code (coerce s 'list))) )
 120       (when (or (> nrof= 2) (/= 0 (logand len #x3))) (merror err-str))
 121       (prog ((j 0))
 122         a
 123         (setf (svref w 0) (svref *num64* (pop bytes))
 124               (svref w 1) (svref *num64* (pop bytes)) )
 125         (when (or (= -1 (svref w 0)) (= -1 (svref w 1))) (merror err-str))
 126         (setf (svref res j)
 127                 (logior (logand (ash (svref w 0) 2.) #xff) (ash (svref w 1)  -4.)) )
 128         (when (= (incf j) size) (return))
 129
 130         (setf (svref w 2.) (svref *num64* (pop bytes)))
 131         (when (= -1 (svref w 2.)) (merror err-str))
 132         (setf (svref res j)
 133                 (logior (logand (ash (svref w 1) 4.) #xff) (ash (svref w 2.) -2.)) )
 134
 135         (when (= (incf j) size) (return))
 136
 137         (setf (svref w 3.) (svref *num64* (pop bytes)))
 138         (when (= -1 (svref w 3.)) (merror err-str))
 139         (setf (svref res j)
 140                 (logior (logand (ash (svref w 2.) 6.) #xff)     (svref w 3.)     ) )
 141         (when (= (incf j) size) (return))
 142         (go a) )
 143       (setq res (coerce res 'list))
 144       (cond
 145         ((equal rtype '$list) (cons '(mlist simp) res))
 146         ((equal rtype '$number) (reduce #'(lambda (x y) (logior (ash x 8.) y)) res))
 147         ((equal rtype '$string) (octets-to-string res))
 148         (t
 149           (gf-merror (intl:gettext
 150             "`base64_decode': Optional argument must be 'list, 'number or 'string." )))))))
 151
 152
 153 (eval-when
 154     (:compile-toplevel :execute)
 155   (setq *read-base* old-ibase-base64) )