From: Kevin M. Rosenberg Date: Sun, 12 Jan 2003 22:32:40 +0000 (+0000) Subject: r3747: *** empty log message *** X-Git-Tag: v3.3.2~49 X-Git-Url: http://git.kpe.io/?p=cl-base64.git;a=commitdiff_plain;h=8d11e40eb06556b995b963ee7c72e59a5368d21e r3747: *** empty log message *** --- diff --git a/debian/changelog b/debian/changelog index 857f024..81e12a0 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,7 +1,10 @@ -cl-base64 (2.2.0-1) unstable; urgency=low +cl-base64 (3.0.0-1) unstable; urgency=low * Fix error in integer-to-base64 when using columns * Add base64-test.asd and test.lisp regression suite + * Rewrite routines as macros to create efficient functions to + converting from strings or streams and converting to streams, strings, + and usb8-arrays. -- Kevin M. Rosenberg Sat, 4 Jan 2003 06:40:32 -0700 diff --git a/decode.lisp b/decode.lisp index ea0cdf2..775bb8e 100644 --- a/decode.lisp +++ b/decode.lisp @@ -7,7 +7,7 @@ ;;;; 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. @@ -21,6 +21,8 @@ (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." @@ -31,78 +33,21 @@ ;;; 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)))))) @@ -114,12 +59,94 @@ (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 @@ -133,22 +160,22 @@ (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 @@ -159,12 +186,16 @@ ((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 @@ -195,6 +226,7 @@ (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) @@ -208,8 +240,8 @@ (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 @@ -220,5 +252,4 @@ ((whitespace-p char) ; ignore whitespace ) ((minusp svalue) - (warn "Bad character ~W in base64 decode" char)))) - value))) + (warn "Bad character ~W in base64 decode" char))))))) diff --git a/encode.lisp b/encode.lisp index e6ee841..d079515 100644 --- a/encode.lisp +++ b/encode.lisp @@ -7,7 +7,7 @@ ;;;; 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. @@ -28,7 +28,7 @@ ;;;; - 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) @@ -147,11 +147,159 @@ with a #\Newline." (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." diff --git a/package.lisp b/package.lisp index 7c119de..014cd1f 100644 --- a/package.lisp +++ b/package.lisp @@ -1,4 +1,4 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; @@ -7,7 +7,7 @@ ;;;; 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 $ ;;;; ;;;; ************************************************************************* @@ -42,33 +42,30 @@ (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*))