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