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.4 2003/01/04 08:27:41 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 (if stream
 110                        0
 111                        (+ padded-length num-breaks)))
 112            (result (make-string strlen))
 113            (col (if (plusp columns)
 114                     0
 115                     (1+ padded-length)))
 116            (ioutput 0))
 117       (declare (fixnum string-length padded-length col ioutput)
 118                (simple-string result))
 119       (labels ((output-char (ch)
 120                  (when (= col columns)
 121                    (if stream
 122                        (write-char #\Newline stream)
 123                        (progn
 124                          (setf (schar result ioutput) #\Newline)
 125                          (incf ioutput)))
 126                    (setq col 0))
 127                  (incf col)
 128                  (if stream
 129                      (write-char ch stream)
 130                      (progn
 131                        (setf (schar result ioutput) ch)
 132                        (incf ioutput))))
 133              (output-group (svalue chars)
 134                (declare (fixnum svalue chars))
 135                (output-char
 136                 (schar encode-table
 137                        (the fixnum
 138                          (logand #x3f
 139                                  (the fixnum (ash svalue -18))))))
 140                (output-char
 141                 (schar encode-table
 142                        (the fixnum
 143                          (logand #x3f
 144                                  (the fixnum (ash svalue -12))))))
 145                (if (> chars 2)
 146                    (output-char
 147                     (schar encode-table
 148                            (the fixnum
 149                              (logand #x3f
 150                                      (the fixnum (ash svalue -6))))))
 151                    (output-char pad))
 152                (if (> chars 3)
 153                    (output-char
 154                     (schar encode-table
 155                            (the fixnum
 156                              (logand #x3f svalue))))
 157                    (output-char pad))))
 158         (do ((igroup 0 (1+ igroup))
 159              (isource 0 (+ isource 3))
 160              (svalue 0))
 161             ((= igroup complete-group-count)
 162              (case remainder
 163                (2
 164                 (setq svalue
 165                       (the fixnum
 166                         (+
 167                          (the fixnum
 168                            (ash (char-code (the character
 169                                              (char string isource))) 16))
 170                          (the fixnum
 171                            (ash (char-code (the character
 172                                              (char string (1+ isource)))) 8)))))
 173                 (output-group svalue 3))
 174                (1
 175                 (setq svalue
 176                       (the fixnum
 177                         (char-code (the character
 178                                      (char string isource)))))
 179                 (output-group svalue 2)))
 180              result)
 181           (declare (fixnum igroup isource svalue))
 182           (setq svalue
 183                 (the fixnum
 184                   (+
 185                    (the fixnum
 186                      (ash (char-code (the character
 187                                        (char string isource))) 16))
 188                    (the fixnum
 189                      (ash (char-code (the character
 190                                        (char string (1+ isource)))) 8))
 191                    (the fixnum
 192                      (char-code (the character
 193                                   (char string (+ 2 isource))))))))
 194           (output-group svalue 4))))))
 195
 196
 197 (defun integer-to-base64 (input &key (uri nil) (columns 0) (stream nil))
 198   (if stream
 199       (integer-to-base64-stream input stream :uri uri :columns columns)
 200       (integer-to-base64-string input :uri uri :columns columns)))
 201
 202 (defun integer-to-base64-string (input &key (uri nil) (columns 0))
 203   "Encode an integer to base64 format."
 204   (declare (integer input)
 205            (fixnum columns)
 206            (optimize (speed 3)))
 207   (let ((pad (if uri *uri-pad-char* *pad-char*))
 208         (encode-table (if uri *uri-encode-table* *encode-table*)))
 209     (declare (simple-string encode-table)
 210              (character pad))
 211     (let* ((input-bits (integer-length input))
 212            (byte-bits (round-next-multiple input-bits 8))
 213            (padded-bits (round-next-multiple byte-bits 6))
 214            (remainder-padding (mod padded-bits 24))
 215            (padding-bits (if (zerop remainder-padding)
 216                              0
 217                              (- 24 remainder-padding)))
 218            (padding-chars (/ padding-bits 6))
 219            (padded-length (/ (+ padded-bits padding-bits) 6))
 220            (last-line-len (if (plusp columns)
 221                               (- padded-length (* columns
 222                                                   (truncate
 223                                                    padded-length columns)))
 224                               0))
 225            (num-lines (if (plusp columns)
 226                           (truncate (+ padded-length (1- columns)) columns)
 227                           0))
 228            (num-breaks (if (plusp num-lines)
 229                            (1- num-lines)
 230                            0))
 231            (strlen (+ padded-length num-breaks))
 232            (last-char (1- strlen))
 233            (str (make-string strlen))
 234            (col (if (zerop last-line-len)
 235                     (1- columns)
 236                     (1- last-line-len))))
 237       (declare (fixnum padded-length num-lines col last-char
 238                        padding-chars last-line-len))
 239       (unless (plusp columns)
 240         (setq col -1)) ;; set to flag to optimize in loop
 241
 242       (dotimes (i padding-chars)
 243         (declare (fixnum i))
 244         (setf (schar str (the fixnum (- last-char i))) pad))
 245
 246       (do* ((strpos (- last-char padding-chars) (1- strpos))
 247             (int (ash input (/ padding-bits 3))))
 248            ((minusp strpos)
 249             str)
 250         (declare (fixnum strpos) (integer int))
 251         (cond
 252           ((zerop col)
 253            (setf (schar str strpos) #\Newline)
 254            (setq col columns))
 255           (t
 256            (setf (schar str strpos)
 257                  (schar encode-table (the fixnum (logand int #x3f))))
 258            (setq int (ash int -6))
 259            (decf col)))))))
 260
 261 (defun integer-to-base64-stream (input stream &key (uri nil) (columns 0))
 262   "Encode an integer to base64 format."
 263   (declare (integer input)
 264            (fixnum columns)
 265            (optimize (speed 3)))
 266   (let ((pad (if uri *uri-pad-char* *pad-char*))
 267         (encode-table (if uri *uri-encode-table* *encode-table*)))
 268     (declare (simple-string encode-table)
 269              (character pad))
 270     (let* ((input-bits (integer-length input))
 271            (byte-bits (round-next-multiple input-bits 8))
 272            (padded-bits (round-next-multiple byte-bits 6))
 273            (remainder-padding (mod padded-bits 24))
 274            (padding-bits (if (zerop remainder-padding)
 275                              0
 276                              (- 24 remainder-padding)))
 277            (padding-chars (/ padding-bits 6))
 278            (padded-length (/ (+ padded-bits padding-bits) 6))
 279            (strlen padded-length)
 280            (nonpad-chars (- strlen padding-chars))
 281            (last-nonpad-char (1- nonpad-chars))
 282            (str (make-string strlen)))
 283       (declare (fixnum padded-length last-nonpad-char))
 284       (do* ((strpos 0 (1+ strpos))
 285             (int (ash input (/ padding-bits 3)) (ash int -6))
 286             (6bit-value (logand int #x3f) (logand int #x3f)))
 287            ((= strpos nonpad-chars)
 288             (let ((col 0))
 289               (declare (fixnum col))
 290               (dotimes (i nonpad-chars)
 291                 (declare (fixnum i))
 292                 (write-char (schar str i) stream)
 293                 (when (plusp columns)
 294                   (incf col)
 295                   (when (= col columns)
 296                     (write-char #\Newline stream)
 297                     (setq col 0))))
 298               (dotimes (ipad padding-chars)
 299                 (declare (fixnum ipad))
 300                 (write-char pad stream)
 301                 (when (plusp columns)
 302                   (incf col)
 303                   (when (= col columns)
 304                     (write-char #\Newline stream)
 305                     (setq col 0)))))
 306             stream)
 307         (declare (fixnum 6bit-value strpos)
 308                  (integer int))
 309         (setf (schar str (- last-nonpad-char strpos))
 310               (schar encode-table 6bit-value))
 311         ))))
 312
 313 ;;; Decoding
 314
 315 (defun base64-to-string (string &key (uri nil))
 316   "Decode a base64 string to a string array."
 317   (declare (string string)
 318            (optimize (speed 3)))
 319   (let ((pad (if uri *uri-pad-char* *pad-char*))
 320         (decode-table (if uri *uri-decode-table* *decode-table*)))
 321     (declare (type decode-table decode-table)
 322              (character pad))
 323     (let ((result (make-string (* 3 (truncate (length string) 4))))
 324           (ridx 0))
 325       (declare (simple-string result)
 326                (fixnum ridx))
 327       (loop
 328          for char of-type character across string
 329          for svalue of-type fixnum = (aref decode-table (the fixnum (char-code char)))
 330          with bitstore of-type fixnum = 0
 331          with bitcount of-type fixnum = 0
 332          do
 333            (cond
 334              ((>= svalue 0)
 335               (setf bitstore (logior
 336                               (the fixnum (ash bitstore 6))
 337                               svalue))
 338               (incf bitcount 6)
 339               (when (>= bitcount 8)
 340                 (decf bitcount 8)
 341                 (setf (char result ridx)
 342                       (code-char (the fixnum
 343                                    (logand
 344                                     (the fixnum
 345                                       (ash bitstore
 346                                            (the fixnum (- bitcount))))
 347                                     #xFF))))
 348                 (incf ridx)
 349                 (setf bitstore (the fixnum (logand bitstore #xFF)))))
 350              ((char= char pad)
 351               ;; Could add checks to make sure padding is correct
 352               ;; Currently, padding is ignored
 353               )
 354              ((whitespace-p char)
 355               ;; Ignore whitespace
 356               )
 357              ((minusp svalue)
 358               (warn "Bad character ~W in base64 decode" char))
 359 ))
 360       (subseq result 0 ridx))))
 361
 362
 363 (defun base64-to-integer (string &key (uri nil))
 364   "Decodes a base64 string to an integer"
 365   (declare (string string)
 366            (optimize (speed 3)))
 367   (let ((pad (if uri *uri-pad-char* *pad-char*))
 368         (decode-table (if uri *uri-decode-table* *decode-table*)))
 369     (declare (type decode-table decode-table)
 370              (character pad))
 371     (let ((value 0))
 372       (declare (integer value))
 373       (loop
 374          for char of-type character across string
 375          for svalue of-type fixnum =
 376            (aref decode-table (the fixnum (char-code char)))
 377          do
 378            (cond
 379              ((>= svalue 0)
 380               (setq value (+ svalue (ash value 6))))
 381              ((char= char pad)
 382               (setq value (ash value -2)))
 383              ((whitespace-p char)
 384               ; ignore whitespace
 385               )
 386              ((minusp svalue)
 387               (warn "Bad character ~W in base64 decode" char))))
 388       value)))