;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Dec 2002
;;;;
-;;;; $Id: encode.lisp,v 1.3 2003/01/13 21:38:01 kevin Exp $
+;;;; $Id: encode.lisp,v 1.6 2003/05/06 16:21:06 kevin Exp $
;;;;
;;;; This file implements the Base64 transfer encoding algorithm as
;;;; defined in RFC 1521 by Borensten & Freed, September 1993.
;;;; Permission to use with BSD-style license included in the COPYING file
;;;; *************************************************************************
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-
;;;; Extended by Kevin M. Rosenberg <kevin@rosenberg.net>:
;;;; - .asd file
;;;; - numerous speed optimizations
;;;; - Renamed functions now that supporting integer conversions
;;;; - URI-compatible encoding using :uri key
;;;;
-;;;; $Id: encode.lisp,v 1.3 2003/01/13 21:38:01 kevin Exp $
+;;;; $Id: encode.lisp,v 1.6 2003/05/06 16:21:06 kevin Exp $
(in-package #:cl-base64)
+(eval-when (:compile-toplevel)
+ (declaim (optimize (space 0) (speed 3) (safety 1) (compilation-speed 0))))
+
(defun round-next-multiple (x n)
"Round x up to the next highest multiple of n."
x
(the fixnum (+ x (the fixnum (- n remainder)))))))
-(defun string-to-base64 (string &key (uri nil) (columns 0) (stream nil))
- "Encode a string array to base64. If columns is > 0, designates
-maximum number of columns in a line and the string will be terminated
-with a #\Newline."
- (declare (string string)
- (fixnum columns)
- (optimize (speed 3)))
- (let ((pad (if uri *uri-pad-char* *pad-char*))
- (encode-table (if uri *uri-encode-table* *encode-table*)))
- (declare (simple-string encode-table)
- (character pad))
- (let* ((string-length (length string))
- (complete-group-count (truncate string-length 3))
- (remainder (nth-value 1 (truncate string-length 3)))
- (padded-length (* 4 (truncate (+ string-length 2) 3)))
- (num-lines (if (plusp columns)
- (truncate (+ padded-length (1- columns)) columns)
- 0))
- (num-breaks (if (plusp num-lines)
- (1- num-lines)
- 0))
- (strlen (if stream
- 0
- (+ padded-length num-breaks)))
- (result (make-string strlen))
- (col (if (plusp columns)
- 0
- (1+ padded-length)))
- (ioutput 0))
- (declare (fixnum string-length padded-length col ioutput)
- (simple-string result))
- (labels ((output-char (ch)
- (if (= col columns)
- (progn
- (if stream
- (write-char #\Newline stream)
- (progn
- (setf (schar result ioutput) #\Newline)
- (incf ioutput)))
- (setq col 1))
- (incf col))
- (if stream
- (write-char ch stream)
- (progn
- (setf (schar result ioutput) ch)
- (incf ioutput))))
- (output-group (svalue chars)
- (declare (fixnum svalue chars))
- (output-char
- (schar encode-table
- (the fixnum
- (logand #x3f
- (the fixnum (ash svalue -18))))))
- (output-char
- (schar encode-table
- (the fixnum
- (logand #x3f
- (the fixnum (ash svalue -12))))))
- (if (> chars 2)
- (output-char
- (schar encode-table
- (the fixnum
- (logand #x3f
- (the fixnum (ash svalue -6))))))
- (output-char pad))
- (if (> chars 3)
- (output-char
- (schar encode-table
- (the fixnum
- (logand #x3f svalue))))
- (output-char pad))))
- (do ((igroup 0 (1+ igroup))
- (isource 0 (+ isource 3)))
- ((= igroup complete-group-count)
- (cond
- ((= remainder 2)
- (output-group
- (the fixnum
- (+
- (the fixnum
- (ash (the fixnum
- (char-code (the character
- (char string isource))))
- 16))
- (the fixnum
- (ash (the fixnum
- (char-code (the character
- (char string (1+ isource)))))
- 8))))
- 3))
- ((= remainder 1)
- (output-group
- (the fixnum
- (ash
- (the fixnum
- (char-code (the character (char string isource))))
- 16))
- 2)))
- result)
- (declare (fixnum igroup isource))
- (output-group
- (the fixnum
- (+
- (the fixnum
- (ash (char-code (the character
- (char string isource))) 16))
- (the fixnum
- (ash (char-code (the character (char string (1+ isource)))) 8))
- (the fixnum
- (char-code (the character (char string (+ 2 isource)))))))
- 4))))))
-
(defmacro def-*-to-base64-* (input-type output-type)
`(defun ,(intern (concatenate 'string (symbol-name input-type)
(symbol-name :-to-base64-)
(:string
'((string input)))
(:usb8-array
- '((type (array fixnum (*)) input))))
+ '((type (array (unsigned-byte 8) (*)) input))))
(fixnum columns)
(optimize (speed 3)))
(let ((pad (if uri *uri-pad-char* *pad-char*))
(ioutput 0)))
(col (if (plusp columns)
0
- (1+ padded-length))))
+ (the fixnum (1+ padded-length)))))
(declare (fixnum string-length padded-length col
,@(when (eq output-type :string)
'(ioutput)))
(the fixnum
(logand #x3f svalue))))
(output-char pad))))
- (do ((igroup 0 (1+ igroup))
- (isource 0 (+ isource 3)))
+ (do ((igroup 0 (the fixnum (1+ igroup)))
+ (isource 0 (the fixnum (+ isource 3))))
((= igroup complete-group-count)
(cond
((= remainder 2)
(ash
,(case input-type
(:string
- '(char-code (the character (char input (1+ isource)))))
+ '(char-code (the character (char input
+ (the fixnum (1+ isource))))))
(:usb8-array
- '(the fixnum (aref input (1+ isource)))))
+ '(the fixnum (aref input (the fixnum
+ (1+ isource))))))
8))))
3))
((= remainder 1)
(the fixnum
,(case input-type
(:string
- '(char-code (the character (char input (1+ isource)))))
+ '(char-code (the character (char input
+ (the fixnum (1+ isource))))))
(:usb8-array
'(aref input (1+ isource)))))
8))
(the fixnum
,(case input-type
(:string
- '(char-code (the character (char input (+ 2 isource)))))
+ '(char-code (the character (char input
+ (the fixnum (+ 2 isource))))))
(:usb8-array
'(aref input (+ 2 isource))))
)))
(last-nonpad-char (1- nonpad-chars))
(str (make-string strlen)))
(declare (fixnum padded-length last-nonpad-char))
- (do* ((strpos 0 (1+ strpos))
+ (do* ((strpos 0 (the fixnum (1+ strpos)))
(int (ash input (/ padding-bits 3)) (ash int -6))
- (6bit-value (logand int #x3f) (logand int #x3f)))
+ (6bit-value (the fixnum (logand int #x3f))
+ (the fixnum (logand int #x3f))))
((= strpos nonpad-chars)
(let ((col 0))
(declare (fixnum col))