base64.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: base64.lisp,v 1.1 2002/12/29 06:08:15 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 (in-package #:base64)
  25
  26 (eval-when (:compile-toplevel :load-toplevel :execute)
  27   (defparameter *encode-table*
  28     "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
  29   (declaim (type simple-string *encode-table*))
  30
  31   (defparameter *uri-encode-table*
  32     "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")
  33   (declaim (type simple-string *uri-encode-table*))
  34
  35   (deftype decode-table () '(simple-array fixnum (256)))
  36
  37   (defparameter *decode-table*
  38     (let ((da (make-array 256 :adjustable nil :fill-pointer nil
  39                           :element-type 'fixnum
  40                           :initial-element -1)))
  41       (loop for char of-type character across *encode-table*
  42             for index of-type fixnum from 0 below 64
  43             do (setf (aref da (the fixnum (char-code char))) index))
  44       da))
  45
  46   (defparameter *uri-decode-table*
  47     (let ((da (make-array 256 :adjustable nil :fill-pointer nil
  48                           :element-type 'fixnum
  49                           :initial-element -1)))
  50       (loop
  51        for char of-type character across *uri-encode-table*
  52        for index of-type fixnum from 0 below 64
  53        do (setf (aref da (the fixnum (char-code char))) index))
  54       da))
  55
  56   (declaim (type decode-table *decode-table* *uri-decode-table*))
  57
  58   (defparameter *pad-char* #\=)
  59   (defparameter *uri-pad-char* #\.))
  60
  61 (defun string-to-base64 (string &key (uri nil))
  62   "Encode a string array to base64."
  63   (declare (string string)
  64            (optimize (speed 3)))
  65   (let ((pad (if uri *uri-pad-char* *pad-char*))
  66         (encode-table (if uri *uri-encode-table* *encode-table*)))
  67     (declare (simple-string encode-table)
  68              (character pad))
  69     (let* ((string-length (length string))
  70            (result (make-string
  71                     (* 4 (truncate (/ (+ 2 string-length) 3))))))
  72       (declare (fixnum string-length)
  73                (simple-string result))
  74       (do ((sidx 0 (the fixnum (+ sidx 3)))
  75            (didx 0 (the fixnum (+ didx 4)))
  76            (chars 2 2)
  77            (value 0 0))
  78           ((>= sidx string-length) t)
  79         (declare (fixnum sidx didx chars value))
  80         (setf value (ash (logand #xFF (char-code (char string sidx))) 8))
  81         (dotimes (n 2)
  82           (declare (fixnum n))
  83           (when (< (the fixnum (+ sidx n 1)) string-length)
  84             (setf value
  85                   (logior value
  86                           (the fixnum
  87                             (logand #xFF
  88                                     (the fixnum
  89                                       (char-code (char string
  90                                                         (the fixnum
  91                                                           (+ sidx n 1)))))))))
  92             (incf chars))
  93           (when (zerop n)
  94             (setf value (the fixnum (ash value 8)))))
  95         (setf (schar result (the fixnum (+ didx 3)))
  96               (if (> chars 3)
  97                   (schar encode-table (logand value #x3F))
  98                   pad))
  99         (setf value (the fixnum (ash value -6)))
 100         (setf (schar result (the fixnum (+ didx 2)))
 101               (if (> chars 2)
 102                   (schar encode-table (logand value #x3F))
 103                   pad))
 104         (setf value (the fixnum (ash value -6)))
 105         (setf (schar result (the fixnum (1+ didx)))
 106               (schar encode-table (logand value #x3F)))
 107         (setf value (the fixnum (ash value -6)))
 108         (setf (schar result didx)
 109               (schar encode-table (logand value #x3F))))
 110       result)))
 111
 112
 113 (defun round-next-multiple (x n)
 114   "Round x up to the next highest multiple of n"
 115   (declare (fixnum n)
 116            (optimize (speed 3)))
 117   (let ((remainder (mod x n)))
 118     (declare (fixnum remainder))
 119     (if (zerop remainder)
 120         x
 121         (the fixnum (+ x (the fixnum (- n remainder)))))))
 122
 123 (defun integer-to-base64 (input &key (uri nil))
 124   "Encode an integer to base64 format."
 125   (declare (integer input)
 126            (optimize (speed 3)))
 127   (let ((pad (if uri *uri-pad-char* *pad-char*))
 128         (encode-table (if uri *uri-encode-table* *encode-table*)))
 129     (declare (simple-string encode-table)
 130              (character pad))
 131     (do* ((input-bits (integer-length input))
 132           (byte-bits (round-next-multiple input-bits 8))
 133           (padded-bits (round-next-multiple byte-bits 6))
 134           (remainder-padding (mod padded-bits 24))
 135           (padding-bits (if (zerop remainder-padding)
 136                             0
 137                             (- 24 remainder-padding)))
 138           (strlen (/ (+ padded-bits padding-bits) 6))
 139           (padding-chars (/ padding-bits 6))
 140           (nonpad-chars (- strlen padding-chars))
 141           (last-nonpad-char (1- nonpad-chars))
 142           (str (make-string strlen))
 143           (strpos 0 (1+ strpos))
 144           (int (ash input (/ padding-bits 3)) (ash int -6))
 145           (6bit-value (logand int #x3f) (logand int #x3f)))
 146          ((= strpos nonpad-chars)
 147           (dotimes (ipad padding-chars)
 148             (setf (schar str strpos) pad)
 149             (incf strpos))
 150           str)
 151       (declare (fixnum 6bit-value strpos strlen last-nonpad-char)
 152                (integer int))
 153       (setf (schar str (the fixnum (- last-nonpad-char strpos)))
 154             (schar encode-table 6bit-value)))))
 155
 156 ;;; Decoding
 157
 158 (defun base64-to-string (string &key (uri nil))
 159   "Decode a base64 string to a string array."
 160   (declare (string string)
 161            (optimize (speed 3)))
 162   (let ((pad (if uri *uri-pad-char* *pad-char*))
 163         (decode-table (if uri *uri-decode-table* *decode-table*)))
 164     (declare (type decode-table decode-table)
 165              (character pad))
 166     (let ((result (make-string (* 3 (truncate (/ (length string) 4)))))
 167           (ridx 0))
 168       (declare (simple-string result)
 169                (fixnum ridx))
 170       (loop
 171          for char of-type character across string
 172          for svalue of-type fixnum = (aref decode-table (the fixnum (char-code char)))
 173          with bitstore of-type fixnum = 0
 174          with bitcount of-type fixnum = 0
 175          do
 176            (cond
 177              ((char= char pad)
 178               ;; Could add checks to make sure padding is correct
 179               ;; Currently, padding is ignored
 180               )
 181              ((minusp svalue)
 182               (warn "Bad character ~W in base64 decode" char))
 183              (t
 184               (setf bitstore (logior
 185                               (the fixnum (ash bitstore 6))
 186                               svalue))
 187               (incf bitcount 6)
 188               (when (>= bitcount 8)
 189                 (decf bitcount 8)
 190                 (setf (char result ridx)
 191                       (code-char (the fixnum
 192                                    (logand
 193                                     (the fixnum
 194                                       (ash bitstore
 195                                            (the fixnum (- bitcount))))
 196                                     #xFF))))
 197                 (incf ridx)
 198                 (setf bitstore (the fixnum (logand bitstore #xFF)))))))
 199       (subseq result 0 ridx))))
 200
 201
 202 (defun base64-to-integer (string &key (uri nil))
 203   "Decodes a base64 string to an integer"
 204   (declare (string string)
 205            (optimize (speed 3)))
 206   (let ((pad (if uri *uri-pad-char* *pad-char*))
 207         (decode-table (if uri *uri-decode-table* *decode-table*)))
 208     (declare (type decode-table decode-table)
 209              (character pad))
 210     (let ((value 0))
 211       (declare (integer value))
 212       (loop
 213          for char of-type character across string
 214          for svalue of-type fixnum =
 215            (aref decode-table (the fixnum (char-code char)))
 216          do
 217            (cond
 218              ((char= char pad)
 219               (setq value (the fixnum (ash value -2))))
 220              ((minusp svalue)
 221               (warn "Bad character ~W in base64 decode" char))
 222              (t
 223               (setq value (the fixnum
 224                             (+ svalue (the fixnum (ash value 6))))))))
 225       value)))