src.lisp

   1 ;;;; This file implements the Base64 transfer encoding algorithm as
   2 ;;;; defined in RFC 1521 by Borensten & Freed, September 1993.
   3 ;;;; See: http://www.ietf.org/rfc/rfc1521.txt
   4 ;;;;
   5 ;;;; Based on initial public domain code by Juri Pakaste <juri@iki.fi>
   6 ;;;;
   7 ;;;; Extended by Kevin M. Rosenberg <kevin@rosenberg.net>:
   8 ;;;;   - .asd file
   9 ;;;;   - numerous speed optimizations
  10 ;;;;   - conversion to and from integers
  11 ;;;;   - Renamed functions now that supporting integer conversions
  12 ;;;;   - URI-compatible encoding using :uri key
  13 ;;;;
  14 ;;;; Copyright 2002-2003 Kevin M. Rosenberg
  15 ;;;; Permission to use with BSD-style license included in the COPYING file
  16 ;;;;
  17 ;;;; $Id: src.lisp,v 1.3 2003/01/04 06:13:53 kevin Exp $
  18
  19 (defpackage #:base64
  20   (:use #:cl)
  21   (:export #:base64-to-string #:base64-to-integer
  22            #:string-to-base64 #:integer-to-base64))
  23
  24
  25 (in-package #:base64)
  26
  27 (eval-when (:compile-toplevel :load-toplevel :execute)
  28   (defvar *encode-table*
  29     "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
  30   (declaim (type simple-string *encode-table*))
  31
  32   (defvar *uri-encode-table*
  33     "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")
  34   (declaim (type simple-string *uri-encode-table*))
  35
  36   (deftype decode-table () '(simple-array fixnum (256)))
  37
  38   (defvar *decode-table*
  39     (let ((da (make-array 256 :adjustable nil :fill-pointer nil
  40                           :element-type 'fixnum
  41                           :initial-element -1)))
  42       (loop for char of-type character across *encode-table*
  43             for index of-type fixnum from 0 below 64
  44             do (setf (aref da (the fixnum (char-code char))) index))
  45       da))
  46
  47   (defvar *uri-decode-table*
  48     (let ((da (make-array 256 :adjustable nil :fill-pointer nil
  49                           :element-type 'fixnum
  50                           :initial-element -1)))
  51       (loop
  52        for char of-type character across *uri-encode-table*
  53        for index of-type fixnum from 0 below 64
  54        do (setf (aref da (the fixnum (char-code char))) index))
  55       da))
  56
  57   (declaim (type decode-table *decode-table* *uri-decode-table*))
  58
  59   (defvar *pad-char* #\=)
  60   (defvar *uri-pad-char* #\.)
  61   (declaim (type character *pad-char* *uri-pad-char*))
  62   )
  63
  64
  65 ;;; Utilities
  66
  67 (defun round-next-multiple (x n)
  68   "Round x up to the next highest multiple of n."
  69   (declare (fixnum n)
  70            (optimize (speed 3)))
  71   (let ((remainder (mod x n)))
  72     (declare (fixnum remainder))
  73     (if (zerop remainder)
  74         x
  75         (the fixnum (+ x (the fixnum (- n remainder)))))))
  76
  77 (declaim (inline whitespace-p))
  78 (defun whitespace-p (c)
  79   "Returns T for a whitespace character."
  80   (or (char= c #\Newline) (char= c #\Linefeed)
  81       (char= c #\Return) (char= c #\Space)
  82       (char= c #\Tab)))
  83
  84
  85 ;; Encode routines
  86
  87 (defun string-to-base64 (string &key (uri nil) (columns 0) (stream nil))
  88   "Encode a string array to base64. If columns is > 0, designates
  89 maximum number of columns in a line and the string will be terminated
  90 with a #\Newline."
  91   (declare (string string)
  92            (fixnum columns)
  93            (optimize (speed 3)))
  94   (let ((pad (if uri *uri-pad-char* *pad-char*))
  95         (encode-table (if uri *uri-encode-table* *encode-table*)))
  96     (declare (simple-string encode-table)
  97              (character pad))
  98     (let* ((string-length (length string))
  99            (complete-group-count (truncate string-length 3))
 100            (remainder (nth-value 1 (truncate string-length 3)))
 101            (padded-length (+ remainder
 102                              (* 4 complete-group-count)))
 103            (num-lines (if (plusp columns)
 104                           (truncate (+ padded-length (1- columns)) columns)
 105                           0))
 106            (num-breaks (if (plusp num-lines)
 107                            (1- num-lines)
 108                            0))
 109            (strlen (+ padded-length num-breaks))
 110            (result (unless stream
 111                      (make-string strlen)))
 112            (col (if (plusp columns)
 113                     0
 114                     (1+ padded-length)))
 115            (ioutput 0))
 116       (declare (fixnum string-length padded-length col ioutput)
 117                (simple-string result))
 118       (labels ((output-char (ch)
 119                  (when (= col columns)
 120                    (if stream
 121                        (write #\Newline stream)
 122                        (progn
 123                          (setf (schar result ioutput) #\Newline)
 124                          (incf ioutput)))
 125                    (setq col 0))
 126                  (incf col)
 127                  (if stream
 128                      (write ch stream)
 129                      (progn
 130                        (setf (schar result ioutput) ch)
 131                        (incf ioutput))))
 132              (output-group (svalue chars)
 133                (output-char
 134                 (schar encode-table
 135                        (the fixnum
 136                          (logand #x3f
 137                                  (the fixnum (ash svalue -18))))))
 138                (output-char
 139                 (schar encode-table
 140                        (the fixnum
 141                          (logand #x3f
 142                                  (the fixnum (ash svalue -12))))))
 143                (if (> chars 2)
 144                    (output-char
 145                     (schar encode-table
 146                            (the fixnum
 147                              (logand #x3f
 148                                      (the fixnum (ash svalue -6))))))
 149                    (output-char pad))
 150                (if (> chars 3)
 151                    (output-char
 152                     (schar encode-table
 153                            (the fixnum
 154                              (logand #x3f svalue))))
 155                    (output-char pad))))
 156         (do ((igroup 0 (1+ igroup))
 157              (isource 0 (+ isource 3))
 158              svalue)
 159             ((= igroup complete-group-count)
 160              (case remainder
 161                (2
 162                 (setq svalue
 163                       (the fixnum
 164                         (+
 165                          (the fixnum
 166                            (ash (char-code (the character
 167                                              (char string isource))) 16))
 168                          (the fixnum
 169                            (ash (char-code (the character
 170                                              (char string (1+ isource)))) 8)))))
 171                 (output-group svalue 3))
 172                (1
 173                 (setq svalue
 174                       (the fixnum
 175                         (char-code (the character
 176                                      (char string isource)))))
 177                 (output-group svalue 2)))
 178              result)
 179           (declare (fixnum igroup isource svalue))
 180           (setq svalue
 181                 (the fixnum
 182                   (+
 183                    (the fixnum
 184                      (ash (char-code (the character
 185                                        (char string isource))) 16))
 186                    (the fixnum
 187                      (ash (char-code (the character
 188                                        (char string (1+ isource)))) 8))
 189                    (the fixnum
 190                      (char-code (the character
 191                                   (char string (+ 2 isource))))))))
 192           (output-group svalue 4))))))
 193
 194
 195 (defun integer-to-base64 (input &key (uri nil) (columns 0) (stream nil))
 196   (if stream
 197       (integer-to-base64-stream input stream :uri uri :columns columns)
 198       (integer-to-base64-string input :uri uri :columns columns)))
 199
 200 (defun integer-to-base64-string (input &key (uri nil) (columns 0))
 201   "Encode an integer to base64 format."
 202   (declare (integer input)
 203            (fixnum columns)
 204            (optimize (speed 3)))
 205   (let ((pad (if uri *uri-pad-char* *pad-char*))
 206         (encode-table (if uri *uri-encode-table* *encode-table*)))
 207     (declare (simple-string encode-table)
 208              (character pad))
 209     (let* ((input-bits (integer-length input))
 210            (byte-bits (round-next-multiple input-bits 8))
 211            (padded-bits (round-next-multiple byte-bits 6))
 212            (remainder-padding (mod padded-bits 24))
 213            (padding-bits (if (zerop remainder-padding)
 214                              0
 215                              (- 24 remainder-padding)))
 216            (padding-chars (/ padding-bits 6))
 217            (padded-length (/ (+ padded-bits padding-bits) 6))
 218            (last-line-len (if (plusp columns)
 219                               (- padded-length (* columns
 220                                                   (truncate
 221                                                    padded-length columns)))
 222                               0))
 223            (num-lines (if (plusp columns)
 224                           (truncate (+ padded-length (1- columns)) columns)
 225                           0))
 226            (num-breaks (if (plusp num-lines)
 227                            (1- num-lines)
 228                            0))
 229            (strlen (+ padded-length num-breaks))
 230            (last-char (1- strlen))
 231            (str (make-string strlen))
 232            (col (if (zerop last-line-len)
 233                     (1- columns)
 234                     (1- last-line-len))))
 235       (declare (fixnum padded-length num-lines col last-char
 236                        padding-chars last-line-len))
 237       (unless (plusp columns)
 238         (setq col -1)) ;; set to flag to optimize in loop
 239
 240       (dotimes (i padding-chars)
 241         (declare (fixnum i))
 242         (setf (schar str (the fixnum (- last-char i))) pad))
 243
 244       (do* ((strpos (- last-char padding-chars) (1- strpos))
 245             (int (ash input (/ padding-bits 3))))
 246            ((minusp strpos)
 247             str)
 248         (declare (fixnum strpos) (integer int))
 249         (cond
 250           ((zerop col)
 251            (setf (schar str strpos) #\Newline)
 252            (setq col columns))
 253           (t
 254            (setf (schar str strpos)
 255                  (schar encode-table (the fixnum (logand int #x3f))))
 256            (setq int (ash int -6))
 257            (decf col)))))))
 258
 259 (defun integer-to-base64-stream (input stream &key (uri nil) (columns 0))
 260   "Encode an integer to base64 format."
 261   (declare (integer input)
 262            (fixnum columns)
 263            (optimize (speed 3)))
 264   (let ((pad (if uri *uri-pad-char* *pad-char*))
 265         (encode-table (if uri *uri-encode-table* *encode-table*)))
 266     (declare (simple-string encode-table)
 267              (character pad))
 268     (let* ((input-bits (integer-length input))
 269            (byte-bits (round-next-multiple input-bits 8))
 270            (padded-bits (round-next-multiple byte-bits 6))
 271            (remainder-padding (mod padded-bits 24))
 272            (padding-bits (if (zerop remainder-padding)
 273                              0
 274                              (- 24 remainder-padding)))
 275            (padding-chars (/ padding-bits 6))
 276            (padded-length (/ (+ padded-bits padding-bits) 6))
 277            (strlen padded-length)
 278            (nonpad-chars (- strlen padding-chars))
 279            (last-nonpad-char (1- nonpad-chars))
 280            (str (make-string strlen)))
 281       (declare (fixnum padded-length last-nonpad-char))
 282       (do* ((strpos 0 (1+ strpos))
 283             (int (ash input (/ padding-bits 3)) (ash int -6))
 284             (6bit-value (logand int #x3f) (logand int #x3f)))
 285            ((= strpos nonpad-chars)
 286             (let ((col 0))
 287               (declare (fixnum col))
 288               (dotimes (i nonpad-chars)
 289                 (declare (fixnum i))
 290                 (write-char (schar str i) stream)
 291                 (when (plusp columns)
 292                   (incf col)
 293                   (when (= col columns)
 294                     (write-char #\Newline stream)
 295                     (setq col 0))))
 296               (dotimes (ipad padding-chars)
 297                 (declare (fixnum ipad))
 298                 (write-char pad stream)
 299                 (when (plusp columns)
 300                   (incf col)
 301                   (when (= col columns)
 302                     (write-char #\Newline stream)
 303                     (setq col 0)))))
 304             stream)
 305         (declare (fixnum 6bit-value strpos)
 306                  (integer int))
 307         (setf (schar str (- last-nonpad-char strpos))
 308               (schar encode-table 6bit-value))
 309         ))))
 310
 311 ;;; Decoding
 312
 313 (defun base64-to-string (string &key (uri nil))
 314   "Decode a base64 string to a string array."
 315   (declare (string string)
 316            (optimize (speed 3)))
 317   (let ((pad (if uri *uri-pad-char* *pad-char*))
 318         (decode-table (if uri *uri-decode-table* *decode-table*)))
 319     (declare (type decode-table decode-table)
 320              (character pad))
 321     (let ((result (make-string (* 3 (truncate (length string) 4))))
 322           (ridx 0))
 323       (declare (simple-string result)
 324                (fixnum ridx))
 325       (loop
 326          for char of-type character across string
 327          for svalue of-type fixnum = (aref decode-table (the fixnum (char-code char)))
 328          with bitstore of-type fixnum = 0
 329          with bitcount of-type fixnum = 0
 330          do
 331            (cond
 332              ((>= svalue 0)
 333               (setf bitstore (logior
 334                               (the fixnum (ash bitstore 6))
 335                               svalue))
 336               (incf bitcount 6)
 337               (when (>= bitcount 8)
 338                 (decf bitcount 8)
 339                 (setf (char result ridx)
 340                       (code-char (the fixnum
 341                                    (logand
 342                                     (the fixnum
 343                                       (ash bitstore
 344                                            (the fixnum (- bitcount))))
 345                                     #xFF))))
 346                 (incf ridx)
 347                 (setf bitstore (the fixnum (logand bitstore #xFF)))))
 348              ((char= char pad)
 349               ;; Could add checks to make sure padding is correct
 350               ;; Currently, padding is ignored
 351               )
 352              ((whitespace-p char)
 353               ;; Ignore whitespace
 354               )
 355              ((minusp svalue)
 356               (warn "Bad character ~W in base64 decode" char))
 357 ))
 358       (subseq result 0 ridx))))
 359
 360
 361 (defun base64-to-integer (string &key (uri nil))
 362   "Decodes a base64 string to an integer"
 363   (declare (string string)
 364            (optimize (speed 3)))
 365   (let ((pad (if uri *uri-pad-char* *pad-char*))
 366         (decode-table (if uri *uri-decode-table* *decode-table*)))
 367     (declare (type decode-table decode-table)
 368              (character pad))
 369     (let ((value 0))
 370       (declare (integer value))
 371       (loop
 372          for char of-type character across string
 373          for svalue of-type fixnum =
 374            (aref decode-table (the fixnum (char-code char)))
 375          do
 376            (cond
 377              ((>= svalue 0)
 378               (setq value (+ svalue (ash value 6))))
 379              ((char= char pad)
 380               (setq value (ash value -2)))
 381              ((whitespace-p char)
 382               ; ignore whitespace
 383               )
 384              ((minusp svalue)
 385               (warn "Bad character ~W in base64 decode" char))))
 386       value)))