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
5 ;;;; Based on initial public domain code by Juri Pakaste <juri@iki.fi>
7 ;;;; Extended by Kevin M. Rosenberg <kevin@rosenberg.net>:
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
14 ;;;; Copyright 2002-2003 Kevin M. Rosenberg
15 ;;;; Permission to use with BSD-style license included in the COPYING file
17 ;;;; $Id: base64.lisp,v 1.2 2002/12/29 06:11:24 kevin Exp $
21 (:export #:base64-to-string #:base64-to-integer
22 #:string-to-base64 #:integer-to-base64))
26 (eval-when (:compile-toplevel :load-toplevel :execute)
27 (defvar *encode-table*
28 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
29 (declaim (type simple-string *encode-table*))
31 (defvar *uri-encode-table*
32 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")
33 (declaim (type simple-string *uri-encode-table*))
35 (deftype decode-table () '(simple-array fixnum (256)))
37 (defvar *decode-table*
38 (let ((da (make-array 256 :adjustable nil :fill-pointer nil
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))
46 (defvar *uri-decode-table*
47 (let ((da (make-array 256 :adjustable nil :fill-pointer nil
49 :initial-element -1)))
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))
56 (declaim (type decode-table *decode-table* *uri-decode-table*))
58 (defvar *pad-char* #\=)
59 (defvar *uri-pad-char* #\.)
60 (declaim (type character *pad-char* *uri-pad-char*))
63 (defun string-to-base64 (string &key (uri nil))
64 "Encode a string array to base64."
65 (declare (string string)
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)
71 (let* ((string-length (length 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)))
80 ((>= sidx string-length) t)
81 (declare (fixnum sidx didx chars value))
82 (setf value (ash (logand #xFF (char-code (char string sidx))) 8))
85 (when (< (the fixnum (+ sidx n 1)) string-length)
91 (char-code (char string
96 (setf value (the fixnum (ash value 8)))))
97 (setf (schar result (the fixnum (+ didx 3)))
99 (schar encode-table (logand value #x3F))
101 (setf value (the fixnum (ash value -6)))
102 (setf (schar result (the fixnum (+ didx 2)))
104 (schar encode-table (logand value #x3F))
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))))
115 (defun round-next-multiple (x n)
116 "Round x up to the next highest multiple of n"
118 (optimize (speed 3)))
119 (let ((remainder (mod x n)))
120 (declare (fixnum remainder))
121 (if (zerop remainder)
123 (the fixnum (+ x (the fixnum (- n remainder)))))))
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)
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)
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)
153 (declare (fixnum 6bit-value strpos strlen last-nonpad-char)
155 (setf (schar str (the fixnum (- last-nonpad-char strpos)))
156 (schar encode-table 6bit-value)))))
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)
168 (let ((result (make-string (* 3 (truncate (/ (length string) 4)))))
170 (declare (simple-string result)
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
180 ;; Could add checks to make sure padding is correct
181 ;; Currently, padding is ignored
184 (warn "Bad character ~W in base64 decode" char))
186 (setf bitstore (logior
187 (the fixnum (ash bitstore 6))
190 (when (>= bitcount 8)
192 (setf (char result ridx)
193 (code-char (the fixnum
197 (the fixnum (- bitcount))))
200 (setf bitstore (the fixnum (logand bitstore #xFF)))))))
201 (subseq result 0 ridx))))
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)
213 (declare (integer value))
215 for char of-type character across string
216 for svalue of-type fixnum =
217 (aref decode-table (the fixnum (char-code char)))
221 (setq value (the fixnum (ash value -2))))
223 (warn "Bad character ~W in base64 decode" char))
225 (setq value (the fixnum
226 (+ svalue (the fixnum (ash value 6))))))))