From: Kevin M. Rosenberg Date: Fri, 31 Aug 2007 18:04:31 +0000 (+0000) Subject: r11859: Canonicalize whitespace X-Git-Tag: v3.3.2~1 X-Git-Url: http://git.kpe.io/?p=cl-base64.git;a=commitdiff_plain;h=c5cbb82b14acd50e5869053157dab7b4d0bcc954 r11859: Canonicalize whitespace --- diff --git a/decode.lisp b/decode.lisp index 6503b78..1649daa 100644 --- a/decode.lisp +++ b/decode.lisp @@ -34,84 +34,84 @@ #+ignore (defmacro def-base64-stream-to-* (output-type) `(defun ,(intern (concatenate 'string (symbol-name :base64-stream-to-) - (symbol-name output-type))) + (symbol-name output-type))) (input &key (uri nil) - ,@(when (eq output-type :stream) - '(stream))) + ,@(when (eq output-type :stream) + '(stream))) ,(concatenate 'string "Decode base64 stream to " (string-downcase - (symbol-name output-type))) + (symbol-name output-type))) (declare (stream input) - (optimize (speed 3) (space 0) (safety 0))) + (optimize (speed 3) (space 0) (safety 0))) (let ((pad (if uri *uri-pad-char* *pad-char*)) - (decode-table (if uri *uri-decode-table* *decode-table*))) + (decode-table (if uri *uri-decode-table* *decode-table*))) (declare (type decode-table decode-table) - (type character pad)) + (type character pad)) (let (,@(case output-type - (:string - '((result (make-string (* 3 (truncate (length string) 4)))))) - (:usb8-array - '((result (make-array (* 3 (truncate (length string) 4)) - :element-type '(unsigned-byte 8) - :fill-pointer nil - :adjustable nil))))) - (ridx 0)) - (declare ,@(case output-type - (:string - '((simple-string result))) - (:usb8-array - '((type (simple-array (usigned-byte 8) (*)) 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) - ((:string :usb8-array) - 'result) - ;; ((: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 - '(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)) - ))))))) + (:string + '((result (make-string (* 3 (truncate (length string) 4)))))) + (:usb8-array + '((result (make-array (* 3 (truncate (length string) 4)) + :element-type '(unsigned-byte 8) + :fill-pointer nil + :adjustable nil))))) + (ridx 0)) + (declare ,@(case output-type + (:string + '((simple-string result))) + (:usb8-array + '((type (simple-array (usigned-byte 8) (*)) 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) + ((:string :usb8-array) + 'result) + ;; ((: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 + '(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) @@ -119,79 +119,79 @@ (defmacro def-base64-string-to-* (output-type) `(defun ,(intern (concatenate 'string (symbol-name :base64-string-to-) - (symbol-name output-type))) + (symbol-name output-type))) (input &key (uri nil) - ,@(when (eq output-type :stream) - '(stream))) + ,@(when (eq output-type :stream) + '(stream))) ,(concatenate 'string "Decode base64 string to " (string-downcase - (symbol-name output-type))) + (symbol-name output-type))) (declare (string input) - (optimize (speed 3) (safety 0) (space 0))) + (optimize (speed 3) (safety 0) (space 0))) (let ((pad (if uri *uri-pad-char* *pad-char*)) - (decode-table (if uri *uri-decode-table* *decode-table*))) + (decode-table (if uri *uri-decode-table* *decode-table*))) (declare (type decode-table decode-table) - (type character pad)) + (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 (simple-array (unsigned-byte 8) (*)) result)))) - (fixnum ridx)) - (loop - 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 - 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) - (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 - '(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)) - )) - ,(case output-type - (:stream - 'stream) - ((:usb8-array :string) - '(subseq result 0 ridx))))))) + (: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 (simple-array (unsigned-byte 8) (*)) result)))) + (fixnum ridx)) + (loop + 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 + 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) + (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 + '(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)) + )) + ,(case output-type + (:stream + 'stream) + ((:usb8-array :string) + '(subseq result 0 ridx))))))) (def-base64-string-to-* :string) (def-base64-string-to-* :stream) @@ -203,54 +203,54 @@ (defun base64-string-to-integer (string &key (uri nil)) "Decodes a base64 string to an integer" (declare (string string) - (optimize (speed 3) (safety 0) (space 0))) + (optimize (speed 3) (safety 0) (space 0))) (let ((pad (if uri *uri-pad-char* *pad-char*)) - (decode-table (if uri *uri-decode-table* *decode-table*))) + (decode-table (if uri *uri-decode-table* *decode-table*))) (declare (type decode-table decode-table) - (character pad)) + (character pad)) (let ((value 0)) (declare (integer value)) (loop - for char of-type character across string - for svalue of-type fixnum = - (aref decode-table (the fixnum (char-code char))) - do - (cond - ((>= svalue 0) - (setq value (+ svalue (ash value 6)))) - ((char= char pad) - (setq value (ash value -2))) - ((whitespace-p char) - ; ignore whitespace - ) - ((minusp svalue) - (warn "Bad character ~W in base64 decode" char)))) + for char of-type character across string + for svalue of-type fixnum = + (aref decode-table (the fixnum (char-code char))) + do + (cond + ((>= svalue 0) + (setq value (+ svalue (ash value 6)))) + ((char= char pad) + (setq value (ash value -2))) + ((whitespace-p char) + ; ignore whitespace + ) + ((minusp svalue) + (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) - (optimize (speed 3) (space 0) (safety 0))) + (optimize (speed 3) (space 0) (safety 0))) (let ((pad (if uri *uri-pad-char* *pad-char*)) - (decode-table (if uri *uri-decode-table* *decode-table*))) + (decode-table (if uri *uri-decode-table* *decode-table*))) (declare (type decode-table decode-table) - (character pad)) + (character pad)) (do* ((value 0) - (char (read-char stream nil #\null) - (read-char stream nil #\null))) - ((eq char #\null) - value) + (char (read-char stream nil #\null) + (read-char stream nil #\null))) + ((eq char #\null) + value) (declare (integer value) - (character char)) + (character char)) (let ((svalue (aref decode-table (the fixnum (char-code char))))) - (declare (fixnum svalue)) - (cond - ((>= svalue 0) - (setq value (+ svalue (ash value 6)))) - ((char= char pad) - (setq value (ash value -2))) - ((whitespace-p char) ; ignore whitespace - ) - ((minusp svalue) - (warn "Bad character ~W in base64 decode" char))))))) + (declare (fixnum svalue)) + (cond + ((>= svalue 0) + (setq value (+ svalue (ash value 6)))) + ((char= char pad) + (setq value (ash value -2))) + ((whitespace-p char) ; ignore whitespace + ) + ((minusp svalue) + (warn "Bad character ~W in base64 decode" char))))))) diff --git a/encode.lisp b/encode.lisp index f5276a8..dcddc1a 100644 --- a/encode.lisp +++ b/encode.lisp @@ -33,174 +33,174 @@ (defun round-next-multiple (x n) "Round x up to the next highest multiple of n." (declare (fixnum n) - (optimize (speed 3) (safety 0) (space 0))) + (optimize (speed 3) (safety 0) (space 0))) (let ((remainder (mod x n))) (declare (fixnum remainder)) (if (zerop remainder) - x - (the fixnum (+ x (the fixnum (- n remainder))))))) + x + (the fixnum (+ x (the fixnum (- n remainder))))))) (defmacro def-*-to-base64-* (input-type output-type) `(defun ,(intern (concatenate 'string (symbol-name input-type) - (symbol-name :-to-base64-) - (symbol-name output-type))) + (symbol-name :-to-base64-) + (symbol-name output-type))) (input - ,@(when (eq output-type :stream) - '(output)) - &key (uri nil) (columns 0)) + ,@(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 (unsigned-byte 8) (*)) input)))) - (fixnum columns) - (optimize (speed 3) (safety 0) (space 0))) + (:string + '((string input))) + (:usb8-array + '((type (array (unsigned-byte 8) (*)) input)))) + (fixnum columns) + (optimize (speed 3) (safety 0) (space 0))) (let ((pad (if uri *uri-pad-char* *pad-char*)) - (encode-table (if uri *uri-encode-table* *encode-table*))) + (encode-table (if uri *uri-encode-table* *encode-table*))) (declare (simple-string encode-table) - (character pad)) + (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))) - ,@(when (eq output-type :string) - '((num-lines (if (plusp columns) - (truncate (+ padded-length (1- columns)) columns) - 0)) - (num-breaks (if (plusp num-lines) - (1- num-lines) - 0)) - (strlen (+ padded-length num-breaks)) - (result (make-string strlen)) - (ioutput 0))) - (col (if (plusp columns) - 0 - (the fixnum (1+ padded-length))))) - (declare (fixnum string-length padded-length col - ,@(when (eq output-type :string) - '(ioutput))) - ,@(when (eq output-type :string) - '((simple-string result)))) - (labels ((output-char (ch) - (if (= col columns) - (progn - ,@(case output-type - (:stream - '((write-char #\Newline output))) - (:string - '((setf (schar result ioutput) #\Newline) - (incf ioutput)))) - (setq col 1)) - (incf col)) - ,@(case output-type - (:stream - '((write-char ch output))) - (:string - '((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 (the fixnum (1+ igroup))) - (isource 0 (the fixnum (+ 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 - (the fixnum (1+ isource)))))) - (:usb8-array - '(the fixnum (aref input (the fixnum - (1+ isource)))))) - 8)))) - 3)) - ((= remainder 1) - (output-group - (the fixnum - (ash - ,(case input-type - (:string - '(char-code (the character (char input isource)))) - (:usb8-array - '(the fixnum (aref input isource)))) - 16)) - 2))) - ,(case output-type - (:string - 'result) - (:stream - 'output))) - (declare (fixnum igroup isource)) - (output-group - (the fixnum - (+ - (the fixnum - (ash - (the fixnum - ,(case input-type - (:string - '(char-code (the character (char input isource)))) - (:usb8-array - '(aref input isource)))) - 16)) - (the fixnum - (ash - (the fixnum - ,(case input-type - (:string - '(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 - (the fixnum (+ 2 isource)))))) - (:usb8-array - '(aref input (+ 2 isource)))) - ))) - 4))))))) + (complete-group-count (truncate string-length 3)) + (remainder (nth-value 1 (truncate string-length 3))) + (padded-length (* 4 (truncate (+ string-length 2) 3))) + ,@(when (eq output-type :string) + '((num-lines (if (plusp columns) + (truncate (+ padded-length (1- columns)) columns) + 0)) + (num-breaks (if (plusp num-lines) + (1- num-lines) + 0)) + (strlen (+ padded-length num-breaks)) + (result (make-string strlen)) + (ioutput 0))) + (col (if (plusp columns) + 0 + (the fixnum (1+ padded-length))))) + (declare (fixnum string-length padded-length col + ,@(when (eq output-type :string) + '(ioutput))) + ,@(when (eq output-type :string) + '((simple-string result)))) + (labels ((output-char (ch) + (if (= col columns) + (progn + ,@(case output-type + (:stream + '((write-char #\Newline output))) + (:string + '((setf (schar result ioutput) #\Newline) + (incf ioutput)))) + (setq col 1)) + (incf col)) + ,@(case output-type + (:stream + '((write-char ch output))) + (:string + '((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 (the fixnum (1+ igroup))) + (isource 0 (the fixnum (+ 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 + (the fixnum (1+ isource)))))) + (:usb8-array + '(the fixnum (aref input (the fixnum + (1+ isource)))))) + 8)))) + 3)) + ((= remainder 1) + (output-group + (the fixnum + (ash + ,(case input-type + (:string + '(char-code (the character (char input isource)))) + (:usb8-array + '(the fixnum (aref input isource)))) + 16)) + 2))) + ,(case output-type + (:string + 'result) + (:stream + 'output))) + (declare (fixnum igroup isource)) + (output-group + (the fixnum + (+ + (the fixnum + (ash + (the fixnum + ,(case input-type + (:string + '(char-code (the character (char input isource)))) + (:usb8-array + '(aref input isource)))) + 16)) + (the fixnum + (ash + (the fixnum + ,(case input-type + (:string + '(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 + (the fixnum (+ 2 isource)))))) + (:usb8-array + '(aref input (+ 2 isource)))) + ))) + 4))))))) (def-*-to-base64-* :string :string) (def-*-to-base64-* :string :stream) @@ -211,112 +211,112 @@ with a #\Newline." (defun integer-to-base64-string (input &key (uri nil) (columns 0)) "Encode an integer to base64 format." (declare (integer input) - (fixnum columns) - (optimize (speed 3) (space 0) (safety 0))) + (fixnum columns) + (optimize (speed 3) (space 0) (safety 0))) (let ((pad (if uri *uri-pad-char* *pad-char*)) - (encode-table (if uri *uri-encode-table* *encode-table*))) + (encode-table (if uri *uri-encode-table* *encode-table*))) (declare (simple-string encode-table) - (character pad)) + (character pad)) (let* ((input-bits (integer-length input)) - (byte-bits (round-next-multiple input-bits 8)) - (padded-bits (round-next-multiple byte-bits 6)) - (remainder-padding (mod padded-bits 24)) - (padding-bits (if (zerop remainder-padding) - 0 - (- 24 remainder-padding))) - (padding-chars (/ padding-bits 6)) - (padded-length (/ (+ padded-bits padding-bits) 6)) - (last-line-len (if (plusp columns) - (- padded-length (* columns - (truncate - padded-length columns))) - 0)) - (num-lines (if (plusp columns) - (truncate (+ padded-length (1- columns)) columns) - 0)) - (num-breaks (if (plusp num-lines) - (1- num-lines) - 0)) - (strlen (+ padded-length num-breaks)) - (last-char (1- strlen)) - (str (make-string strlen)) - (col (if (zerop last-line-len) - columns - last-line-len))) + (byte-bits (round-next-multiple input-bits 8)) + (padded-bits (round-next-multiple byte-bits 6)) + (remainder-padding (mod padded-bits 24)) + (padding-bits (if (zerop remainder-padding) + 0 + (- 24 remainder-padding))) + (padding-chars (/ padding-bits 6)) + (padded-length (/ (+ padded-bits padding-bits) 6)) + (last-line-len (if (plusp columns) + (- padded-length (* columns + (truncate + padded-length columns))) + 0)) + (num-lines (if (plusp columns) + (truncate (+ padded-length (1- columns)) columns) + 0)) + (num-breaks (if (plusp num-lines) + (1- num-lines) + 0)) + (strlen (+ padded-length num-breaks)) + (last-char (1- strlen)) + (str (make-string strlen)) + (col (if (zerop last-line-len) + columns + last-line-len))) (declare (fixnum padded-length num-lines col last-char - padding-chars last-line-len)) + padding-chars last-line-len)) (unless (plusp columns) - (setq col -1)) ;; set to flag to optimize in loop - + (setq col -1)) ;; set to flag to optimize in loop + (dotimes (i padding-chars) - (declare (fixnum i)) - (setf (schar str (the fixnum (- last-char i))) pad)) + (declare (fixnum i)) + (setf (schar str (the fixnum (- last-char i))) pad)) (do* ((strpos (- last-char padding-chars) (1- strpos)) - (int (ash input (/ padding-bits 3)))) - ((minusp strpos) - str) - (declare (fixnum strpos) (integer int)) - (cond - ((zerop col) - (setf (schar str strpos) #\Newline) - (setq col columns)) - (t - (setf (schar str strpos) - (schar encode-table (the fixnum (logand int #x3f)))) - (setq int (ash int -6)) - (decf col))))))) + (int (ash input (/ padding-bits 3)))) + ((minusp strpos) + str) + (declare (fixnum strpos) (integer int)) + (cond + ((zerop col) + (setf (schar str strpos) #\Newline) + (setq col columns)) + (t + (setf (schar str strpos) + (schar encode-table (the fixnum (logand int #x3f)))) + (setq int (ash int -6)) + (decf col))))))) (defun integer-to-base64-stream (input stream &key (uri nil) (columns 0)) "Encode an integer to base64 format." (declare (integer input) - (fixnum columns) - (optimize (speed 3) (space 0) (safety 0))) + (fixnum columns) + (optimize (speed 3) (space 0) (safety 0))) (let ((pad (if uri *uri-pad-char* *pad-char*)) - (encode-table (if uri *uri-encode-table* *encode-table*))) + (encode-table (if uri *uri-encode-table* *encode-table*))) (declare (simple-string encode-table) - (character pad)) + (character pad)) (let* ((input-bits (integer-length input)) - (byte-bits (round-next-multiple input-bits 8)) - (padded-bits (round-next-multiple byte-bits 6)) - (remainder-padding (mod padded-bits 24)) - (padding-bits (if (zerop remainder-padding) - 0 - (- 24 remainder-padding))) - (padding-chars (/ padding-bits 6)) - (padded-length (/ (+ padded-bits padding-bits) 6)) - (strlen padded-length) - (nonpad-chars (- strlen padding-chars)) - (last-nonpad-char (1- nonpad-chars)) - (str (make-string strlen))) + (byte-bits (round-next-multiple input-bits 8)) + (padded-bits (round-next-multiple byte-bits 6)) + (remainder-padding (mod padded-bits 24)) + (padding-bits (if (zerop remainder-padding) + 0 + (- 24 remainder-padding))) + (padding-chars (/ padding-bits 6)) + (padded-length (/ (+ padded-bits padding-bits) 6)) + (strlen padded-length) + (nonpad-chars (- strlen padding-chars)) + (last-nonpad-char (1- nonpad-chars)) + (str (make-string strlen))) (declare (fixnum padded-length last-nonpad-char)) (do* ((strpos 0 (the fixnum (1+ strpos))) - (int (ash input (/ padding-bits 3)) (ash int -6)) - (6bit-value (the fixnum (logand int #x3f)) - (the fixnum (logand int #x3f)))) - ((= strpos nonpad-chars) - (let ((col 0)) - (declare (fixnum col)) - (dotimes (i nonpad-chars) - (declare (fixnum i)) - (write-char (schar str i) stream) - (when (plusp columns) - (incf col) - (when (= col columns) - (write-char #\Newline stream) - (setq col 0)))) - (dotimes (ipad padding-chars) - (declare (fixnum ipad)) - (write-char pad stream) - (when (plusp columns) - (incf col) - (when (= col columns) - (write-char #\Newline stream) - (setq col 0))))) - stream) - (declare (fixnum 6bit-value strpos) - (integer int)) - (setf (schar str (- last-nonpad-char strpos)) - (schar encode-table 6bit-value)) - )))) + (int (ash input (/ padding-bits 3)) (ash int -6)) + (6bit-value (the fixnum (logand int #x3f)) + (the fixnum (logand int #x3f)))) + ((= strpos nonpad-chars) + (let ((col 0)) + (declare (fixnum col)) + (dotimes (i nonpad-chars) + (declare (fixnum i)) + (write-char (schar str i) stream) + (when (plusp columns) + (incf col) + (when (= col columns) + (write-char #\Newline stream) + (setq col 0)))) + (dotimes (ipad padding-chars) + (declare (fixnum ipad)) + (write-char pad stream) + (when (plusp columns) + (incf col) + (when (= col columns) + (write-char #\Newline stream) + (setq col 0))))) + stream) + (declare (fixnum 6bit-value strpos) + (integer int)) + (setf (schar str (- last-nonpad-char strpos)) + (schar encode-table 6bit-value)) + )))) diff --git a/package.lisp b/package.lisp index 6f4fa2c..5eac241 100644 --- a/package.lisp +++ b/package.lisp @@ -15,29 +15,29 @@ (:nicknames #:base64) (:use #:cl) (:export #:base64-stream-to-integer - #:base64-string-to-integer - #:base64-string-to-string - #:base64-stream-to-string - #:base64-string-to-stream - #:base64-stream-to-stream - #:base64-string-to-usb8-array - #:base64-stream-to-usb8-array - #:string-to-base64-string - #:string-to-base64-stream - #:usb8-array-to-base64-string - #:usb8-array-to-base64-stream - #:stream-to-base64-string - #:stream-to-base64-stream - #:integer-to-base64-string - #:integer-to-base64-stream + #:base64-string-to-integer + #:base64-string-to-string + #:base64-stream-to-string + #:base64-string-to-stream + #:base64-stream-to-stream + #:base64-string-to-usb8-array + #:base64-stream-to-usb8-array + #:string-to-base64-string + #:string-to-base64-stream + #:usb8-array-to-base64-string + #:usb8-array-to-base64-stream + #:stream-to-base64-string + #:stream-to-base64-stream + #:integer-to-base64-string + #:integer-to-base64-stream - ;; For creating custom encode/decode tables - #:*uri-encode-table* - #:*uri-decode-table* - #:make-decode-table + ;; For creating custom encode/decode tables + #:*uri-encode-table* + #:*uri-decode-table* + #:make-decode-table - #:test-base64 - )) + #:test-base64 + )) (in-package #:cl-base64) @@ -54,18 +54,18 @@ (defun make-decode-table (encode-table) (let ((dt (make-array 256 :adjustable nil :fill-pointer nil - :element-type 'fixnum - :initial-element -1))) + :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 *pad-char* #\=) (defvar *uri-pad-char* #\.) (declaim (type character *pad-char* *uri-pad-char*)) diff --git a/tests.lisp b/tests.lisp index 7e5d3ff..927e4b8 100644 --- a/tests.lisp +++ b/tests.lisp @@ -21,53 +21,53 @@ (with-tests (:name "cl-base64 tests") (let ((*break-on-test-failures* t)) (do* ((length 0 (+ 3 length)) - (string (make-string length) (make-string length)) - (usb8 (make-usb8-array length) (make-usb8-array length)) - (integer (random (expt 10 length)) (random (expt 10 length)))) - ((>= length 300)) - (dotimes (i length) - (declare (fixnum i)) - (let ((code (random 256))) - (setf (schar string i) (code-char code)) - (setf (aref usb8 i) code))) - - (do* ((columns 0 (+ columns 4))) - ((> columns length)) - ;; Test against cl-base64 routines - (test integer (base64-string-to-integer - (integer-to-base64-string integer :columns columns))) - (test string (base64-string-to-string - (string-to-base64-string string :columns columns)) - :test #'string=) - - ;; Test against AllegroCL built-in routines - #+allegro - (progn - (test integer (excl:base64-string-to-integer - (integer-to-base64-string integer :columns columns))) - (test integer (base64-string-to-integer - (excl:integer-to-base64-string integer))) - (test (string-to-base64-string string :columns columns) - (excl:usb8-array-to-base64-string usb8 - (if (zerop columns) - nil - columns)) - :test #'string=) - (test string (base64-string-to-string - (excl:usb8-array-to-base64-string - usb8 - (if (zerop columns) - nil - columns))) - :test #'string=)))))) + (string (make-string length) (make-string length)) + (usb8 (make-usb8-array length) (make-usb8-array length)) + (integer (random (expt 10 length)) (random (expt 10 length)))) + ((>= length 300)) + (dotimes (i length) + (declare (fixnum i)) + (let ((code (random 256))) + (setf (schar string i) (code-char code)) + (setf (aref usb8 i) code))) + + (do* ((columns 0 (+ columns 4))) + ((> columns length)) + ;; Test against cl-base64 routines + (test integer (base64-string-to-integer + (integer-to-base64-string integer :columns columns))) + (test string (base64-string-to-string + (string-to-base64-string string :columns columns)) + :test #'string=) + + ;; Test against AllegroCL built-in routines + #+allegro + (progn + (test integer (excl:base64-string-to-integer + (integer-to-base64-string integer :columns columns))) + (test integer (base64-string-to-integer + (excl:integer-to-base64-string integer))) + (test (string-to-base64-string string :columns columns) + (excl:usb8-array-to-base64-string usb8 + (if (zerop columns) + nil + columns)) + :test #'string=) + (test string (base64-string-to-string + (excl:usb8-array-to-base64-string + usb8 + (if (zerop columns) + nil + columns))) + :test #'string=)))))) t) (defun time-routines () (let* ((str "abcdefghijklmnopqwertyu1234589jhwf2ff") - (usb8 (string-to-usb8-array str)) - (int 12345678901234567890) - (n 50000)) + (usb8 (string-to-usb8-array str)) + (int 12345678901234567890) + (n 50000)) (time-iterations n (integer-to-base64-string int)) (time-iterations n (string-to-base64-string str)) #+allego @@ -75,5 +75,5 @@ (time-iterations n (excl:integer-to-base64-string int)) (time-iterations n (excl:usb8-array-to-base64-string usb8))))) - + ;;#+run-test (test-base64)