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