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
10 ;;;; $Id: encode.lisp,v 1.6 2003/05/06 16:21:06 kevin Exp $
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
29 ;;;; $Id: encode.lisp,v 1.6 2003/05/06 16:21:06 kevin Exp $
31 (in-package #:cl-base64)
33 (eval-when (:compile-toplevel)
34 (declaim (optimize (space 0) (speed 3) (safety 1) (compilation-speed 0))))
37 (defun round-next-multiple (x n)
38 "Round x up to the next highest multiple of n."
41 (let ((remainder (mod x n)))
42 (declare (fixnum remainder))
45 (the fixnum (+ x (the fixnum (- n remainder)))))))
47 (defmacro def-*-to-base64-* (input-type output-type)
48 `(defun ,(intern (concatenate 'string (symbol-name input-type)
49 (symbol-name :-to-base64-)
50 (symbol-name output-type)))
52 ,@(when (eq output-type :stream)
54 &key (uri nil) (columns 0))
55 "Encode a string array to base64. If columns is > 0, designates
56 maximum number of columns in a line and the string will be terminated
58 (declare ,@(case input-type
62 '((type (array (unsigned-byte 8) (*)) input))))
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)
69 (let* ((string-length (length input))
70 (complete-group-count (truncate string-length 3))
71 (remainder (nth-value 1 (truncate string-length 3)))
72 (padded-length (* 4 (truncate (+ string-length 2) 3)))
73 ,@(when (eq output-type :string)
74 '((num-lines (if (plusp columns)
75 (truncate (+ padded-length (1- columns)) columns)
77 (num-breaks (if (plusp num-lines)
80 (strlen (+ padded-length num-breaks))
81 (result (make-string strlen))
83 (col (if (plusp columns)
85 (the fixnum (1+ padded-length)))))
86 (declare (fixnum string-length padded-length col
87 ,@(when (eq output-type :string)
89 ,@(when (eq output-type :string)
90 '((simple-string result))))
91 (labels ((output-char (ch)
96 '((write-char #\Newline output)))
98 '((setf (schar result ioutput) #\Newline)
104 '((write-char ch output)))
106 '((setf (schar result ioutput) ch)
108 (output-group (svalue chars)
109 (declare (fixnum svalue chars))
114 (the fixnum (ash svalue -18))))))
119 (the fixnum (ash svalue -12))))))
125 (the fixnum (ash svalue -6))))))
131 (logand #x3f svalue))))
133 (do ((igroup 0 (the fixnum (1+ igroup)))
134 (isource 0 (the fixnum (+ isource 3))))
135 ((= igroup complete-group-count)
145 '(char-code (the character (char input isource))))
147 '(the fixnum (aref input isource))))
153 '(char-code (the character (char input
154 (the fixnum (1+ isource))))))
156 '(the fixnum (aref input (the fixnum
166 '(char-code (the character (char input isource))))
168 '(the fixnum (aref input isource))))
176 (declare (fixnum igroup isource))
185 '(char-code (the character (char input isource))))
187 '(aref input isource))))
194 '(char-code (the character (char input
195 (the fixnum (1+ isource))))))
197 '(aref input (1+ isource)))))
202 '(char-code (the character (char input
203 (the fixnum (+ 2 isource))))))
205 '(aref input (+ 2 isource))))
209 (def-*-to-base64-* :string :string)
210 (def-*-to-base64-* :string :stream)
211 (def-*-to-base64-* :usb8-array :string)
212 (def-*-to-base64-* :usb8-array :stream)
215 (defun integer-to-base64-string (input &key (uri nil) (columns 0))
216 "Encode an integer to base64 format."
217 (declare (integer input)
219 (optimize (speed 3)))
220 (let ((pad (if uri *uri-pad-char* *pad-char*))
221 (encode-table (if uri *uri-encode-table* *encode-table*)))
222 (declare (simple-string encode-table)
224 (let* ((input-bits (integer-length input))
225 (byte-bits (round-next-multiple input-bits 8))
226 (padded-bits (round-next-multiple byte-bits 6))
227 (remainder-padding (mod padded-bits 24))
228 (padding-bits (if (zerop remainder-padding)
230 (- 24 remainder-padding)))
231 (padding-chars (/ padding-bits 6))
232 (padded-length (/ (+ padded-bits padding-bits) 6))
233 (last-line-len (if (plusp columns)
234 (- padded-length (* columns
236 padded-length columns)))
238 (num-lines (if (plusp columns)
239 (truncate (+ padded-length (1- columns)) columns)
241 (num-breaks (if (plusp num-lines)
244 (strlen (+ padded-length num-breaks))
245 (last-char (1- strlen))
246 (str (make-string strlen))
247 (col (if (zerop last-line-len)
250 (declare (fixnum padded-length num-lines col last-char
251 padding-chars last-line-len))
252 (unless (plusp columns)
253 (setq col -1)) ;; set to flag to optimize in loop
255 (dotimes (i padding-chars)
257 (setf (schar str (the fixnum (- last-char i))) pad))
259 (do* ((strpos (- last-char padding-chars) (1- strpos))
260 (int (ash input (/ padding-bits 3))))
263 (declare (fixnum strpos) (integer int))
266 (setf (schar str strpos) #\Newline)
269 (setf (schar str strpos)
270 (schar encode-table (the fixnum (logand int #x3f))))
271 (setq int (ash int -6))
274 (defun integer-to-base64-stream (input stream &key (uri nil) (columns 0))
275 "Encode an integer to base64 format."
276 (declare (integer input)
278 (optimize (speed 3)))
279 (let ((pad (if uri *uri-pad-char* *pad-char*))
280 (encode-table (if uri *uri-encode-table* *encode-table*)))
281 (declare (simple-string encode-table)
283 (let* ((input-bits (integer-length input))
284 (byte-bits (round-next-multiple input-bits 8))
285 (padded-bits (round-next-multiple byte-bits 6))
286 (remainder-padding (mod padded-bits 24))
287 (padding-bits (if (zerop remainder-padding)
289 (- 24 remainder-padding)))
290 (padding-chars (/ padding-bits 6))
291 (padded-length (/ (+ padded-bits padding-bits) 6))
292 (strlen padded-length)
293 (nonpad-chars (- strlen padding-chars))
294 (last-nonpad-char (1- nonpad-chars))
295 (str (make-string strlen)))
296 (declare (fixnum padded-length last-nonpad-char))
297 (do* ((strpos 0 (the fixnum (1+ strpos)))
298 (int (ash input (/ padding-bits 3)) (ash int -6))
299 (6bit-value (the fixnum (logand int #x3f))
300 (the fixnum (logand int #x3f))))
301 ((= strpos nonpad-chars)
303 (declare (fixnum col))
304 (dotimes (i nonpad-chars)
306 (write-char (schar str i) stream)
307 (when (plusp columns)
309 (when (= col columns)
310 (write-char #\Newline stream)
312 (dotimes (ipad padding-chars)
313 (declare (fixnum ipad))
314 (write-char pad stream)
315 (when (plusp columns)
317 (when (= col columns)
318 (write-char #\Newline stream)
321 (declare (fixnum 6bit-value strpos)
323 (setf (schar str (- last-nonpad-char strpos))
324 (schar encode-table 6bit-value))