Updates for modern ASDF test-op. Performance and safety improvements (thanks to Janis...

[cl-base64.git] / tests.lisp

diff --git a/tests.lisp b/tests.lisp
index 927e4b8c606c4bd270e58f236b3b42137d394068..06aebdfa5ca0c74feff220d8aab03a5b8256997c 100644 (file)
--- 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)))))