;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Dec 2002
;;;;
-;;;; $Id: decode.lisp,v 1.1 2003/01/12 20:25:26 kevin Exp $
+;;;; $Id: decode.lisp,v 1.2 2003/01/12 22:32:40 kevin Exp $
;;;;
;;;; This file implements the Base64 transfer encoding algorithm as
;;;; defined in RFC 1521 by Borensten & Freed, September 1993.
(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package #:cl-base64)
+
(declaim (inline whitespace-p))
(defun whitespace-p (c)
"Returns T for a whitespace character."
;;; Decoding
-(defun base64-to-string (string &key (uri nil))
- "Decode a base64 string to a string array."
- (declare (string string)
- (optimize (speed 3)))
- (let ((pad (if uri *uri-pad-char* *pad-char*))
- (decode-table (if uri *uri-decode-table* *decode-table*)))
- (declare (type decode-table decode-table)
- (character pad))
- (let ((result (make-string (* 3 (truncate (length string) 4))))
- (ridx 0))
- (declare (simple-string result)
- (fixnum ridx))
- (loop
- for char of-type character across string
- for svalue of-type fixnum = (aref decode-table
- (the fixnum (char-code char)))
- with bitstore of-type fixnum = 0
- with bitcount of-type fixnum = 0
- do
- (cond
- ((>= svalue 0)
- (setf bitstore (logior
- (the fixnum (ash bitstore 6))
- svalue))
- (incf bitcount 6)
- (when (>= bitcount 8)
- (decf bitcount 8)
- (setf (char result ridx)
- (code-char (the fixnum
- (logand
- (the fixnum
- (ash bitstore
- (the fixnum (- bitcount))))
- #xFF))))
- (incf ridx)
- (setf bitstore (the fixnum (logand bitstore #xFF)))))
- ((char= char pad)
- ;; Could add checks to make sure padding is correct
- ;; Currently, padding is ignored
- )
- ((whitespace-p char)
- ;; Ignore whitespace
- )
- ((minusp svalue)
- (warn "Bad character ~W in base64 decode" char))
-))
- (subseq result 0 ridx))))
-
-#|
-(def-base64-stream-to-* :string)
-(def-base64-stream-to-* :stream)
-(def-base64-stream-to-* :usb8-array)
-|#
-
-(defmacro def-base64-string-to-* (output-type)
- `(defun ,(case output-type
- (:string
- 'base64-string-to-string)
- (:stream
- 'base64-string-to-stream)
- (:usb8-array
- 'base64-string-to-usb8-array))
+#+ignore
+(defmacro def-base64-stream-to-* (output-type)
+ `(defun ,(intern (concatenate 'string (symbol-name :base64-stream-to-)
+ (symbol-name output-type)))
(input &key (uri nil)
,@(when (eq output-type :stream)
'(stream)))
- "Decode base64 string"
- (declare (input string)
+ ,(concatenate 'string "Decode base64 stream to " (string-downcase
+ (symbol-name output-type)))
+ (declare (stream input)
(optimize (speed 3)))
(let ((pad (if uri *uri-pad-char* *pad-char*))
(decode-table (if uri *uri-decode-table* *decode-table*)))
(declare (type decode-table decode-table)
- (character pad))
+ (type character pad))
(let (,@(case output-type
(:string
'((result (make-string (* 3 (truncate (length string) 4))))))
(ridx 0))
(declare ,@(case output-type
(:string
- '((simple-string result))
+ '((simple-string result)))
+ (:usb8-array
+ '((type (array fixnum (*)) result))))
+ (fixnum ridx))
+ (do* ((bitstore 0)
+ (bitcount 0)
+ (char (read-char stream nil #\null)
+ (read-char stream nil #\null)))
+ ((eq char #\null)
+ ,(case output-type
+ (:stream
+ 'stream)
+ ((or :stream :string)
+ '(subseq result 0 ridx))))
+ (declare (fixnum bitstore bitcount)
+ (character char))
+ (let ((svalue (aref decode-table (the fixnum (char-code char)))))
+ (declare (fixnum svalue))
+ (cond
+ ((>= svalue 0)
+ (setf bitstore (logior
+ (the fixnum (ash bitstore 6))
+ svalue))
+ (incf bitcount 6)
+ (when (>= bitcount 8)
+ (decf bitcount 8)
+ (let ((ovalue (the fixnum
+ (logand
+ (the fixnum
+ (ash bitstore
+ (the fixnum (- bitcount))))
+ #xFF))))
+ (declare (fixnum ovalue))
+ ,(case output-type
+ (:string
+ '(setf (char result ridx) (code-char ovalue)))
(:usb8-array
- '((type (array fixnum (*)) result)))))
+ '(setf (aref result ridx) ovalue))
+ (:stream
+ '(write-char (code-char ovalue) stream)))
+ (incf ridx)
+ (setf bitstore (the fixnum (logand bitstore #xFF))))))
+ ((char= char pad)
+ ;; Could add checks to make sure padding is correct
+ ;; Currently, padding is ignored
+ )
+ ((whitespace-p char)
+ ;; Ignore whitespace
+ )
+ ((minusp svalue)
+ (warn "Bad character ~W in base64 decode" char))
+ )))))))
+
+;;(def-base64-stream-to-* :string)
+;;(def-base64-stream-to-* :stream)
+;;(def-base64-stream-to-* :usb8-array)
+
+(defmacro def-base64-string-to-* (output-type)
+ `(defun ,(intern (concatenate 'string (symbol-name :base64-string-to-)
+ (symbol-name output-type)))
+ (input &key (uri nil)
+ ,@(when (eq output-type :stream)
+ '(stream)))
+ ,(concatenate 'string "Decode base64 string to " (string-downcase
+ (symbol-name output-type)))
+ (declare (string input)
+ (optimize (speed 3)))
+ (let ((pad (if uri *uri-pad-char* *pad-char*))
+ (decode-table (if uri *uri-decode-table* *decode-table*)))
+ (declare (type decode-table decode-table)
+ (type character pad))
+ (let (,@(case output-type
+ (:string
+ '((result (make-string (* 3 (truncate (length input) 4))))))
+ (:usb8-array
+ '((result (make-array (* 3 (truncate (length input) 4))
+ :element-type '(unsigned-byte 8)
+ :fill-pointer nil
+ :adjustable nil)))))
+ (ridx 0))
+ (declare ,@(case output-type
+ (:string
+ '((simple-string result)))
+ (:usb8-array
+ '((type (array fixnum (*)) result))))
(fixnum ridx))
(loop
- for char of-type character across string
+ for char of-type character across input
for svalue of-type fixnum = (aref decode-table
(the fixnum (char-code char)))
with bitstore of-type fixnum = 0
(incf bitcount 6)
(when (>= bitcount 8)
(decf bitcount 8)
- (let ((svalue (the fixnum
+ (let ((ovalue (the fixnum
(logand
(the fixnum
(ash bitstore
(the fixnum (- bitcount))))
#xFF))))
- (declare (fixnum svalue))
- ,@(case output-type
- (:string
- (setf (char result ridx) (code-char svalue)))
- (:usb8-array
- (setf (aref result ridx) svalue))
- (:stream
- (write-char (code-char svalue) stream)))
+ (declare (fixnum ovalue))
+ ,(case output-type
+ (:string
+ '(setf (char result ridx) (code-char ovalue)))
+ (:usb8-array
+ '(setf (aref result ridx) ovalue))
+ (:stream
+ '(write-char (code-char ovalue) stream)))
(incf ridx)
- (setf bitstore (the fixnum (logand bitstore #xFF)))))
+ (setf bitstore (the fixnum (logand bitstore #xFF))))))
((char= char pad)
;; Could add checks to make sure padding is correct
;; Currently, padding is ignored
((minusp svalue)
(warn "Bad character ~W in base64 decode" char))
))
- (subseq result 0 ridx))))))
+ ,(case output-type
+ (:stream
+ 'stream)
+ ((:stream :string)
+ '(subseq result 0 ridx)))))))
(def-base64-string-to-* :string)
(def-base64-string-to-* :stream)
(def-base64-string-to-* :usb8-array)
-
+
;; input-mode can be :string or :stream
;; input-format can be :character or :usb8
(warn "Bad character ~W in base64 decode" char))))
value)))
+
(defun base64-stream-to-integer (stream &key (uri nil))
"Decodes a base64 string to an integer"
(declare (stream stream)
(read-char stream nil #\null)))
((eq char #\null)
value)
- (declare (value integer)
- (char character))
+ (declare (integer value)
+ (character char))
(let ((svalue (aref decode-table (the fixnum (char-code char)))))
(declare (fixnum svalue))
(cond
((whitespace-p char) ; ignore whitespace
)
((minusp svalue)
- (warn "Bad character ~W in base64 decode" char))))
- value)))
+ (warn "Bad character ~W in base64 decode" char)))))))
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Dec 2002
;;;;
-;;;; $Id: encode.lisp,v 1.1 2003/01/12 20:25:26 kevin Exp $
+;;;; $Id: encode.lisp,v 1.2 2003/01/12 22:32:40 kevin Exp $
;;;;
;;;; This file implements the Base64 transfer encoding algorithm as
;;;; defined in RFC 1521 by Borensten & Freed, September 1993.
;;;; - Renamed functions now that supporting integer conversions
;;;; - URI-compatible encoding using :uri key
;;;;
-;;;; $Id: encode.lisp,v 1.1 2003/01/12 20:25:26 kevin Exp $
+;;;; $Id: encode.lisp,v 1.2 2003/01/12 22:32:40 kevin Exp $
(in-package #:cl-base64)
(the fixnum
(char-code (the character (char string (+ 2 isource)))))))
4))))))
-
-(defun integer-to-base64 (input &key (uri nil) (columns 0) (stream nil))
- (if stream
- (integer-to-base64-stream input stream :uri uri :columns columns)
- (integer-to-base64-string input :uri uri :columns columns)))
+
+(defmacro def-*-to-base64-* (input-type output-type)
+ `(defun ,(intern (concatenate 'string (symbol-name input-type)
+ (symbol-name :-to-base-64-)
+ (symbol-name output-type)))
+ (input
+ ,@(when (eq output-type :stream)
+ 'output)
+ &key (uri nil) (columns 0))
+ "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 (,@(case input-type
+ (:string
+ '((string input)))
+ (:usb8-array)
+ '((type (array fixnum (*))) input))
+ (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 input))
+ (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))
+ (macrolet ((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))
+ ,@(case output-type
+ (:stream
+ '((write-char ch stream))
+ (:string
+ '((setf (schar result ioutput) ch)
+ (incf ioutput)))))))
+ (labels ((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
+ ,(case input-type
+ (:string
+ '(char-code (the character (char input isource))))
+ (:usb8-array
+ '(the fixnum (aref input isource))))
+ 16))
+ (the fixnum
+ (ash
+ ,(case input-type
+ (:string
+ '(char-code (the character (char input (1+ isource)))))
+ (:usb8-array
+ '(the fixnum (aref input (1+ isource)))))
+ 8))))
+ 3))
+ ((= remainder 1)
+ (output-group
+ (the fixnum
+ ,(case input-type
+ (:string
+ '(char-code (the character (char input isource))))
+ (:usb8-array
+ '(the fixnum (aref input isource)))))
+ 2)))
+ result)
+ (declare (fixnum igroup isource))
+ (output-group
+ (the fixnum
+ (+
+ (the fixnum
+ (ash
+ ,(case input-type
+ (:string
+ '(char-code (the character (char input isource))))
+ (:usb8-array
+ '(the fixnum (aref input isource))))
+ 16))
+ (the fixnum
+ (ash
+ ,(case input-type
+ (:string
+ '(char-code (the character (char input (1+ isource)))))
+ (:usb8-array
+ '(the fixnum (aref input (1+ isource)))))
+ 8))
+ (the fixnum
+ ,(case input-type
+ (:string
+ '(char-code (the character (char input (+ 2 isource)))))
+ (:usb8-array
+ '(the fixnum (aref input (+ 2 isource)))))
+ )))
+ 4))))))))
+
+(def-*-to-base64-* :string :string)
+(def-*-to-base64-* :string :stream)
+(def-*-to-base64-* :usb8-array :string)
+(def-*-to-base64-* :usb8-array :stream)
+
(defun integer-to-base64-string (input &key (uri nil) (columns 0))
"Encode an integer to base64 format."
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Dec 2002
;;;;
-;;;; $Id: package.lisp,v 1.1 2003/01/12 20:25:26 kevin Exp $
+;;;; $Id: package.lisp,v 1.2 2003/01/12 22:32:40 kevin Exp $
;;;;
;;;; *************************************************************************
(in-package #:cl-base64)
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defvar *encode-table*
- "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
- (declaim (type simple-string *encode-table*))
-
- (defvar *uri-encode-table*
- "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")
- (declaim (type simple-string *uri-encode-table*))
-
- (deftype decode-table () '(array fixnum (256)))
+(defvar *encode-table*
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
+(declaim (type simple-string *encode-table*))
+
+(defvar *uri-encode-table*
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")
+(declaim (type simple-string *uri-encode-table*))
- (defun make-decode-table (encode-table)
- (let ((dt (make-array 256 :adjustable nil :fill-pointer nil
- :element-type 'fixnum
- :initial-element -1)))
- (loop for char of-type character across encode-table
- for index of-type fixnum from 0 below 64
- do (setf (aref dt (the fixnum (char-code char))) index))
- dt))
+(deftype decode-table () '(array fixnum (256)))
+
+(defun make-decode-table (encode-table)
+ (let ((dt (make-array 256 :adjustable nil :fill-pointer nil
+ :element-type 'fixnum
+ :initial-element -1)))
+ (declare (type decode-table dt))
+ (loop for char of-type character across encode-table
+ for index of-type fixnum from 0 below 64
+ do (setf (aref dt (the fixnum (char-code char))) index))
+ dt))
- (defvar *decode-table* (make-decode-table *encode-table*))
-
- (defvar *uri-decode-table* (make-decode-table *uri-encode-table*))
+(defvar *decode-table* (make-decode-table *encode-table*))
- (declaim (type decode-table *decode-table* *uri-decode-table*))
+(defvar *uri-decode-table* (make-decode-table *uri-encode-table*))
- (defvar *pad-char* #\=)
- (defvar *uri-pad-char* #\.)
- (declaim (type character *pad-char* *uri-pad-char*))
- )
+(defvar *pad-char* #\=)
+(defvar *uri-pad-char* #\.)
+(declaim (type character *pad-char* *uri-pad-char*))
projects / cl-base64.git / commitdiff