1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: cl-base64 encoding routines
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Dec 2002
12 ;;;; This file implements the Base64 transfer encoding algorithm as
13 ;;;; defined in RFC 1521 by Borensten & Freed, September 1993.
14 ;;;; See: http://www.ietf.org/rfc/rfc1521.txt
16 ;;;; Based on initial public domain code by Juri Pakaste <juri@iki.fi>
18 ;;;; Copyright 2002-2003 Kevin M. Rosenberg
19 ;;;; Permission to use with BSD-style license included in the COPYING file
20 ;;;; *************************************************************************
22 ;;;; Extended by Kevin M. Rosenberg <kevin@rosenberg.net>:
24 ;;;; - numerous speed optimizations
25 ;;;; - conversion to and from integers
26 ;;;; - Renamed functions now that supporting integer conversions
27 ;;;; - URI-compatible encoding using :uri key
31 (in-package #:cl-base64)
33 (defun round-next-multiple (x n)
34 "Round x up to the next highest multiple of n."
36 (optimize (speed 3) (safety 0) (space 0)))
37 (let ((remainder (mod x n)))
38 (declare (fixnum remainder))
41 (the fixnum (+ x (the fixnum (- n remainder)))))))
43 (defmacro def-*-to-base64-* (input-type output-type)
44 `(defun ,(intern (concatenate 'string (symbol-name input-type)
45 (symbol-name :-to-base64-)
46 (symbol-name output-type)))
48 ,@(when (eq output-type :stream)
50 &key (uri nil) (columns 0))
51 "Encode a string array to base64. If columns is > 0, designates
52 maximum number of columns in a line and the string will be terminated
54 (declare ,@(case input-type
58 '((type (array (unsigned-byte 8) (*)) input))))
60 (optimize (speed 3) (safety 0) (space 0)))
61 (let ((pad (if uri *uri-pad-char* *pad-char*))
62 (encode-table (if uri *uri-encode-table* *encode-table*)))
63 (declare (simple-string encode-table)
65 (let* ((string-length (length input))
66 (complete-group-count (truncate string-length 3))
67 (remainder (nth-value 1 (truncate string-length 3)))
68 (padded-length (* 4 (truncate (+ string-length 2) 3)))
69 ,@(when (eq output-type :string)
70 '((num-lines (if (plusp columns)
71 (truncate (+ padded-length (1- columns)) columns)
73 (num-breaks (if (plusp num-lines)
76 (strlen (+ padded-length num-breaks))
77 (result (make-string strlen))
79 (col (if (plusp columns)
81 (the fixnum (1+ padded-length)))))
82 (declare (fixnum string-length padded-length col
83 ,@(when (eq output-type :string)
85 ,@(when (eq output-type :string)
86 '((simple-string result))))
87 (labels ((output-char (ch)
92 '((write-char #\Newline output)))
94 '((setf (schar result ioutput) #\Newline)
100 '((write-char ch output)))
102 '((setf (schar result ioutput) ch)
104 (output-group (svalue chars)
105 (declare (fixnum svalue chars))
110 (the fixnum (ash svalue -18))))))
115 (the fixnum (ash svalue -12))))))
121 (the fixnum (ash svalue -6))))))
127 (logand #x3f svalue))))
129 (do ((igroup 0 (the fixnum (1+ igroup)))
130 (isource 0 (the fixnum (+ isource 3))))
131 ((= igroup complete-group-count)
141 '(char-code (the character (char input isource))))
143 '(the fixnum (aref input isource))))
149 '(char-code (the character (char input
150 (the fixnum (1+ isource))))))
152 '(the fixnum (aref input (the fixnum
162 '(char-code (the character (char input isource))))
164 '(the fixnum (aref input isource))))
172 (declare (fixnum igroup isource))
181 '(char-code (the character (char input isource))))
183 '(aref input isource))))
190 '(char-code (the character (char input
191 (the fixnum (1+ isource))))))
193 '(aref input (1+ isource)))))
198 '(char-code (the character (char input
199 (the fixnum (+ 2 isource))))))
201 '(aref input (+ 2 isource))))
205 (def-*-to-base64-* :string :string)
206 (def-*-to-base64-* :string :stream)
207 (def-*-to-base64-* :usb8-array :string)
208 (def-*-to-base64-* :usb8-array :stream)
211 (defun integer-to-base64-string (input &key (uri nil) (columns 0))
212 "Encode an integer to base64 format."
213 (declare (integer input)
215 (optimize (speed 3) (space 0) (safety 0)))
216 (let ((pad (if uri *uri-pad-char* *pad-char*))
217 (encode-table (if uri *uri-encode-table* *encode-table*)))
218 (declare (simple-string encode-table)
220 (let* ((input-bits (integer-length input))
221 (byte-bits (round-next-multiple input-bits 8))
222 (padded-bits (round-next-multiple byte-bits 6))
223 (remainder-padding (mod padded-bits 24))
224 (padding-bits (if (zerop remainder-padding)
226 (- 24 remainder-padding)))
227 (padding-chars (/ padding-bits 6))
228 (padded-length (/ (+ padded-bits padding-bits) 6))
229 (last-line-len (if (plusp columns)
230 (- padded-length (* columns
232 padded-length columns)))
234 (num-lines (if (plusp columns)
235 (truncate (+ padded-length (1- columns)) columns)
237 (num-breaks (if (plusp num-lines)
240 (strlen (+ padded-length num-breaks))
241 (last-char (1- strlen))
242 (str (make-string strlen))
243 (col (if (zerop last-line-len)
246 (declare (fixnum padded-length num-lines col last-char
247 padding-chars last-line-len))
248 (unless (plusp columns)
249 (setq col -1)) ;; set to flag to optimize in loop
251 (dotimes (i padding-chars)
253 (setf (schar str (the fixnum (- last-char i))) pad))
255 (do* ((strpos (- last-char padding-chars) (1- strpos))
256 (int (ash input (/ padding-bits 3))))
259 (declare (fixnum strpos) (integer int))
262 (setf (schar str strpos) #\Newline)
265 (setf (schar str strpos)
266 (schar encode-table (the fixnum (logand int #x3f))))
267 (setq int (ash int -6))
270 (defun integer-to-base64-stream (input stream &key (uri nil) (columns 0))
271 "Encode an integer to base64 format."
272 (declare (integer input)
274 (optimize (speed 3) (space 0) (safety 0)))
275 (let ((pad (if uri *uri-pad-char* *pad-char*))
276 (encode-table (if uri *uri-encode-table* *encode-table*)))
277 (declare (simple-string encode-table)
279 (let* ((input-bits (integer-length input))
280 (byte-bits (round-next-multiple input-bits 8))
281 (padded-bits (round-next-multiple byte-bits 6))
282 (remainder-padding (mod padded-bits 24))
283 (padding-bits (if (zerop remainder-padding)
285 (- 24 remainder-padding)))
286 (padding-chars (/ padding-bits 6))
287 (padded-length (/ (+ padded-bits padding-bits) 6))
288 (strlen padded-length)
289 (nonpad-chars (- strlen padding-chars))
290 (last-nonpad-char (1- nonpad-chars))
291 (str (make-string strlen)))
292 (declare (fixnum padded-length last-nonpad-char))
293 (do* ((strpos 0 (the fixnum (1+ strpos)))
294 (int (ash input (/ padding-bits 3)) (ash int -6))
295 (6bit-value (the fixnum (logand int #x3f))
296 (the fixnum (logand int #x3f))))
297 ((= strpos nonpad-chars)
299 (declare (fixnum col))
300 (dotimes (i nonpad-chars)
302 (write-char (schar str i) stream)
303 (when (plusp columns)
305 (when (= col columns)
306 (write-char #\Newline stream)
308 (dotimes (ipad padding-chars)
309 (declare (fixnum ipad))
310 (write-char pad stream)
311 (when (plusp columns)
313 (when (= col columns)
314 (write-char #\Newline stream)
317 (declare (fixnum 6bit-value strpos)
319 (setf (schar str (- last-nonpad-char strpos))
320 (schar encode-table 6bit-value))