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: src.lisp,v 1.4 2003/01/04 08:27:41 kevin Exp $
21 (:export #:base64-to-string #:base64-to-integer
22 #:string-to-base64 #:integer-to-base64))
27 (eval-when (:compile-toplevel :load-toplevel :execute)
28 (defvar *encode-table*
29 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
30 (declaim (type simple-string *encode-table*))
32 (defvar *uri-encode-table*
33 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")
34 (declaim (type simple-string *uri-encode-table*))
36 (deftype decode-table () '(simple-array fixnum (256)))
38 (defvar *decode-table*
39 (let ((da (make-array 256 :adjustable nil :fill-pointer nil
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))
47 (defvar *uri-decode-table*
48 (let ((da (make-array 256 :adjustable nil :fill-pointer nil
50 :initial-element -1)))
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))
57 (declaim (type decode-table *decode-table* *uri-decode-table*))
59 (defvar *pad-char* #\=)
60 (defvar *uri-pad-char* #\.)
61 (declaim (type character *pad-char* *uri-pad-char*))
67 (defun round-next-multiple (x n)
68 "Round x up to the next highest multiple of n."
71 (let ((remainder (mod x n)))
72 (declare (fixnum remainder))
75 (the fixnum (+ x (the fixnum (- n remainder)))))))
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)
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
91 (declare (string string)
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)
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)
106 (num-breaks (if (plusp num-lines)
111 (+ padded-length num-breaks)))
112 (result (make-string strlen))
113 (col (if (plusp columns)
117 (declare (fixnum string-length padded-length col ioutput)
118 (simple-string result))
119 (labels ((output-char (ch)
120 (when (= col columns)
122 (write-char #\Newline stream)
124 (setf (schar result ioutput) #\Newline)
129 (write-char ch stream)
131 (setf (schar result ioutput) ch)
133 (output-group (svalue chars)
134 (declare (fixnum svalue chars))
139 (the fixnum (ash svalue -18))))))
144 (the fixnum (ash svalue -12))))))
150 (the fixnum (ash svalue -6))))))
156 (logand #x3f svalue))))
158 (do ((igroup 0 (1+ igroup))
159 (isource 0 (+ isource 3))
161 ((= igroup complete-group-count)
168 (ash (char-code (the character
169 (char string isource))) 16))
171 (ash (char-code (the character
172 (char string (1+ isource)))) 8)))))
173 (output-group svalue 3))
177 (char-code (the character
178 (char string isource)))))
179 (output-group svalue 2)))
181 (declare (fixnum igroup isource svalue))
186 (ash (char-code (the character
187 (char string isource))) 16))
189 (ash (char-code (the character
190 (char string (1+ isource)))) 8))
192 (char-code (the character
193 (char string (+ 2 isource))))))))
194 (output-group svalue 4))))))
197 (defun integer-to-base64 (input &key (uri nil) (columns 0) (stream nil))
199 (integer-to-base64-stream input stream :uri uri :columns columns)
200 (integer-to-base64-string input :uri uri :columns columns)))
202 (defun integer-to-base64-string (input &key (uri nil) (columns 0))
203 "Encode an integer to base64 format."
204 (declare (integer input)
206 (optimize (speed 3)))
207 (let ((pad (if uri *uri-pad-char* *pad-char*))
208 (encode-table (if uri *uri-encode-table* *encode-table*)))
209 (declare (simple-string encode-table)
211 (let* ((input-bits (integer-length input))
212 (byte-bits (round-next-multiple input-bits 8))
213 (padded-bits (round-next-multiple byte-bits 6))
214 (remainder-padding (mod padded-bits 24))
215 (padding-bits (if (zerop remainder-padding)
217 (- 24 remainder-padding)))
218 (padding-chars (/ padding-bits 6))
219 (padded-length (/ (+ padded-bits padding-bits) 6))
220 (last-line-len (if (plusp columns)
221 (- padded-length (* columns
223 padded-length columns)))
225 (num-lines (if (plusp columns)
226 (truncate (+ padded-length (1- columns)) columns)
228 (num-breaks (if (plusp num-lines)
231 (strlen (+ padded-length num-breaks))
232 (last-char (1- strlen))
233 (str (make-string strlen))
234 (col (if (zerop last-line-len)
236 (1- last-line-len))))
237 (declare (fixnum padded-length num-lines col last-char
238 padding-chars last-line-len))
239 (unless (plusp columns)
240 (setq col -1)) ;; set to flag to optimize in loop
242 (dotimes (i padding-chars)
244 (setf (schar str (the fixnum (- last-char i))) pad))
246 (do* ((strpos (- last-char padding-chars) (1- strpos))
247 (int (ash input (/ padding-bits 3))))
250 (declare (fixnum strpos) (integer int))
253 (setf (schar str strpos) #\Newline)
256 (setf (schar str strpos)
257 (schar encode-table (the fixnum (logand int #x3f))))
258 (setq int (ash int -6))
261 (defun integer-to-base64-stream (input stream &key (uri nil) (columns 0))
262 "Encode an integer to base64 format."
263 (declare (integer input)
265 (optimize (speed 3)))
266 (let ((pad (if uri *uri-pad-char* *pad-char*))
267 (encode-table (if uri *uri-encode-table* *encode-table*)))
268 (declare (simple-string encode-table)
270 (let* ((input-bits (integer-length input))
271 (byte-bits (round-next-multiple input-bits 8))
272 (padded-bits (round-next-multiple byte-bits 6))
273 (remainder-padding (mod padded-bits 24))
274 (padding-bits (if (zerop remainder-padding)
276 (- 24 remainder-padding)))
277 (padding-chars (/ padding-bits 6))
278 (padded-length (/ (+ padded-bits padding-bits) 6))
279 (strlen padded-length)
280 (nonpad-chars (- strlen padding-chars))
281 (last-nonpad-char (1- nonpad-chars))
282 (str (make-string strlen)))
283 (declare (fixnum padded-length last-nonpad-char))
284 (do* ((strpos 0 (1+ strpos))
285 (int (ash input (/ padding-bits 3)) (ash int -6))
286 (6bit-value (logand int #x3f) (logand int #x3f)))
287 ((= strpos nonpad-chars)
289 (declare (fixnum col))
290 (dotimes (i nonpad-chars)
292 (write-char (schar str i) stream)
293 (when (plusp columns)
295 (when (= col columns)
296 (write-char #\Newline stream)
298 (dotimes (ipad padding-chars)
299 (declare (fixnum ipad))
300 (write-char pad stream)
301 (when (plusp columns)
303 (when (= col columns)
304 (write-char #\Newline stream)
307 (declare (fixnum 6bit-value strpos)
309 (setf (schar str (- last-nonpad-char strpos))
310 (schar encode-table 6bit-value))
315 (defun base64-to-string (string &key (uri nil))
316 "Decode a base64 string to a string array."
317 (declare (string string)
318 (optimize (speed 3)))
319 (let ((pad (if uri *uri-pad-char* *pad-char*))
320 (decode-table (if uri *uri-decode-table* *decode-table*)))
321 (declare (type decode-table decode-table)
323 (let ((result (make-string (* 3 (truncate (length string) 4))))
325 (declare (simple-string result)
328 for char of-type character across string
329 for svalue of-type fixnum = (aref decode-table (the fixnum (char-code char)))
330 with bitstore of-type fixnum = 0
331 with bitcount of-type fixnum = 0
335 (setf bitstore (logior
336 (the fixnum (ash bitstore 6))
339 (when (>= bitcount 8)
341 (setf (char result ridx)
342 (code-char (the fixnum
346 (the fixnum (- bitcount))))
349 (setf bitstore (the fixnum (logand bitstore #xFF)))))
351 ;; Could add checks to make sure padding is correct
352 ;; Currently, padding is ignored
358 (warn "Bad character ~W in base64 decode" char))
360 (subseq result 0 ridx))))
363 (defun base64-to-integer (string &key (uri nil))
364 "Decodes a base64 string to an integer"
365 (declare (string string)
366 (optimize (speed 3)))
367 (let ((pad (if uri *uri-pad-char* *pad-char*))
368 (decode-table (if uri *uri-decode-table* *decode-table*)))
369 (declare (type decode-table decode-table)
372 (declare (integer value))
374 for char of-type character across string
375 for svalue of-type fixnum =
376 (aref decode-table (the fixnum (char-code char)))
380 (setq value (+ svalue (ash value 6))))
382 (setq value (ash value -2)))
387 (warn "Bad character ~W in base64 decode" char))))