tests.lisp 1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package:CL-WHO-TEST; Base: 10 -*-
2 ;;; $Header: /usr/local/cvsrep/cl-who/test/tests.lisp,v 1.5 2009/01/26 11:10:52 edi Exp $
3
4 ;;; Copyright (c) 2008-2009, Dr. Edmund Weitz. All rights reserved.
5
6 ;;; Redistribution and use in source and binary forms, with or without
7 ;;; modification, are permitted provided that the following conditions
8 ;;; are met:
9
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
12
13 ;;; * Redistributions in binary form must reproduce the above
14 ;;; copyright notice, this list of conditions and the following
15 ;;; disclaimer in the documentation and/or other materials
16 ;;; provided with the distribution.
17
18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
21 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29
30 (in-package :cl-who-test)
31
32 (defvar *initial-settings*
33 (list #\'
34 t
35 (lambda (char)
36 (or (find char "<>&'\"")
37 (> (char-code char) 127)))
38 t
39 '(:area
40 :atop
41 :audioscope
42 :base
43 :basefont
44 :br
45 :choose
46 :col
47 :frame
48 :hr
49 :img
50 :input
51 :isindex
52 :keygen
53 :left
54 :limittext
55 :link
56 :meta
57 :nextid
58 :of
59 :over
60 :param
61 :range
62 :right
63 :spacer
64 :spot
65 :tab
66 :wbr)
67 "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"))
68
69 (defvar *this-file* (load-time-value
70 (or #.*compile-file-pathname* *load-pathname*))
71 "The location of this source file.")
72
73 (defmacro do-tests ((name &optional show-progress-p) &body body)
74 "Helper macro which repeatedly executes BODY until the code in body
75 calls the function DONE. It is assumed that each invocation of BODY
76 will be the execution of one test which returns NIL in case of success
77 and list of string describing errors otherwise.
78
79 The macro prints a simple progress indicator \(one dots for ten tests)
80 to *STANDARD-OUTPUT* unless SHOW-PROGRESS-P is NIL and returns a true
81 value iff all tests succeeded. Errors in BODY are caught and reported
82 \(and counted as failures)."
83 `(let ((successp t)
84 (testcount 1))
85 (block test-block
86 (flet ((done ()
87 (return-from test-block successp)))
88 (format t "~&Test: ~A~%" ,name)
89 (loop
90 (when (and ,show-progress-p (zerop (mod testcount 1)))
91 (format t ".")
92 (when (zerop (mod testcount 10))
93 (terpri))
94 (force-output))
95 (let ((errors
96 (handler-case
97 (progn ,@body)
98 (error (msg)
99 (list (format nil "~&got an unexpected error: ~A" msg))))))
100 (setq successp (and successp (null errors)))
101 (when errors
102 (format t "~&~4@A:~{~& ~A~}~%" testcount errors))
103 (incf testcount)))))
104 successp))
105
106 (defun simple-tests (&key (file-name
107 (make-pathname :name "simple"
108 :type nil :version nil
109 :defaults *this-file*))
110 (external-format '(:latin-1 :eol-style :lf))
111 verbose)
112 "Loops through all the forms in the file FILE-NAME and executes each
113 of them using EVAL. It is assumed that each FORM specifies a test
114 which returns a true value iff it succeeds. Prints each test form to
115 *STANDARD-OUTPUT* if VERBOSE is true and shows a simple progress
116 indicator otherwise. EXTERNAL-FORMAT is the FLEXI-STREAMS external
117 format which is used to read the file. Returns a true value iff all
118 tests succeeded."
119 (with-open-file (binary-stream file-name :element-type 'flex:octet)
120 (let ((stream (flex:make-flexi-stream binary-stream :external-format external-format))
121 (*package* (find-package :cl-who-test))
122 (html-mode (html-mode)))
123 (unwind-protect
124 (destructuring-bind (*attribute-quote-char*
125 *downcase-tokens-p*
126 *escape-char-p*
127 *html-empty-tag-aware-p*
128 *html-empty-tags*
129 *prologue*)
130 *initial-settings*
131 (setf (html-mode) :xml)
132 (do-tests ((format nil "Simple tests from file ~S" (file-namestring file-name))
133 (not verbose))
134 (let ((form (or (read stream nil) (done))))
135 (when verbose
136 (format t "~&~S" form))
137 (cond ((and (consp form) (eq 'string= (car form))
138 (stringp (third form)))
139 (destructuring-bind (gen expected) (cdr form)
140 (let ((actual (eval gen)))
141 (unless (string= actual expected)
142 (list (format nil "~@<~:@_ ~2:I~S~:@_Expected: ~S~
143 ~@:_ Actual: ~S~:>"
144 form expected actual))))))
145 ((eval form) nil)
146 (t (list (format nil "~S returned NIL" form)))))))
147 (setf (html-mode) html-mode)))))
148
149 (defun run-all-tests (&key verbose)
150 "Runs all tests for CL-WHO and returns a true value iff all tests
151 succeeded. VERBOSE is interpreted by the individual test suites."
152 (let ((successp t))
153 (macrolet ((run-test-suite (&body body)
154 `(unless (progn ,@body)
155 (setq successp nil))))
156 (run-test-suite (simple-tests :verbose verbose)))
157 (format t "~2&~:[Some tests failed~;All tests passed~]." successp)
158 successp))