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