tests.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          test.lisp
   6 ;;;; Purpose:       Regression tests for cl-base64
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Jan 2003
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;; *************************************************************************
  12
  13 (in-package #:cl-user)
  14
  15 (defpackage #:cl-base64/test
  16   (:use #:cl #:kmrcl #:cl-base64 #:ptester))
  17
  18 (in-package #:cl-base64/test)
  19
  20 (defun test-valid-input (exp input)
  21   (test exp (base64-string-to-usb8-array input) :test #'equalp))
  22
  23 (defun test-broken-input (arg)
  24   (let ((.hole. (make-broadcast-stream)))
  25     (test-error (base64-string-to-usb8-array arg)
  26                 :condition-type 'base64-error
  27                 :include-subtypes t)
  28     (test-error (base64-string-to-string arg)
  29                 :condition-type 'base64-error
  30                 :include-subtypes t)
  31     (test-error (base64-string-to-integer arg)
  32                 :condition-type 'base64-error
  33                 :include-subtypes t)
  34     (test-error (base64-string-to-stream arg :stream .hole.)
  35                 :condition-type 'base64-error
  36                 :include-subtypes t)
  37     (test-error (with-input-from-string (in arg)
  38                   (base64-stream-to-usb8-array in))
  39                 :condition-type 'base64-error
  40                 :include-subtypes t)
  41     (test-error (with-input-from-string (in arg)
  42                   (base64-stream-to-string in))
  43                 :condition-type 'base64-error
  44                 :include-subtypes t)
  45     (test-error (with-input-from-string (in arg)
  46                   (base64-stream-to-stream in :stream .hole.))
  47                 :condition-type 'base64-error
  48                 :include-subtypes t)
  49     (test-error (with-input-from-string (in arg)
  50                   (base64-stream-to-integer in))
  51                 :condition-type 'base64-error
  52                 :include-subtypes t)))
  53
  54 (defun test-valid ()
  55   (test-valid-input #(0) "AA==")
  56   (test-valid-input #(0 0) "AAA=")
  57   (test-valid-input #(0 0 0) "AAAA")
  58   (test-valid-input #(0) " A A = = ")
  59   (test-valid-input #(0 0) " A A A = ")
  60   (test-valid-input #(0 0 0) " A A A A "))
  61
  62 (defun test-broken-1 ()
  63   (test-broken-input "A")
  64   (test-broken-input "AA")
  65   (test-broken-input "AAA")
  66   (test-broken-input "AA=")
  67   (test-broken-input "A==")
  68   (test-broken-input "A===")
  69   (test-broken-input "AA===")
  70   (test-broken-input "AAA===")
  71   (test-broken-input "AAA==")
  72   (test-broken-input "A=A")
  73   (test-broken-input "AA=A")
  74   (test-broken-input "AAA=A")
  75   (test-broken-input "A==A"))
  76
  77 (defun test-broken-2 ()
  78   (flet ((test-invalid-char (char)
  79            (test-broken-input (format nil "~C" char))
  80            (test-broken-input (format nil "A~C" char))
  81            (test-broken-input (format nil "AA~C" char))
  82            (test-broken-input (format nil "AAA~C" char))
  83            (test-broken-input (format nil "AAAA~C" char))
  84            (test-broken-input (format nil "AAA=~C" char))
  85            (test-broken-input (format nil "AA==~C" char))))
  86     (test-invalid-char #\$)
  87     (test-invalid-char (code-char 0))
  88     (test-invalid-char (code-char 256))))
  89
  90 (defun do-tests (&key ((:break-on-failures *break-on-test-failures*) nil))
  91   (with-tests (:name "cl-base64 tests")
  92     (test-valid)
  93     (test-broken-1)
  94     (test-broken-2)
  95       (do* ((length 0 (+ 3 length))
  96             (string (make-string length) (make-string length))
  97             (usb8 (make-usb8-array length) (make-usb8-array length))
  98             (integer (random (expt 10 length)) (random (expt 10 length))))
  99            ((>= length 300))
 100         (dotimes (i length)
 101           (declare (fixnum i))
 102           (let ((code (random 256)))
 103             (setf (schar string i) (code-char code))
 104         (setf (aref usb8 i) code)))
 105
 106         (do* ((columns 0 (+ columns 4)))
 107              ((> columns length))
 108           ;; Test against cl-base64 routines
 109           (test integer (base64-string-to-integer
 110                          (integer-to-base64-string integer :columns columns)))
 111           (test string (base64-string-to-string
 112                         (string-to-base64-string string :columns columns))
 113                 :test #'string=)
 114         (test usb8 (base64-string-to-usb8-array
 115                     (usb8-array-to-base64-string usb8))
 116               :test #'equalp)
 117
 118           ;; Test against AllegroCL built-in routines
 119           #+allegro
 120           (progn
 121           (test integer (excl:base64-string-to-integer
 122                          (integer-to-base64-string integer :columns columns)))
 123           (test integer (base64-string-to-integer
 124                          (excl:integer-to-base64-string integer)))
 125           (test (string-to-base64-string string :columns columns)
 126                 (excl:usb8-array-to-base64-string usb8
 127                                                   (if (zerop columns)
 128                                                       nil
 129                                                       columns))
 130                 :test #'string=)
 131           (test string (base64-string-to-string
 132                         (excl:usb8-array-to-base64-string
 133                          usb8
 134                          (if (zerop columns)
 135                              nil
 136                              columns)))
 137                 :test #'string=)))))
 138   t)
 139
 140
 141 (defun time-routines (&key (iterations nil)
 142                            (length 256)
 143                            (padding 0))
 144   (assert (zerop (rem length 4)) (length))
 145   (assert (<= 0 padding 2) (padding))
 146   (let* ((str (make-string length :initial-element #\q))
 147          (usb8 (map '(simple-array (unsigned-byte 8) (*)) #'char-code str))
 148          (int 12345678901234567890)
 149          (n (or iterations (ceiling (* 32 1024 1024) length))))
 150     (loop for i downfrom (1- length)
 151           repeat padding
 152           do (setf (aref str i) #\=))
 153     (time-iterations 50000 (integer-to-base64-string int))
 154     (time-iterations n (string-to-base64-string str))
 155     (time-iterations n (usb8-array-to-base64-string usb8))
 156
 157     (let ((displaced (make-array (length str)
 158                                  :displaced-to str
 159                                  :element-type (array-element-type str)))
 160           (base (coerce str 'simple-base-string)))
 161       (time-iterations n (base64-string-to-usb8-array displaced))
 162       (time-iterations n (base64-string-to-usb8-array str))
 163       (time-iterations n (base64-string-to-usb8-array base)))
 164
 165     #+allegro
 166     (progn
 167       (time-iterations n (excl:integer-to-base64-string int))
 168       (time-iterations n (excl:usb8-array-to-base64-string usb8)))))
 169
 170
 171 ;;#+run-test (test-base64)