From ecff5c5549684a5636a0436961b879177dc1039f Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Wed, 30 Sep 2020 18:12:02 +0000 Subject: [PATCH] Updates for modern ASDF test-op. Performance and safety improvements (thanks to Janis Dzerins) --- cl-base64.asd | 25 +-- debian/changelog | 7 + debian/compat | 2 +- debian/control | 2 +- decode.lisp | 426 ++++++++++++++++++++++++----------------------- encode.lisp | 8 +- package.lisp | 70 +++++--- tests.lisp | 114 +++++++++++-- 8 files changed, 386 insertions(+), 268 deletions(-) diff --git a/cl-base64.asd b/cl-base64.asd index 252389d..59a3e6b 100644 --- a/cl-base64.asd +++ b/cl-base64.asd @@ -7,7 +7,6 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Dec 2002 ;;;; -;;;; $Id$ ;;;; ************************************************************************* (in-package #:cl-user) @@ -18,27 +17,21 @@ (defsystem cl-base64 :name "cl-base64" :author "Kevin M. Rosenberg based on initial code by Juri Pakaste" - :version "3.1" + :version "3.4" :maintainer "Kevin M. Rosenberg " :licence "BSD-style" :description "Base64 encoding and decoding with URI support." :components ((:file "package") (:file "encode" :depends-on ("package")) - (:file "decode" :depends-on ("package")) - )) + (:file "decode" :depends-on ("package"))) + :in-order-to ((test-op (test-op "cl-base64/test")))) -(defmethod perform ((o test-op) (c (eql (find-system 'cl-base64)))) - (operate 'load-op 'cl-base64-tests) - (operate 'test-op 'cl-base64-tests :force t)) - -(defsystem cl-base64-tests +(defsystem cl-base64/test :depends-on (cl-base64 ptester kmrcl) :components - ((:file "tests"))) - -(defmethod perform ((o test-op) (c (eql (find-system 'cl-base64-tests)))) - (operate 'load-op 'cl-base64-tests) - (or (funcall (intern (symbol-name '#:do-tests) - (find-package '#:cl-base64-tests))) - (error "test-op failed"))) + ((:file "tests")) + :perform (test-op (o s) + (or (funcall (intern (symbol-name '#:do-tests) + (find-package '#:cl-base64/test))) + (error "test-op failed")))) diff --git a/debian/changelog b/debian/changelog index c1fd12f..8610439 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,10 @@ +cl-base64 (3.4.0-1) unstable; urgency=medium + + * New upstream. + Performance and safety improvements (thanks to Janis Dzerins) + + -- Kevin M. Rosenberg Wed, 30 Sep 2020 18:06:36 +0000 + cl-base64 (3.3.4-1) unstable; urgency=medium * New upstream. (closes:796978) Thanks to Denis Martinez. diff --git a/debian/compat b/debian/compat index 7f8f011..b4de394 100644 --- a/debian/compat +++ b/debian/compat @@ -1 +1 @@ -7 +11 diff --git a/debian/control b/debian/control index a72cbc8..c111842 100644 --- a/debian/control +++ b/debian/control @@ -3,7 +3,7 @@ Section: lisp Priority: optional Maintainer: Kevin M. Rosenberg Build-Depends-Indep: dh-lisp -Build-Depends: debhelper (>= 7.0.0) +Build-Depends: debhelper (>= 11.0.0) Standards-Version: 3.9.5.0 Homepage: http://files.kpe.io/cl-base64/ Vcs-Git: git://git.kpe.io/cl-base64.git diff --git a/decode.lisp b/decode.lisp index 515b4d0..1c7f336 100644 --- a/decode.lisp +++ b/decode.lisp @@ -21,236 +21,240 @@ (in-package #:cl-base64) -(declaim (inline whitespace-p)) -(defun whitespace-p (c) - "Returns T for a whitespace character." - (or (char= c #\Newline) (char= c #\Linefeed) - (char= c #\Return) (char= c #\Space) - (char= c #\Tab))) +(define-condition base64-error (error) + ((input + :initarg :input + :reader base64-error-input) + (position + :initarg :position + :reader base64-error-position + :type unsigned-byte))) +(define-condition bad-base64-character (base64-error) + ((code :initarg :code :reader bad-base64-character-code)) + (:report (lambda (condition stream) + (format stream "Bad character ~S at index ~D of ~S" + (code-char (bad-base64-character-code condition)) + (base64-error-position condition) + (base64-error-input condition))))) -;;; Decoding +(define-condition incomplete-base64-data (base64-error) + () + (:report (lambda (condition stream) + (format stream "Unexpected end of Base64 data at index ~D of ~S" + (base64-error-position condition) + (base64-error-input condition))))) -#+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))) - ,(concatenate 'string "Decode base64 stream to " (string-downcase - (symbol-name output-type))) - (declare (stream input) - (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*))) - (declare (type decode-table decode-table) - (type character pad)) - (let (,@(case output-type - (:string - '((result (make-string (* 3 (truncate (length string) 4)))))) +(deftype array-index (&optional (length array-dimension-limit)) + `(integer 0 (,length))) + +(deftype array-length (&optional (length array-dimension-limit)) + `(integer 0 ,length)) + +(deftype character-code () + `(integer 0 (,char-code-limit))) + +(defmacro etypecase/unroll ((var &rest types) &body body) + #+sbcl `(etypecase ,var + ,@(loop for type in types + collect `(,type ,@body))) + #-sbcl `(locally + (declare (type (or ,@types) ,var)) + ,@body)) + +(defmacro let/typed ((&rest vars) &body body) + `(let ,(loop for (var value) in vars + collect (list var value)) + (declare ,@(loop for (var nil type) in vars + when type + collect (list 'type type var))) + ,@body)) + +(defmacro define-base64-decoder (hose sink) + `(defun ,(intern (format nil "~A-~A-~A-~A" '#:base64 hose '#:to sink)) + (input &key (table +decode-table+) + (uri nil) + ,@(when (eq sink :stream) `(stream)) + (whitespace :ignore)) + ,(format nil "~ +Decode Base64 ~(~A~) to ~(~A~). + +TABLE is the decode table to use. Two decode tables are provided: ++DECODE-TABLE+ (used by default) and +URI-DECODE-TABLE+. See +MAKE-DECODE-TABLE. + +For backwards-compatibility the URI parameter is supported. If it is +true, then +URI-DECODE-TABLE+ is used, and the value for TABLE +parameter is ignored. + +WHITESPACE can be one of: + + :ignore - Whitespace characters are ignored (default). + :signal - Signal a BAD-BASE64-CHARACTER condition using SIGNAL. + :error - Signal a BAD-BASE64-CHARACTER condition using ERROR." + hose sink) + (declare (optimize (speed 3) (safety 1)) + (type decode-table table) + (type ,(ecase hose + (:stream 'stream) + (:string 'string)) + input)) + (let/typed ((decode-table (if uri +uri-decode-table+ table) + decode-table) + ,@(ecase sink + (:stream) (:usb8-array - '((result (make-array (* 3 (truncate (length string) 4)) + (ecase hose + (:stream + `((result (make-array 1024 :element-type '(unsigned-byte 8) - :fill-pointer nil - :adjustable nil))))) - (ridx 0)) - (declare ,@(case output-type + :adjustable t + :fill-pointer 0) + (array (unsigned-byte 8) (*))))) + (:string + `((result (make-array (* 3 (ceiling (length input) 4)) + :element-type '(unsigned-byte 8)) + (simple-array (unsigned-byte 8) (*))) + (rpos 0 array-index))))) (:string - '((simple-string result))) - (:usb8-array - '((type (simple-array (unsigned-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 + (case hose (: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)) + `((result (make-array 1024 + :element-type 'character + :adjustable t + :fill-pointer 0) + (array character (*))))) + (:string + `((result (make-array (* 3 (ceiling (length input) 4)) + :element-type 'character) + (simple-array character (*))) + (rpos 0 array-index))))) + (:integer + `((result 0 unsigned-byte))))) + (flet ((bad-char (pos code &optional (action :error)) + (let ((args (list 'bad-base64-character + :input input + :position pos + :code code))) + (ecase action + (:error + (apply #'error args)) + (:cerror + (apply #'cerror "Ignore the error and continue." args)) + (:signal + (apply #'signal args))))) + (incomplete-input (pos) + (error 'incomplete-base64-data :input input :position pos))) + ,(let ((body + `(let/typed ((ipos 0 array-index) + (bitstore 0 (unsigned-byte 24)) + (bitcount 0 (integer 0 14)) + (svalue -1 (signed-byte 8)) + (padchar 0 (integer 0 3)) + (code 0 fixnum)) + (loop + ,@(ecase hose + (:string + `((if (< ipos length) + (setq code (char-code (aref input ipos))) + (return)))) + (:stream + `((let ((char (read-char input nil nil))) + (if char + (setq code (char-code char)) + (return)))))) (cond - ((>= svalue 0) - (setf bitstore (logior - (the fixnum (ash bitstore 6)) + ((or (< 127 code) + (= -1 (setq svalue (aref decode-table code)))) + (bad-char ipos code)) + ((= -2 svalue) + (cond ((<= (incf padchar) 2) + (unless (<= 2 bitcount) + (bad-char ipos code)) + (decf bitcount 2)) + (t + (bad-char ipos code)))) + ((= -3 svalue) + (ecase whitespace + (:ignore + ;; Do nothing. + ) + (:error + (bad-char ipos code :error)) + (:signal + (bad-char ipos code :signal)))) + ((not (zerop padchar)) + (bad-char ipos code)) + (t + (setf bitstore (logior (the (unsigned-byte 24) + (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))) + (let ((byte (logand (the (unsigned-byte 24) + (ash bitstore (- bitcount))) + #xFF))) + (declare (type (unsigned-byte 8) byte)) + ,@(ecase sink (:usb8-array - '(setf (aref result ridx) ovalue)) + (ecase hose + (:string + `((setf (aref result rpos) byte) + (incf rpos))) (: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) (safety 0) (space 0))) - (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 + `((vector-push-extend byte result))))) (: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 + (ecase hose (: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 + `((setf (schar result rpos) + (code-char byte)) + (incf rpos))) + (:stream + `((vector-push-extend (code-char byte) + result))))) + (:integer + `((setq result + (logior (ash result 8) byte)))) + (:stream + '((write-char (code-char byte) stream))))) + (setf bitstore (logand bitstore #xFF))))) + (incf ipos)) + (unless (zerop bitcount) + (incomplete-input ipos)) + ,(ecase sink + ((:string :usb8-array) + (ecase hose (:string - '(setf (char result ridx) (code-char ovalue))) - (:usb8-array - '(setf (aref result ridx) ovalue)) + `(if (= rpos (length result)) + result + (subseq result 0 rpos))) (: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))))))) + `(copy-seq result)))) + (:integer + 'result) + (:stream + 'stream))))) + (ecase hose + (:string + `(let ((length (length input))) + (declare (type array-length length)) + (etypecase/unroll (input simple-base-string + simple-string + string) + ,body))) + (:stream + body))))))) + +(define-base64-decoder :string :usb8-array) +(define-base64-decoder :string :string) +(define-base64-decoder :string :integer) +(define-base64-decoder :string :stream) -(def-base64-string-to-* :string) -(def-base64-string-to-* :stream) -(def-base64-string-to-* :usb8-array) +(define-base64-decoder :stream :usb8-array) +(define-base64-decoder :stream :string) +(define-base64-decoder :stream :integer) +(define-base64-decoder :stream :stream) ;; input-mode can be :string or :stream ;; input-format can be :character or :usb8 - -(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))) - (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 ((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)))) - 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))) - (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)) - (do* ((value 0) - (char (read-char stream nil #\null) - (read-char stream nil #\null))) - ((eq char #\null) - value) - (declare (integer value) - (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))))))) diff --git a/encode.lisp b/encode.lisp index dcddc1a..1c4a4ec 100644 --- a/encode.lisp +++ b/encode.lisp @@ -33,7 +33,7 @@ (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 1) (space 0))) (let ((remainder (mod x n))) (declare (fixnum remainder)) (if (zerop remainder) @@ -57,7 +57,7 @@ with a #\Newline." (:usb8-array '((type (array (unsigned-byte 8) (*)) input)))) (fixnum columns) - (optimize (speed 3) (safety 0) (space 0))) + (optimize (speed 3) (safety 1) (space 0))) (let ((pad (if uri *uri-pad-char* *pad-char*)) (encode-table (if uri *uri-encode-table* *encode-table*))) (declare (simple-string encode-table) @@ -212,7 +212,7 @@ with a #\Newline." "Encode an integer to base64 format." (declare (integer input) (fixnum columns) - (optimize (speed 3) (space 0) (safety 0))) + (optimize (speed 3) (space 0) (safety 1))) (let ((pad (if uri *uri-pad-char* *pad-char*)) (encode-table (if uri *uri-encode-table* *encode-table*))) (declare (simple-string encode-table) @@ -271,7 +271,7 @@ with a #\Newline." "Encode an integer to base64 format." (declare (integer input) (fixnum columns) - (optimize (speed 3) (space 0) (safety 0))) + (optimize (speed 3) (space 0) (safety 1))) (let ((pad (if uri *uri-pad-char* *pad-char*)) (encode-table (if uri *uri-encode-table* *encode-table*))) (declare (simple-string encode-table) diff --git a/package.lisp b/package.lisp index 5eac241..71524cf 100644 --- a/package.lisp +++ b/package.lisp @@ -15,13 +15,13 @@ (:nicknames #:base64) (:use #:cl) (:export #:base64-stream-to-integer + #:base64-stream-to-string + #:base64-stream-to-stream + #:base64-stream-to-usb8-array #: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 @@ -31,17 +31,23 @@ #:integer-to-base64-string #:integer-to-base64-stream - ;; For creating custom encode/decode tables + ;; Conditions. + #:base64-error + #:bad-base64-character + #:incomplete-base64-data + + ;; For creating custom encode/decode tables. + #:make-decode-table + #:+decode-table+ + #:+uri-decode-table+ + ;; What's the point of exporting these? #:*uri-encode-table* #:*uri-decode-table* - #:make-decode-table - - #:test-base64 )) (in-package #:cl-base64) - +(eval-when (:compile-toplevel :load-toplevel :execute) (defvar *encode-table* "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") (declaim (type simple-string *encode-table*)) @@ -50,22 +56,38 @@ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_") (declaim (type simple-string *uri-encode-table*)) -(deftype decode-table () '(simple-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 *pad-char* #\=) (defvar *uri-pad-char* #\.) (declaim (type character *pad-char* *uri-pad-char*)) + + (deftype decode-table () '(simple-array (signed-byte 8) (128))) + (defun make-decode-table (encode-table pad-char + &key (whitespace-chars + '(#\Linefeed #\Return #\Space #\Tab))) + (assert (< (length encode-table) 128) + (encode-table) + "Encode table too big: ~S" encode-table) + (let ((dt (make-array 128 :element-type '(signed-byte 8) + :initial-element -1))) + (declare (type decode-table dt)) + (loop for char across encode-table + for index upfrom 0 + do (setf (aref dt (char-code char)) index)) + (setf (aref dt (char-code pad-char)) -2) + (loop for char in whitespace-chars + do (setf (aref dt (char-code char)) -3)) + dt))) + +(defconstant +decode-table+ + (if (boundp '+decode-table+) + (symbol-value '+decode-table+) + (make-decode-table *encode-table* *pad-char*))) +(defvar *decode-table* +decode-table+ "Deprecated.") +(declaim (type decode-table +decode-table+ *decode-table*)) + +(defconstant +uri-decode-table+ + (if (boundp '+uri-decode-table+) + (symbol-value '+uri-decode-table+) + (make-decode-table *uri-encode-table* *uri-pad-char*))) +(defvar *uri-decode-table* +uri-decode-table+ "Deprecated.") +(declaim (type decode-table +uri-decode-table+ *uri-decode-table*)) diff --git a/tests.lisp b/tests.lisp index 927e4b8..06aebdf 100644 --- a/tests.lisp +++ b/tests.lisp @@ -12,14 +12,86 @@ (in-package #:cl-user) -(defpackage #:cl-base64-tests +(defpackage #:cl-base64/test (:use #:cl #:kmrcl #:cl-base64 #:ptester)) -(in-package #:cl-base64-tests) +(in-package #:cl-base64/test) -(defun do-tests () +(defun test-valid-input (exp input) + (test exp (base64-string-to-usb8-array input) :test #'equalp)) + +(defun test-broken-input (arg) + (let ((.hole. (make-broadcast-stream))) + (test-error (base64-string-to-usb8-array arg) + :condition-type 'base64-error + :include-subtypes t) + (test-error (base64-string-to-string arg) + :condition-type 'base64-error + :include-subtypes t) + (test-error (base64-string-to-integer arg) + :condition-type 'base64-error + :include-subtypes t) + (test-error (base64-string-to-stream arg :stream .hole.) + :condition-type 'base64-error + :include-subtypes t) + (test-error (with-input-from-string (in arg) + (base64-stream-to-usb8-array in)) + :condition-type 'base64-error + :include-subtypes t) + (test-error (with-input-from-string (in arg) + (base64-stream-to-string in)) + :condition-type 'base64-error + :include-subtypes t) + (test-error (with-input-from-string (in arg) + (base64-stream-to-stream in :stream .hole.)) + :condition-type 'base64-error + :include-subtypes t) + (test-error (with-input-from-string (in arg) + (base64-stream-to-integer in)) + :condition-type 'base64-error + :include-subtypes t))) + +(defun test-valid () + (test-valid-input #(0) "AA==") + (test-valid-input #(0 0) "AAA=") + (test-valid-input #(0 0 0) "AAAA") + (test-valid-input #(0) " A A = = ") + (test-valid-input #(0 0) " A A A = ") + (test-valid-input #(0 0 0) " A A A A ")) + +(defun test-broken-1 () + (test-broken-input "A") + (test-broken-input "AA") + (test-broken-input "AAA") + (test-broken-input "AA=") + (test-broken-input "A==") + (test-broken-input "A===") + (test-broken-input "AA===") + (test-broken-input "AAA===") + (test-broken-input "AAA==") + (test-broken-input "A=A") + (test-broken-input "AA=A") + (test-broken-input "AAA=A") + (test-broken-input "A==A")) + +(defun test-broken-2 () + (flet ((test-invalid-char (char) + (test-broken-input (format nil "~C" char)) + (test-broken-input (format nil "A~C" char)) + (test-broken-input (format nil "AA~C" char)) + (test-broken-input (format nil "AAA~C" char)) + (test-broken-input (format nil "AAAA~C" char)) + (test-broken-input (format nil "AAA=~C" char)) + (test-broken-input (format nil "AA==~C" char)))) + (test-invalid-char #\$) + (test-invalid-char (code-char 0)) + (test-invalid-char (code-char 256)))) + +(defun do-tests (&key ((:break-on-failures *break-on-test-failures*) nil)) (with-tests (:name "cl-base64 tests") - (let ((*break-on-test-failures* t)) + (test-valid) + (test-broken-1) + (test-broken-2) (do* ((length 0 (+ 3 length)) (string (make-string length) (make-string length)) (usb8 (make-usb8-array length) (make-usb8-array length)) @@ -39,6 +111,9 @@ (test string (base64-string-to-string (string-to-base64-string string :columns columns)) :test #'string=) + (test usb8 (base64-string-to-usb8-array + (usb8-array-to-base64-string usb8)) + :test #'equalp) ;; Test against AllegroCL built-in routines #+allegro @@ -59,18 +134,35 @@ (if (zerop columns) nil columns))) - :test #'string=)))))) + :test #'string=))))) t) -(defun time-routines () - (let* ((str "abcdefghijklmnopqwertyu1234589jhwf2ff") - (usb8 (string-to-usb8-array str)) +(defun time-routines (&key (iterations nil) + (length 256) + (padding 0)) + (assert (zerop (rem length 4)) (length)) + (assert (<= 0 padding 2) (padding)) + (let* ((str (make-string length :initial-element #\q)) + (usb8 (map '(simple-array (unsigned-byte 8) (*)) #'char-code str)) (int 12345678901234567890) - (n 50000)) - (time-iterations n (integer-to-base64-string int)) + (n (or iterations (ceiling (* 32 1024 1024) length)))) + (loop for i downfrom (1- length) + repeat padding + do (setf (aref str i) #\=)) + (time-iterations 50000 (integer-to-base64-string int)) (time-iterations n (string-to-base64-string str)) - #+allego + (time-iterations n (usb8-array-to-base64-string usb8)) + + (let ((displaced (make-array (length str) + :displaced-to str + :element-type (array-element-type str))) + (base (coerce str 'simple-base-string))) + (time-iterations n (base64-string-to-usb8-array displaced)) + (time-iterations n (base64-string-to-usb8-array str)) + (time-iterations n (base64-string-to-usb8-array base))) + + #+allegro (progn (time-iterations n (excl:integer-to-base64-string int)) (time-iterations n (excl:usb8-array-to-base64-string usb8))))) -- 2.34.1