Squashed 'third_party/lisp/fiveam/' content from commit ee9456a2
git-subtree-dir: third_party/lisp/fiveam git-subtree-split: ee9456a2ac52b1c9f5f5f789d263f0f76a15176c
This commit is contained in:
		
						commit
						728a186263
					
				
					 20 changed files with 2596 additions and 0 deletions
				
			
		
							
								
								
									
										14
									
								
								.boring
									
										
									
									
									
										Normal file
									
								
							
							
						
						
									
										14
									
								
								.boring
									
										
									
									
									
										Normal file
									
								
							|  | @ -0,0 +1,14 @@ | ||||||
|  | # Boring file regexps: | ||||||
|  | \# | ||||||
|  | ~$ | ||||||
|  | (^|/)_darcs($|/) | ||||||
|  | \.dfsl$ | ||||||
|  | \.ppcf$ | ||||||
|  | \.fasl$ | ||||||
|  | \.x86f$ | ||||||
|  | \.fas$ | ||||||
|  | \.lib$ | ||||||
|  | ^docs/html($|/) | ||||||
|  | ^docs/pdf($|/) | ||||||
|  | ^\{arch\}$ | ||||||
|  | (^|/).arch-ids($|/) | ||||||
							
								
								
									
										47
									
								
								.travis.yml
									
										
									
									
									
										Normal file
									
								
							
							
						
						
									
										47
									
								
								.travis.yml
									
										
									
									
									
										Normal file
									
								
							|  | @ -0,0 +1,47 @@ | ||||||
|  | dist: bionic | ||||||
|  | language: lisp | ||||||
|  | 
 | ||||||
|  | env: | ||||||
|  |   matrix: | ||||||
|  |     - LISP=abcl | ||||||
|  |     - LISP=allegro | ||||||
|  |     - LISP=ccl | ||||||
|  |     - LISP=ccl32 | ||||||
|  |     - LISP=ecl | ||||||
|  |     - LISP=sbcl | ||||||
|  |     - LISP=sbcl32 | ||||||
|  |     - LISP=cmucl | ||||||
|  | 
 | ||||||
|  | matrix: | ||||||
|  |   allow_failures: | ||||||
|  |     - env: LISP=allegro | ||||||
|  |     - env: LISP=ccl32 | ||||||
|  |     - env: LISP=cmucl | ||||||
|  |     - env: LISP=sbcl32 | ||||||
|  | 
 | ||||||
|  | notifications: | ||||||
|  |   email: | ||||||
|  |     on_success: change | ||||||
|  |     on_failure: always | ||||||
|  |   irc: | ||||||
|  |     channels: | ||||||
|  |       - "chat.freenode.net#iolib" | ||||||
|  |     on_success: change | ||||||
|  |     on_failure: always | ||||||
|  |     use_notice: true | ||||||
|  |     skip_join: true | ||||||
|  | 
 | ||||||
|  | install: | ||||||
|  |   - curl -L https://raw.githubusercontent.com/sionescu/cl-travis/master/install.sh | sh | ||||||
|  |   - cl -e "(cl:in-package :cl-user) | ||||||
|  |            (dolist (p '(:alexandria)) | ||||||
|  |              (ql:quickload p :verbose t))" | ||||||
|  | 
 | ||||||
|  | script: | ||||||
|  |   - cl -e "(cl:in-package :cl-user) | ||||||
|  |            (ql:quickload :fiveam/test :verbose t) | ||||||
|  |            (uiop:quit (if (some (lambda (x) (typep x '5am::test-failure)) | ||||||
|  |                                 (5am:run :it.bese.fiveam)) | ||||||
|  |                           1 0))" | ||||||
|  | 
 | ||||||
|  | sudo: required | ||||||
							
								
								
									
										30
									
								
								COPYING
									
										
									
									
									
										Normal file
									
								
							
							
						
						
									
										30
									
								
								COPYING
									
										
									
									
									
										Normal file
									
								
							|  | @ -0,0 +1,30 @@ | ||||||
|  | Copyright (c) 2003-2006, Edward Marco Baringer | ||||||
|  | All rights reserved. | ||||||
|  | 
 | ||||||
|  | Redistribution and use in source and binary forms, with or without | ||||||
|  | modification, are permitted provided that the following conditions are | ||||||
|  | met: | ||||||
|  | 
 | ||||||
|  | - Redistributions of source code must retain the above copyright | ||||||
|  | notice, this list of conditions and the following disclaimer. | ||||||
|  |    | ||||||
|  | - Redistributions in binary form must reproduce the above copyright | ||||||
|  | notice, this list of conditions and the following disclaimer in the | ||||||
|  | documentation and/or other materials provided with the distribution. | ||||||
|  |      | ||||||
|  | - Neither the name of Edward Marco Baringer, nor BESE, nor the names | ||||||
|  | of its contributors may be used to endorse or promote products derived | ||||||
|  | from this software without specific prior written permission. | ||||||
|  | 
 | ||||||
|  | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS | ||||||
|  | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT | ||||||
|  | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR | ||||||
|  | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT | ||||||
|  | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, | ||||||
|  | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT | ||||||
|  | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, | ||||||
|  | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY | ||||||
|  | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT | ||||||
|  | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE | ||||||
|  | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. | ||||||
|  | 
 | ||||||
							
								
								
									
										8
									
								
								README
									
										
									
									
									
										Normal file
									
								
							
							
						
						
									
										8
									
								
								README
									
										
									
									
									
										Normal file
									
								
							|  | @ -0,0 +1,8 @@ | ||||||
|  | This is FiveAM, a common lisp testing framework. | ||||||
|  | 
 | ||||||
|  | The documentation can be found in the docstrings, start with the | ||||||
|  | package :it.bese.fiveam (nicknamed 5AM). | ||||||
|  | 
 | ||||||
|  | The mailing list for FiveAM is fiveam-devel@common-lisp.net | ||||||
|  | 
 | ||||||
|  | All the code is Copyright (C) 2002-2006 Edward Marco Baringer. | ||||||
							
								
								
									
										13
									
								
								docs/make-qbook.lisp
									
										
									
									
									
										Normal file
									
								
							
							
						
						
									
										13
									
								
								docs/make-qbook.lisp
									
										
									
									
									
										Normal file
									
								
							|  | @ -0,0 +1,13 @@ | ||||||
|  | (asdf:oos 'asdf:load-op :FiveAM) | ||||||
|  | (asdf:oos 'asdf:load-op :qbook) | ||||||
|  | 
 | ||||||
|  | (asdf:oos 'qbook:publish-op :FiveAM | ||||||
|  |           :generator (make-instance 'qbook:html-generator | ||||||
|  |                                     :title "FiveAM" | ||||||
|  |                                     :output-directory | ||||||
|  |                                     (merge-pathnames | ||||||
|  |                                         (make-pathname :directory '(:relative "docs" "html")) | ||||||
|  |                                         (asdf:component-pathname (asdf:find-system :FiveAM))))) | ||||||
|  | 
 | ||||||
|  |            | ||||||
|  | 
 | ||||||
							
								
								
									
										36
									
								
								fiveam.asd
									
										
									
									
									
										Normal file
									
								
							
							
						
						
									
										36
									
								
								fiveam.asd
									
										
									
									
									
										Normal file
									
								
							|  | @ -0,0 +1,36 @@ | ||||||
|  | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- | ||||||
|  | 
 | ||||||
|  | #.(unless (or #+asdf3.1 (version<= "3.1" (asdf-version))) | ||||||
|  |     (error "You need ASDF >= 3.1 to load this system correctly.")) | ||||||
|  | 
 | ||||||
|  | (defsystem :fiveam | ||||||
|  |   :author "Edward Marco Baringer <mb@bese.it>" | ||||||
|  |   :version (:read-file-form "version.sexp") | ||||||
|  |   :description "A simple regression testing framework" | ||||||
|  |   :license "BSD" | ||||||
|  |   :depends-on (:alexandria :net.didierverna.asdf-flv  :trivial-backtrace) | ||||||
|  |   :pathname "src/" | ||||||
|  |   :components ((:file "package") | ||||||
|  |                (:file "utils" :depends-on ("package")) | ||||||
|  |                (:file "check" :depends-on ("package" "utils")) | ||||||
|  |                (:file "fixture" :depends-on ("package")) | ||||||
|  |                (:file "classes" :depends-on ("package")) | ||||||
|  |                (:file "random" :depends-on ("package" "check")) | ||||||
|  |                (:file "test" :depends-on ("package" "fixture" "classes")) | ||||||
|  |                (:file "explain" :depends-on ("package" "utils" "check" "classes" "random")) | ||||||
|  |                (:file "suite" :depends-on ("package" "test" "classes")) | ||||||
|  |                (:file "run" :depends-on ("package" "check" "classes" "test" "explain" "suite"))) | ||||||
|  |   :in-order-to ((test-op (test-op :fiveam/test)))) | ||||||
|  | 
 | ||||||
|  | (defsystem :fiveam/test | ||||||
|  |   :author "Edward Marco Baringer <mb@bese.it>" | ||||||
|  |   :description "FiveAM's own test suite" | ||||||
|  |   :license "BSD" | ||||||
|  |   :depends-on (:fiveam) | ||||||
|  |   :pathname "t/" | ||||||
|  |   :components ((:file "tests")) | ||||||
|  |   :perform (test-op (o c) (symbol-call :5am :run! :it.bese.fiveam))) | ||||||
|  | 
 | ||||||
|  | ;;;;@include "src/package.lisp" | ||||||
|  | 
 | ||||||
|  | ;;;;@include "t/example.lisp" | ||||||
							
								
								
									
										311
									
								
								src/check.lisp
									
										
									
									
									
										Normal file
									
								
							
							
						
						
									
										311
									
								
								src/check.lisp
									
										
									
									
									
										Normal file
									
								
							|  | @ -0,0 +1,311 @@ | ||||||
|  | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- | ||||||
|  | 
 | ||||||
|  | (in-package :it.bese.fiveam) | ||||||
|  | 
 | ||||||
|  | ;;;; * Checks | ||||||
|  | 
 | ||||||
|  | ;;;; At the lowest level testing the system requires that certain | ||||||
|  | ;;;; forms be evaluated and that certain post conditions are met: the | ||||||
|  | ;;;; value returned must satisfy a certain predicate, the form must | ||||||
|  | ;;;; (or must not) signal a certain condition, etc. In FiveAM these | ||||||
|  | ;;;; low level operations are called 'checks' and are defined using | ||||||
|  | ;;;; the various checking macros. | ||||||
|  | 
 | ||||||
|  | ;;;; Checks are the basic operators for collecting results. Tests and | ||||||
|  | ;;;; test suites on the other hand allow grouping multiple checks into | ||||||
|  | ;;;; logic collections. | ||||||
|  | 
 | ||||||
|  | (defvar *test-dribble* t) | ||||||
|  | 
 | ||||||
|  | (defmacro with-*test-dribble* (stream &body body) | ||||||
|  |   `(let ((*test-dribble* ,stream)) | ||||||
|  |      (declare (special *test-dribble*)) | ||||||
|  |      ,@body)) | ||||||
|  | 
 | ||||||
|  | (eval-when (:compile-toplevel :load-toplevel :execute) | ||||||
|  |   (def-special-environment run-state () | ||||||
|  |     result-list | ||||||
|  |     current-test)) | ||||||
|  | 
 | ||||||
|  | ;;;; ** Types of test results | ||||||
|  | 
 | ||||||
|  | ;;;; Every check produces a result object. | ||||||
|  | 
 | ||||||
|  | (defclass test-result () | ||||||
|  |   ((reason :accessor reason :initarg :reason :initform "no reason given") | ||||||
|  |    (test-case :accessor test-case :initarg :test-case) | ||||||
|  |    (test-expr :accessor test-expr :initarg :test-expr)) | ||||||
|  |   (:documentation "All checking macros will generate an object of | ||||||
|  |  type TEST-RESULT.")) | ||||||
|  | 
 | ||||||
|  | (defclass test-passed (test-result) | ||||||
|  |   () | ||||||
|  |   (:documentation "Class for successful checks.")) | ||||||
|  | 
 | ||||||
|  | (defgeneric test-passed-p (object) | ||||||
|  |   (:method ((o t)) nil) | ||||||
|  |   (:method ((o test-passed)) t)) | ||||||
|  | 
 | ||||||
|  | (define-condition check-failure (error) | ||||||
|  |   ((reason :accessor reason :initarg :reason :initform "no reason given") | ||||||
|  |    (test-case :accessor test-case :initarg :test-case) | ||||||
|  |    (test-expr :accessor test-expr :initarg :test-expr)) | ||||||
|  |   (:documentation "Signaled when a check fails.") | ||||||
|  |   (:report  (lambda (c stream) | ||||||
|  |               (format stream "The following check failed: ~S~%~A." | ||||||
|  |                       (test-expr c) | ||||||
|  |                       (reason c))))) | ||||||
|  | 
 | ||||||
|  | (defun process-failure (test-expr &optional reason-format &rest format-args) | ||||||
|  |   (let ((reason (and reason-format | ||||||
|  |                      (apply #'format nil reason-format format-args)))) | ||||||
|  |     (with-simple-restart (ignore-failure "Continue the test run.") | ||||||
|  |       (error 'check-failure :test-expr test-expr | ||||||
|  |                             :reason reason)) | ||||||
|  |     (add-result 'test-failure :test-expr test-expr | ||||||
|  |                               :reason reason))) | ||||||
|  | 
 | ||||||
|  | (defclass test-failure (test-result) | ||||||
|  |   () | ||||||
|  |   (:documentation "Class for unsuccessful checks.")) | ||||||
|  | 
 | ||||||
|  | (defgeneric test-failure-p (object) | ||||||
|  |   (:method ((o t)) nil) | ||||||
|  |   (:method ((o test-failure)) t)) | ||||||
|  | 
 | ||||||
|  | (defclass unexpected-test-failure (test-failure) | ||||||
|  |   ((actual-condition :accessor actual-condition :initarg :condition)) | ||||||
|  |   (:documentation "Represents the result of a test which neither | ||||||
|  | passed nor failed, but signaled an error we couldn't deal | ||||||
|  | with. | ||||||
|  | 
 | ||||||
|  | Note: This is very different than a SIGNALS check which instead | ||||||
|  | creates a TEST-PASSED or TEST-FAILURE object.")) | ||||||
|  | 
 | ||||||
|  | (defclass test-skipped (test-result) | ||||||
|  |   () | ||||||
|  |   (:documentation "A test which was not run. Usually this is due to | ||||||
|  | unsatisfied dependencies, but users can decide to skip the test when | ||||||
|  | appropriate.")) | ||||||
|  | 
 | ||||||
|  | (defgeneric test-skipped-p (object) | ||||||
|  |   (:method ((o t)) nil) | ||||||
|  |   (:method ((o test-skipped)) t)) | ||||||
|  | 
 | ||||||
|  | (defun add-result (result-type &rest make-instance-args) | ||||||
|  |   "Create a TEST-RESULT object of type RESULT-TYPE passing it the | ||||||
|  |   initialize args MAKE-INSTANCE-ARGS and add the resulting | ||||||
|  |   object to the list of test results." | ||||||
|  |   (with-run-state (result-list current-test) | ||||||
|  |     (let ((result (apply #'make-instance result-type | ||||||
|  |                          (append make-instance-args (list :test-case current-test))))) | ||||||
|  |       (etypecase result | ||||||
|  |         (test-passed  (format *test-dribble* ".")) | ||||||
|  |         (unexpected-test-failure (format *test-dribble* "X")) | ||||||
|  |         (test-failure (format *test-dribble* "f")) | ||||||
|  |         (test-skipped (format *test-dribble* "s"))) | ||||||
|  |       (push result result-list)))) | ||||||
|  | 
 | ||||||
|  | ;;;; ** The check operators | ||||||
|  | 
 | ||||||
|  | ;;;; *** The IS check | ||||||
|  | 
 | ||||||
|  | (defmacro is (test &rest reason-args) | ||||||
|  |   "The DWIM checking operator. | ||||||
|  | 
 | ||||||
|  | If TEST returns a true value a test-passed result is generated, | ||||||
|  | otherwise a test-failure result is generated. The reason, unless | ||||||
|  | REASON-ARGS is provided, is generated based on the form of TEST: | ||||||
|  | 
 | ||||||
|  |  (predicate expected actual) - Means that we want to check | ||||||
|  |  whether, according to PREDICATE, the ACTUAL value is | ||||||
|  |  in fact what we EXPECTED. | ||||||
|  | 
 | ||||||
|  |  (predicate value) - Means that we want to ensure that VALUE | ||||||
|  |  satisfies PREDICATE. | ||||||
|  | 
 | ||||||
|  |  Wrapping the TEST form in a NOT simply produces a negated reason | ||||||
|  |  string." | ||||||
|  |   (assert (listp test) | ||||||
|  |           (test) | ||||||
|  |           "Argument to IS must be a list, not ~S" test) | ||||||
|  |   (let (bindings effective-test default-reason-args) | ||||||
|  |     (with-gensyms (e a v) | ||||||
|  |       (flet ((process-entry (predicate expected actual &optional negatedp) | ||||||
|  |                ;; make sure EXPECTED is holding the entry that starts with 'values | ||||||
|  |                (when (and (consp actual) | ||||||
|  |                           (eq (car actual) 'values)) | ||||||
|  |                  (assert (not (and (consp expected) | ||||||
|  |                                    (eq (car expected) 'values))) () | ||||||
|  |                                    "Both the expected and actual part is a values expression.") | ||||||
|  |                  (rotatef expected actual)) | ||||||
|  |                (let ((setf-forms)) | ||||||
|  |                  (if (and (consp expected) | ||||||
|  |                           (eq (car expected) 'values)) | ||||||
|  |                      (progn | ||||||
|  |                        (setf expected (copy-list expected)) | ||||||
|  |                        (setf setf-forms (loop for cell = (rest expected) then (cdr cell) | ||||||
|  |                                               for i from 0 | ||||||
|  |                                               while cell | ||||||
|  |                                               when (eq (car cell) '*) | ||||||
|  |                                               collect `(setf (elt ,a ,i) nil) | ||||||
|  |                                               and do (setf (car cell) nil))) | ||||||
|  |                        (setf bindings (list (list e `(list ,@(rest expected))) | ||||||
|  |                                             (list a `(multiple-value-list ,actual))))) | ||||||
|  |                      (setf bindings (list (list e expected) | ||||||
|  |                                           (list a actual)))) | ||||||
|  |                  (setf effective-test `(progn | ||||||
|  |                                          ,@setf-forms | ||||||
|  |                                          ,(if negatedp | ||||||
|  |                                               `(not (,predicate ,e ,a)) | ||||||
|  |                                               `(,predicate ,e ,a))))))) | ||||||
|  |         (list-match-case test | ||||||
|  |           ((not (?predicate ?expected ?actual)) | ||||||
|  |            (process-entry ?predicate ?expected ?actual t) | ||||||
|  |            (setf default-reason-args | ||||||
|  |                  (list "~2&~S~2% evaluated to ~2&~S~2% which is ~2&~S~2%to ~2&~S~2% (it should not be)" | ||||||
|  |                        `',?actual a `',?predicate e))) | ||||||
|  |           ((not (?satisfies ?value)) | ||||||
|  |            (setf bindings (list (list v ?value)) | ||||||
|  |                  effective-test `(not (,?satisfies ,v)) | ||||||
|  |                  default-reason-args | ||||||
|  |                  (list "~2&~S~2% evaluated to ~2&~S~2% which satisfies ~2&~S~2% (it should not)" | ||||||
|  |                        `',?value v `',?satisfies))) | ||||||
|  |           ((?predicate ?expected ?actual) | ||||||
|  |            (process-entry ?predicate ?expected ?actual) | ||||||
|  |            (setf default-reason-args | ||||||
|  |                  (list "~2&~S~2% evaluated to ~2&~S~2% which is not ~2&~S~2% to ~2&~S~2%." | ||||||
|  |                        `',?actual a `',?predicate e))) | ||||||
|  |           ((?satisfies ?value) | ||||||
|  |            (setf bindings (list (list v ?value)) | ||||||
|  |                  effective-test `(,?satisfies ,v) | ||||||
|  |                  default-reason-args | ||||||
|  |                  (list "~2&~S~2% evaluated to ~2&~S~2% which does not satisfy ~2&~S~2%" | ||||||
|  |                        `',?value v `',?satisfies))) | ||||||
|  |           (?_ | ||||||
|  |            (setf bindings '() | ||||||
|  |                  effective-test test | ||||||
|  |                  default-reason-args (list "~2&~S~2% was NIL." `',test))))) | ||||||
|  |       `(let ,bindings | ||||||
|  |          (if ,effective-test | ||||||
|  |              (add-result 'test-passed :test-expr ',test) | ||||||
|  |              (process-failure ',test | ||||||
|  |                               ,@(or reason-args default-reason-args))))))) | ||||||
|  | 
 | ||||||
|  | ;;;; *** Other checks | ||||||
|  | 
 | ||||||
|  | (defmacro skip (&rest reason) | ||||||
|  |   "Generates a TEST-SKIPPED result." | ||||||
|  |   `(progn | ||||||
|  |      (format *test-dribble* "s") | ||||||
|  |      (add-result 'test-skipped :reason (format nil ,@reason)))) | ||||||
|  | 
 | ||||||
|  | (defmacro is-every (predicate &body clauses) | ||||||
|  |   "The input is either a list of lists, or a list of pairs. Generates (is (,predicate ,expr ,value)) | ||||||
|  |    for each pair of elements or (is (,predicate ,expr ,value) ,@reason) for each list." | ||||||
|  |   `(progn | ||||||
|  |      ,@(if (every #'consp clauses) | ||||||
|  |            (loop for (expected actual . reason) in clauses | ||||||
|  |                  collect `(is (,predicate ,expected ,actual) ,@reason)) | ||||||
|  |            (progn | ||||||
|  |              (assert (evenp (list-length clauses))) | ||||||
|  |              (loop for (expr value) on clauses by #'cddr | ||||||
|  |                    collect `(is (,predicate ,expr ,value))))))) | ||||||
|  | 
 | ||||||
|  | (defmacro is-true (condition &rest reason-args) | ||||||
|  |   "Like IS this check generates a pass if CONDITION returns true | ||||||
|  |   and a failure if CONDITION returns false. Unlike IS this check | ||||||
|  |   does not inspect CONDITION to determine how to report the | ||||||
|  |   failure." | ||||||
|  |   `(if ,condition | ||||||
|  |        (add-result 'test-passed :test-expr ',condition) | ||||||
|  |        (process-failure ',condition | ||||||
|  |                         ,@(or reason-args | ||||||
|  |                               `("~S did not return a true value" ',condition))))) | ||||||
|  | 
 | ||||||
|  | (defmacro is-false (condition &rest reason-args) | ||||||
|  |   "Generates a pass if CONDITION returns false, generates a | ||||||
|  |   failure otherwise. Like IS-TRUE, and unlike IS, IS-FALSE does | ||||||
|  |   not inspect CONDITION to determine what reason to give it case | ||||||
|  |   of test failure" | ||||||
|  |   (with-gensyms (value) | ||||||
|  |     `(let ((,value ,condition)) | ||||||
|  |        (if ,value | ||||||
|  |            (process-failure ',condition | ||||||
|  |                             ,@(or reason-args | ||||||
|  |                                   `("~S returned the value ~S, which is true" ',condition ,value))) | ||||||
|  |            (add-result 'test-passed :test-expr ',condition))))) | ||||||
|  | 
 | ||||||
|  | (defmacro signals (condition-spec | ||||||
|  |                    &body body) | ||||||
|  |   "Generates a pass if BODY signals a condition of type | ||||||
|  | CONDITION. BODY is evaluated in a block named NIL, CONDITION is | ||||||
|  | not evaluated." | ||||||
|  |   (let ((block-name (gensym))) | ||||||
|  |     (destructuring-bind (condition &optional reason-control reason-args) | ||||||
|  |         (ensure-list condition-spec) | ||||||
|  |       `(block ,block-name | ||||||
|  |          (handler-bind ((,condition (lambda (c) | ||||||
|  |                                       (declare (ignore c)) | ||||||
|  |                                       ;; ok, body threw condition | ||||||
|  |                                       (add-result 'test-passed | ||||||
|  |                                                   :test-expr ',condition) | ||||||
|  |                                       (return-from ,block-name t)))) | ||||||
|  |            (block nil | ||||||
|  |              ,@body)) | ||||||
|  |          (process-failure | ||||||
|  |            ',condition | ||||||
|  |            ,@(if reason-control | ||||||
|  |                  `(,reason-control ,@reason-args) | ||||||
|  |                  `("Failed to signal a ~S" ',condition))) | ||||||
|  |          (return-from ,block-name nil))))) | ||||||
|  | 
 | ||||||
|  | (defmacro finishes (&body body) | ||||||
|  |   "Generates a pass if BODY executes to normal completion. In | ||||||
|  | other words if body does signal, return-from or throw this test | ||||||
|  | fails." | ||||||
|  |   `(unwind-protect-case () (progn ,@body) | ||||||
|  |      (:normal (add-result 'test-passed :test-expr ',body)) | ||||||
|  |      (:abort (process-failure ',body "Test didn't finish")))) | ||||||
|  | 
 | ||||||
|  | (defmacro pass (&rest message-args) | ||||||
|  |   "Simply generate a PASS." | ||||||
|  |   `(add-result 'test-passed | ||||||
|  |                :test-expr ',message-args | ||||||
|  |                ,@(when message-args | ||||||
|  |                    `(:reason (format nil ,@message-args))))) | ||||||
|  | 
 | ||||||
|  | (defmacro fail (&rest message-args) | ||||||
|  |   "Simply generate a FAIL." | ||||||
|  |   `(process-failure ',message-args | ||||||
|  |                     ,@message-args)) | ||||||
|  | 
 | ||||||
|  | ;; Copyright (c) 2002-2003, Edward Marco Baringer | ||||||
|  | ;; All rights reserved. | ||||||
|  | ;; | ||||||
|  | ;; Redistribution and use in source and binary forms, with or without | ||||||
|  | ;; modification, are permitted provided that the following conditions are | ||||||
|  | ;; met: | ||||||
|  | ;; | ||||||
|  | ;;  - Redistributions of source code must retain the above copyright | ||||||
|  | ;;    notice, this list of conditions and the following disclaimer. | ||||||
|  | ;; | ||||||
|  | ;;  - Redistributions in binary form must reproduce the above copyright | ||||||
|  | ;;    notice, this list of conditions and the following disclaimer in the | ||||||
|  | ;;    documentation and/or other materials provided with the distribution. | ||||||
|  | ;; | ||||||
|  | ;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names | ||||||
|  | ;;    of its contributors may be used to endorse or promote products | ||||||
|  | ;;    derived from this software without specific prior written permission. | ||||||
|  | ;; | ||||||
|  | ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS | ||||||
|  | ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT | ||||||
|  | ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR | ||||||
|  | ;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT | ||||||
|  | ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, | ||||||
|  | ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT | ||||||
|  | ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, | ||||||
|  | ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY | ||||||
|  | ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT | ||||||
|  | ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE | ||||||
|  | ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE | ||||||
							
								
								
									
										128
									
								
								src/classes.lisp
									
										
									
									
									
										Normal file
									
								
							
							
						
						
									
										128
									
								
								src/classes.lisp
									
										
									
									
									
										Normal file
									
								
							|  | @ -0,0 +1,128 @@ | ||||||
|  | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- | ||||||
|  | 
 | ||||||
|  | (in-package :it.bese.fiveam) | ||||||
|  | 
 | ||||||
|  | (defclass testable-object () | ||||||
|  |   ((name :initarg :name :accessor name | ||||||
|  |          :documentation "A symbol naming this test object.") | ||||||
|  |    (description :initarg :description :accessor description :initform nil | ||||||
|  |                 :documentation "The textual description of this test object.") | ||||||
|  |    (depends-on :initarg :depends-on :accessor depends-on :initform nil | ||||||
|  |                :documentation "The list of AND, OR, NOT forms specifying when to run this test.") | ||||||
|  |    (status :initarg :status :accessor status :initform :unknown | ||||||
|  |            :documentation "A symbol specifying the current status | ||||||
|  | 	   of this test. Either: T - this test (and all its | ||||||
|  | 	   dependencies, have passed. NIL - this test | ||||||
|  | 	   failed (either it failed or its dependecies weren't | ||||||
|  | 	   met. :circular this test has a circular dependency | ||||||
|  | 	   and was skipped. Or :depends-not-satisfied or :resolving") | ||||||
|  |    (profiling-info :accessor profiling-info | ||||||
|  |                    :initform nil | ||||||
|  |                    :documentation "An object representing how | ||||||
|  |                    much time and memory where used by the | ||||||
|  |                    test.") | ||||||
|  |    (collect-profiling-info :accessor collect-profiling-info | ||||||
|  |                            :initarg :collect-profiling-info | ||||||
|  |                            :initform nil | ||||||
|  |                            :documentation "When T profiling | ||||||
|  |                            information will be collected when the | ||||||
|  |                            test is run."))) | ||||||
|  | 
 | ||||||
|  | (defmethod print-object ((test testable-object) stream) | ||||||
|  |   (print-unreadable-object (test stream :type t :identity t) | ||||||
|  |     (format stream "~S" (name test)))) | ||||||
|  | 
 | ||||||
|  | (defclass test-suite (testable-object) | ||||||
|  |   ((tests :accessor tests :initform (make-hash-table :test 'eql) | ||||||
|  |           :documentation "The hash table mapping names to test | ||||||
|  | 	  objects in this suite. The values in this hash table | ||||||
|  | 	  can be either test-cases or other test-suites.")) | ||||||
|  |   (:documentation "A test suite is a collection of tests or test suites. | ||||||
|  | 
 | ||||||
|  | Test suites serve to organize tests into groups so that the | ||||||
|  | developer can chose to run some tests and not just one or | ||||||
|  | all. Like tests test suites have a name and a description. | ||||||
|  | 
 | ||||||
|  | Test suites, like tests, can be part of other test suites, this | ||||||
|  | allows the developer to create a hierarchy of tests where sub | ||||||
|  | trees can be singularly run. | ||||||
|  | 
 | ||||||
|  | Running a test suite has the effect of running every test (or | ||||||
|  | suite) in the suite.")) | ||||||
|  | 
 | ||||||
|  | (defclass test-case (testable-object) | ||||||
|  |   ((test-lambda :initarg :test-lambda :accessor test-lambda | ||||||
|  |                 :documentation "The function to run.") | ||||||
|  |    (runtime-package :initarg :runtime-package :accessor runtime-package | ||||||
|  |                     :documentation "By default it stores *package* from the time this test was defined (macroexpanded).")) | ||||||
|  |   (:documentation "A test case is a single, named, collection of | ||||||
|  | checks. | ||||||
|  | 
 | ||||||
|  | A test case is the smallest organizational element which can be | ||||||
|  | run individually. Every test case has a name, which is a symbol, | ||||||
|  | a description and a test lambda. The test lambda is a regular | ||||||
|  | funcall'able function which should use the various checking | ||||||
|  | macros to collect results. | ||||||
|  | 
 | ||||||
|  | Every test case is part of a suite, when a suite is not | ||||||
|  | explicitly specified (either via the :SUITE parameter to the TEST | ||||||
|  | macro or the global variable *SUITE*) the test is inserted into | ||||||
|  | the global suite named NIL. | ||||||
|  | 
 | ||||||
|  | Sometimes we want to run a certain test only if another test has | ||||||
|  | passed. FiveAM allows us to specify the ways in which one test is | ||||||
|  | dependent on another. | ||||||
|  | 
 | ||||||
|  | - AND Run this test only if all the named tests passed. | ||||||
|  | 
 | ||||||
|  | - OR Run this test if at least one of the named tests passed. | ||||||
|  | 
 | ||||||
|  | - NOT Run this test only if another test has failed. | ||||||
|  | 
 | ||||||
|  | FiveAM considers a test to have passed if all the checks executed | ||||||
|  | were successful, otherwise we consider the test a failure. | ||||||
|  | 
 | ||||||
|  | When a test is not run due to it's dependencies having failed a | ||||||
|  | test-skipped result is added to the results.")) | ||||||
|  | 
 | ||||||
|  | (defclass explainer () | ||||||
|  |   ()) | ||||||
|  | 
 | ||||||
|  | (defclass text-explainer (explainer) | ||||||
|  |   ()) | ||||||
|  | 
 | ||||||
|  | (defclass simple-text-explainer (text-explainer) | ||||||
|  |   ()) | ||||||
|  | 
 | ||||||
|  | (defclass detailed-text-explainer (text-explainer) | ||||||
|  |   ()) | ||||||
|  | 
 | ||||||
|  | ;; Copyright (c) 2002-2003, Edward Marco Baringer | ||||||
|  | ;; All rights reserved. | ||||||
|  | ;; | ||||||
|  | ;; Redistribution and use in source and binary forms, with or without | ||||||
|  | ;; modification, are permitted provided that the following conditions are | ||||||
|  | ;; met: | ||||||
|  | ;; | ||||||
|  | ;;  - Redistributions of source code must retain the above copyright | ||||||
|  | ;;    notice, this list of conditions and the following disclaimer. | ||||||
|  | ;; | ||||||
|  | ;;  - Redistributions in binary form must reproduce the above copyright | ||||||
|  | ;;    notice, this list of conditions and the following disclaimer in the | ||||||
|  | ;;    documentation and/or other materials provided with the distribution. | ||||||
|  | ;; | ||||||
|  | ;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names | ||||||
|  | ;;    of its contributors may be used to endorse or promote products | ||||||
|  | ;;    derived from this software without specific prior written permission. | ||||||
|  | ;; | ||||||
|  | ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS | ||||||
|  | ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT | ||||||
|  | ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR | ||||||
|  | ;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT | ||||||
|  | ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, | ||||||
|  | ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT | ||||||
|  | ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, | ||||||
|  | ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY | ||||||
|  | ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT | ||||||
|  | ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE | ||||||
|  | ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE | ||||||
							
								
								
									
										133
									
								
								src/explain.lisp
									
										
									
									
									
										Normal file
									
								
							
							
						
						
									
										133
									
								
								src/explain.lisp
									
										
									
									
									
										Normal file
									
								
							|  | @ -0,0 +1,133 @@ | ||||||
|  | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- | ||||||
|  | 
 | ||||||
|  | (in-package :it.bese.fiveam) | ||||||
|  | 
 | ||||||
|  | ;;;; * Analyzing the results | ||||||
|  | 
 | ||||||
|  | (defparameter *verbose-failures* nil | ||||||
|  |   "T if we should print the expression failing, NIL otherwise.") | ||||||
|  | 
 | ||||||
|  | ;;;; Just as important as defining and runnig the tests is | ||||||
|  | ;;;; understanding the results. FiveAM provides the function EXPLAIN | ||||||
|  | ;;;; which prints a human readable summary (number passed, number | ||||||
|  | ;;;; failed, what failed and why, etc.) of a list of test results. | ||||||
|  | 
 | ||||||
|  | (defgeneric explain (explainer results &optional stream recursive-depth) | ||||||
|  |   (:documentation "Given a list of test results report write to stream detailed | ||||||
|  |  human readable statistics regarding the results.")) | ||||||
|  | 
 | ||||||
|  | (defmethod explain ((exp detailed-text-explainer) results | ||||||
|  |                     &optional (stream *test-dribble*) (recursive-depth 0)) | ||||||
|  |   (multiple-value-bind (num-checks passed num-passed passed% | ||||||
|  |                                    skipped num-skipped skipped% | ||||||
|  |                                    failed num-failed failed% | ||||||
|  |                                    unknown num-unknown unknown%) | ||||||
|  |       (partition-results results) | ||||||
|  |     (declare (ignore passed)) | ||||||
|  |     (flet ((output (&rest format-args) | ||||||
|  |              (format stream "~&~vT" recursive-depth) | ||||||
|  |              (apply #'format stream format-args))) | ||||||
|  | 
 | ||||||
|  |       (when (zerop num-checks) | ||||||
|  |         (output "Didn't run anything...huh?") | ||||||
|  |         (return-from explain nil)) | ||||||
|  |       (output "Did ~D check~P.~%" num-checks num-checks) | ||||||
|  |       (output "   Pass: ~D (~2D%)~%" num-passed passed%) | ||||||
|  |       (output "   Skip: ~D (~2D%)~%" num-skipped skipped%) | ||||||
|  |       (output "   Fail: ~D (~2D%)~%" num-failed failed%) | ||||||
|  |       (when unknown | ||||||
|  |         (output "   UNKNOWN RESULTS: ~D (~2D)~%" num-unknown unknown%)) | ||||||
|  |       (terpri stream) | ||||||
|  |       (when failed | ||||||
|  |         (output "Failure Details:~%") | ||||||
|  |         (dolist (f (reverse failed)) | ||||||
|  |           (output "--------------------------------~%") | ||||||
|  |           (output "~A ~@{[~A]~}: ~%" | ||||||
|  |                   (name (test-case f)) | ||||||
|  |                   (description (test-case f))) | ||||||
|  |           (output "     ~A.~%" (reason f)) | ||||||
|  |           (when (for-all-test-failed-p f) | ||||||
|  |             (output "Results collected with failure data:~%") | ||||||
|  |             (explain exp (slot-value f 'result-list) | ||||||
|  |                      stream (+ 4 recursive-depth))) | ||||||
|  |           (when (and *verbose-failures* (test-expr f)) | ||||||
|  |             (output "    ~S~%" (test-expr f))) | ||||||
|  |           (output "--------------------------------~%")) | ||||||
|  |         (terpri stream)) | ||||||
|  |       (when skipped | ||||||
|  |         (output "Skip Details:~%") | ||||||
|  |         (dolist (f skipped) | ||||||
|  |           (output "~A ~@{[~A]~}: ~%" | ||||||
|  |                   (name (test-case f)) | ||||||
|  |                   (description (test-case f))) | ||||||
|  |           (output "    ~A.~%" (reason f))) | ||||||
|  |         (terpri stream))))) | ||||||
|  | 
 | ||||||
|  | (defmethod explain ((exp simple-text-explainer) results | ||||||
|  |                     &optional (stream *test-dribble*) (recursive-depth 0)) | ||||||
|  |   (multiple-value-bind (num-checks passed num-passed passed% | ||||||
|  |                                    skipped num-skipped skipped% | ||||||
|  |                                    failed num-failed failed% | ||||||
|  |                                    unknown num-unknown unknown%) | ||||||
|  |       (partition-results results) | ||||||
|  |     (declare (ignore passed passed% skipped skipped% failed failed% unknown unknown%)) | ||||||
|  |     (format stream "~&~vTRan ~D checks, ~D passed" recursive-depth num-checks num-passed) | ||||||
|  |     (when (plusp num-skipped) | ||||||
|  |       (format stream ", ~D skipped " num-skipped)) | ||||||
|  |     (format stream " and ~D failed.~%" num-failed) | ||||||
|  |     (when (plusp num-unknown) | ||||||
|  |       (format stream "~vT~D UNKNOWN RESULTS.~%" recursive-depth num-unknown)))) | ||||||
|  | 
 | ||||||
|  | (defun partition-results (results-list) | ||||||
|  |   (let ((num-checks (length results-list))) | ||||||
|  |     (destructuring-bind (passed skipped failed unknown) | ||||||
|  |         (partitionx results-list | ||||||
|  |                     (lambda (res) | ||||||
|  |                       (typep res 'test-passed)) | ||||||
|  |                     (lambda (res) | ||||||
|  |                       (typep res 'test-skipped)) | ||||||
|  |                     (lambda (res) | ||||||
|  |                       (typep res 'test-failure)) | ||||||
|  |                     t) | ||||||
|  |       (if (zerop num-checks) | ||||||
|  |           (values 0 | ||||||
|  |                   nil 0 0 | ||||||
|  |                   nil 0 0 | ||||||
|  |                   nil 0 0 | ||||||
|  |                   nil 0 0) | ||||||
|  |           (values | ||||||
|  |            num-checks | ||||||
|  |            passed (length passed) (floor (* 100 (/ (length passed) num-checks))) | ||||||
|  |            skipped (length skipped) (floor (* 100 (/ (length skipped) num-checks))) | ||||||
|  |            failed (length failed) (floor (* 100 (/ (length failed) num-checks))) | ||||||
|  |            unknown (length unknown) (floor (* 100 (/ (length failed) num-checks)))))))) | ||||||
|  | 
 | ||||||
|  | ;; Copyright (c) 2002-2003, Edward Marco Baringer | ||||||
|  | ;; All rights reserved. | ||||||
|  | ;; | ||||||
|  | ;; Redistribution and use in source and binary forms, with or without | ||||||
|  | ;; modification, are permitted provided that the following conditions are | ||||||
|  | ;; met: | ||||||
|  | ;; | ||||||
|  | ;;  - Redistributions of source code must retain the above copyright | ||||||
|  | ;;    notice, this list of conditions and the following disclaimer. | ||||||
|  | ;; | ||||||
|  | ;;  - Redistributions in binary form must reproduce the above copyright | ||||||
|  | ;;    notice, this list of conditions and the following disclaimer in the | ||||||
|  | ;;    documentation and/or other materials provided with the distribution. | ||||||
|  | ;; | ||||||
|  | ;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names | ||||||
|  | ;;    of its contributors may be used to endorse or promote products | ||||||
|  | ;;    derived from this software without specific prior written permission. | ||||||
|  | ;; | ||||||
|  | ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS | ||||||
|  | ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT | ||||||
|  | ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR | ||||||
|  | ;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT | ||||||
|  | ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, | ||||||
|  | ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT | ||||||
|  | ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, | ||||||
|  | ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY | ||||||
|  | ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT | ||||||
|  | ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE | ||||||
|  | ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE | ||||||
							
								
								
									
										82
									
								
								src/fixture.lisp
									
										
									
									
									
										Normal file
									
								
							
							
						
						
									
										82
									
								
								src/fixture.lisp
									
										
									
									
									
										Normal file
									
								
							|  | @ -0,0 +1,82 @@ | ||||||
|  | ;; -*- lisp -*- | ||||||
|  | 
 | ||||||
|  | (in-package :it.bese.fiveam) | ||||||
|  | 
 | ||||||
|  | ;;;; ** Fixtures | ||||||
|  | 
 | ||||||
|  | ;;;; When running tests we often need to setup some kind of context | ||||||
|  | ;;;; (create dummy db connections, simulate an http request, | ||||||
|  | ;;;; etc.). Fixtures provide a way to conviently hide this context | ||||||
|  | ;;;; into a macro and allow the test to focus on testing. | ||||||
|  | 
 | ||||||
|  | ;;;; NB: A FiveAM fixture is nothing more than a macro. Since the term | ||||||
|  | ;;;; 'fixture' is so common in testing frameworks we've provided a | ||||||
|  | ;;;; wrapper around defmacro for this purpose. | ||||||
|  | 
 | ||||||
|  | (defvar *fixture* | ||||||
|  |   (make-hash-table :test 'eql) | ||||||
|  |   "Lookup table mapping fixture names to fixture | ||||||
|  |   objects.") | ||||||
|  | 
 | ||||||
|  | (defun get-fixture (key &optional default) | ||||||
|  |   (gethash key *fixture* default)) | ||||||
|  | 
 | ||||||
|  | (defun (setf get-fixture) (value key) | ||||||
|  |   (setf (gethash key *fixture*) value)) | ||||||
|  | 
 | ||||||
|  | (defun rem-fixture (key) | ||||||
|  |   (remhash key *fixture*)) | ||||||
|  | 
 | ||||||
|  | (defmacro def-fixture (name (&rest args) &body body) | ||||||
|  |   "Defines a fixture named NAME. A fixture is very much like a | ||||||
|  | macro but is used only for simple templating. A fixture created | ||||||
|  | with DEF-FIXTURE is a macro which can use the special macrolet | ||||||
|  | &BODY to specify where the body should go. | ||||||
|  | 
 | ||||||
|  | See Also: WITH-FIXTURE | ||||||
|  | " | ||||||
|  |   `(eval-when (:compile-toplevel :load-toplevel :execute) | ||||||
|  |      (setf (get-fixture ',name) (cons ',args ',body)) | ||||||
|  |      ',name)) | ||||||
|  | 
 | ||||||
|  | (defmacro with-fixture (fixture-name (&rest args) &body body) | ||||||
|  |   "Insert BODY into the fixture named FIXTURE-NAME. | ||||||
|  | 
 | ||||||
|  | See Also: DEF-FIXTURE" | ||||||
|  |   (assert (get-fixture fixture-name) | ||||||
|  |           (fixture-name) | ||||||
|  |           "Unknown fixture ~S." fixture-name) | ||||||
|  |   (destructuring-bind ((&rest largs) &rest lbody) | ||||||
|  |       (get-fixture fixture-name) | ||||||
|  |     `(macrolet ((&body () '(progn ,@body))) | ||||||
|  |        (funcall (lambda (,@largs) ,@lbody) ,@args)))) | ||||||
|  | 
 | ||||||
|  | ;; Copyright (c) 2002-2003, Edward Marco Baringer | ||||||
|  | ;; All rights reserved. | ||||||
|  | ;; | ||||||
|  | ;; Redistribution and use in source and binary forms, with or without | ||||||
|  | ;; modification, are permitted provided that the following conditions are | ||||||
|  | ;; met: | ||||||
|  | ;; | ||||||
|  | ;;  - Redistributions of source code must retain the above copyright | ||||||
|  | ;;    notice, this list of conditions and the following disclaimer. | ||||||
|  | ;; | ||||||
|  | ;;  - Redistributions in binary form must reproduce the above copyright | ||||||
|  | ;;    notice, this list of conditions and the following disclaimer in the | ||||||
|  | ;;    documentation and/or other materials provided with the distribution. | ||||||
|  | ;; | ||||||
|  | ;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names | ||||||
|  | ;;    of its contributors may be used to endorse or promote products | ||||||
|  | ;;    derived from this software without specific prior written permission. | ||||||
|  | ;; | ||||||
|  | ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS | ||||||
|  | ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT | ||||||
|  | ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR | ||||||
|  | ;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT | ||||||
|  | ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, | ||||||
|  | ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT | ||||||
|  | ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, | ||||||
|  | ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY | ||||||
|  | ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT | ||||||
|  | ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE | ||||||
|  | ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. | ||||||
							
								
								
									
										139
									
								
								src/package.lisp
									
										
									
									
									
										Normal file
									
								
							
							
						
						
									
										139
									
								
								src/package.lisp
									
										
									
									
									
										Normal file
									
								
							|  | @ -0,0 +1,139 @@ | ||||||
|  | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- | ||||||
|  | 
 | ||||||
|  | ;;;; * Introduction | ||||||
|  | 
 | ||||||
|  | ;;;; FiveAM is a testing framework. It takes care of all the boring | ||||||
|  | ;;;; bookkeeping associated with managing a test framework allowing | ||||||
|  | ;;;; the developer to focus on writing tests and code. | ||||||
|  | 
 | ||||||
|  | ;;;; FiveAM was designed with the following premises: | ||||||
|  | 
 | ||||||
|  | ;;;; - Defining tests should be about writing tests, not | ||||||
|  | ;;;; infrastructure. The developer should be able to focus on what | ||||||
|  | ;;;; they're testing, not the testing framework. | ||||||
|  | 
 | ||||||
|  | ;;;; - Interactive testing is the norm. Common Lisp is an interactive | ||||||
|  | ;;;; development environment, the testing environment should allow the | ||||||
|  | ;;;; developer to quickly and easily redefine, change, remove and run | ||||||
|  | ;;;; tests. | ||||||
|  | 
 | ||||||
|  | (defpackage :it.bese.fiveam | ||||||
|  |   (:use :common-lisp :alexandria) | ||||||
|  |   (:nicknames :5am :fiveam) | ||||||
|  |   #+sb-package-locks | ||||||
|  |   (:lock t) | ||||||
|  |   (:export | ||||||
|  |    ;; creating tests and test-suites | ||||||
|  |    #:make-suite | ||||||
|  |    #:def-suite | ||||||
|  |    #:def-suite* | ||||||
|  |    #:in-suite | ||||||
|  |    #:in-suite* | ||||||
|  |    #:test | ||||||
|  |    #:def-test | ||||||
|  |    #:get-test | ||||||
|  |    #:rem-test | ||||||
|  |    #:test-names | ||||||
|  |    #:*default-test-compilation-time* | ||||||
|  |    ;; fixtures | ||||||
|  |    #:def-fixture | ||||||
|  |    #:with-fixture | ||||||
|  |    #:get-fixture | ||||||
|  |    #:rem-fixture | ||||||
|  |    ;; running checks | ||||||
|  |    #:is | ||||||
|  |    #:is-every | ||||||
|  |    #:is-true | ||||||
|  |    #:is-false | ||||||
|  |    #:signals | ||||||
|  |    #:finishes | ||||||
|  |    #:skip | ||||||
|  |    #:pass | ||||||
|  |    #:fail | ||||||
|  |    #:*test-dribble* | ||||||
|  |    #:for-all | ||||||
|  |    #:*num-trials* | ||||||
|  |    #:*max-trials* | ||||||
|  |    #:gen-integer | ||||||
|  |    #:gen-float | ||||||
|  |    #:gen-character | ||||||
|  |    #:gen-string | ||||||
|  |    #:gen-list | ||||||
|  |    #:gen-tree | ||||||
|  |    #:gen-buffer | ||||||
|  |    #:gen-one-element | ||||||
|  |    ;; running tests | ||||||
|  |    #:run | ||||||
|  |    #:run-all-tests | ||||||
|  |    #:explain | ||||||
|  |    #:explain! | ||||||
|  |    #:run! | ||||||
|  |    #:debug! | ||||||
|  |    #:! | ||||||
|  |    #:!! | ||||||
|  |    #:!!! | ||||||
|  |    #:*run-test-when-defined* | ||||||
|  |    #:*debug-on-error* | ||||||
|  |    #:*debug-on-failure* | ||||||
|  |    #:*on-error* | ||||||
|  |    #:*on-failure* | ||||||
|  |    #:*verbose-failures* | ||||||
|  |    #:*print-names* | ||||||
|  |    #:results-status)) | ||||||
|  | 
 | ||||||
|  | ;;;; You can use #+5am to put your test-defining code inline with your | ||||||
|  | ;;;; other code - and not require people to have fiveam to run your | ||||||
|  | ;;;; package. | ||||||
|  | 
 | ||||||
|  | (pushnew :5am *features*) | ||||||
|  | 
 | ||||||
|  | ;;;;@include "check.lisp" | ||||||
|  | 
 | ||||||
|  | ;;;;@include "random.lisp" | ||||||
|  | 
 | ||||||
|  | ;;;;@include "fixture.lisp" | ||||||
|  | 
 | ||||||
|  | ;;;;@include "test.lisp" | ||||||
|  | 
 | ||||||
|  | ;;;;@include "suite.lisp" | ||||||
|  | 
 | ||||||
|  | ;;;;@include "run.lisp" | ||||||
|  | 
 | ||||||
|  | ;;;;@include "explain.lisp" | ||||||
|  | 
 | ||||||
|  | ;;;; * Colophon | ||||||
|  | 
 | ||||||
|  | ;;;; This documentaion was written by Edward Marco Baringer | ||||||
|  | ;;;; <mb@bese.it> and generated by qbook. | ||||||
|  | 
 | ||||||
|  | ;;;; ** COPYRIGHT | ||||||
|  | 
 | ||||||
|  | ;;;; Copyright (c) 2002-2003, Edward Marco Baringer | ||||||
|  | ;;;; All rights reserved. | ||||||
|  | 
 | ||||||
|  | ;;;; Redistribution and use in source and binary forms, with or without | ||||||
|  | ;;;; modification, are permitted provided that the following conditions are | ||||||
|  | ;;;; met: | ||||||
|  | 
 | ||||||
|  | ;;;;  - Redistributions of source code must retain the above copyright | ||||||
|  | ;;;;    notice, this list of conditions and the following disclaimer. | ||||||
|  | 
 | ||||||
|  | ;;;;  - Redistributions in binary form must reproduce the above copyright | ||||||
|  | ;;;;    notice, this list of conditions and the following disclaimer in the | ||||||
|  | ;;;;    documentation and/or other materials provided with the distribution. | ||||||
|  | 
 | ||||||
|  | ;;;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names | ||||||
|  | ;;;;    of its contributors may be used to endorse or promote products | ||||||
|  | ;;;;    derived from this software without specific prior written permission. | ||||||
|  | 
 | ||||||
|  | ;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS | ||||||
|  | ;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT | ||||||
|  | ;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR | ||||||
|  | ;;;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT | ||||||
|  | ;;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, | ||||||
|  | ;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT | ||||||
|  | ;;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, | ||||||
|  | ;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY | ||||||
|  | ;;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT | ||||||
|  | ;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE | ||||||
|  | ;;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE | ||||||
							
								
								
									
										265
									
								
								src/random.lisp
									
										
									
									
									
										Normal file
									
								
							
							
						
						
									
										265
									
								
								src/random.lisp
									
										
									
									
									
										Normal file
									
								
							|  | @ -0,0 +1,265 @@ | ||||||
|  | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- | ||||||
|  | 
 | ||||||
|  | (in-package :it.bese.fiveam) | ||||||
|  | 
 | ||||||
|  | ;;;; ** Random (QuickCheck-ish) testing | ||||||
|  | 
 | ||||||
|  | ;;;; FiveAM provides the ability to automatically generate a | ||||||
|  | ;;;; collection of random input data for a specific test and run a | ||||||
|  | ;;;; test multiple times. | ||||||
|  | 
 | ||||||
|  | ;;;; Specification testing is done through the FOR-ALL macro. This | ||||||
|  | ;;;; macro will bind variables to random data and run a test body a | ||||||
|  | ;;;; certain number of times. Should the test body ever signal a | ||||||
|  | ;;;; failure we stop running and report what values of the variables | ||||||
|  | ;;;; caused the code to fail. | ||||||
|  | 
 | ||||||
|  | ;;;; The generation of the random data is done using "generator | ||||||
|  | ;;;; functions" (see below for details). A generator function is a | ||||||
|  | ;;;; function which creates, based on user supplied parameters, a | ||||||
|  | ;;;; function which returns random data. In order to facilitate | ||||||
|  | ;;;; generating good random data the FOR-ALL macro also supports guard | ||||||
|  | ;;;; conditions and creating one random input based on the values of | ||||||
|  | ;;;; another (see the FOR-ALL macro for details). | ||||||
|  | 
 | ||||||
|  | ;;;; *** Public Interface to the Random Tester | ||||||
|  | 
 | ||||||
|  | (defparameter *num-trials* 100 | ||||||
|  |   "Number of times we attempt to run the body of the FOR-ALL test.") | ||||||
|  | 
 | ||||||
|  | (defparameter *max-trials* 10000 | ||||||
|  |   "Number of total times we attempt to run the body of the | ||||||
|  |   FOR-ALL test including when the body is skipped due to failed | ||||||
|  |   guard conditions. | ||||||
|  | 
 | ||||||
|  | Since we have guard conditions we may get into infinite loops | ||||||
|  | where the test code is never run due to the guards never | ||||||
|  | returning true. This second run limit prevents that.") | ||||||
|  | 
 | ||||||
|  | (defmacro for-all (bindings &body body) | ||||||
|  |   "Bind BINDINGS to random variables and test BODY *num-trials* times. | ||||||
|  | 
 | ||||||
|  | BINDINGS is a list of binding forms, each element is a list | ||||||
|  | of (BINDING VALUE &optional GUARD). Value, which is evaluated | ||||||
|  | once when the for-all is evaluated, must return a generator which | ||||||
|  | be called each time BODY is evaluated. BINDING is either a symbol | ||||||
|  | or a list which will be passed to destructuring-bind. GUARD is a | ||||||
|  | form which, if present, stops BODY from executing when IT returns | ||||||
|  | NIL. The GUARDS are evaluated after all the random data has been | ||||||
|  | generated and they can refer to the current value of any | ||||||
|  | binding. NB: Generator forms, unlike guard forms, can not contain | ||||||
|  | references to the bound variables. | ||||||
|  | 
 | ||||||
|  | Examples: | ||||||
|  | 
 | ||||||
|  |   (for-all ((a (gen-integer))) | ||||||
|  |     (is (integerp a))) | ||||||
|  | 
 | ||||||
|  |   (for-all ((a (gen-integer) (plusp a))) | ||||||
|  |     (is (integerp a)) | ||||||
|  |     (is (plusp a))) | ||||||
|  | 
 | ||||||
|  |   (for-all ((less (gen-integer)) | ||||||
|  |             (more (gen-integer) (< less more))) | ||||||
|  |     (is (<= less more))) | ||||||
|  | 
 | ||||||
|  |   (for-all (((a b) (gen-two-integers))) | ||||||
|  |     (is (integerp a)) | ||||||
|  |     (is (integerp b)))" | ||||||
|  |   (with-gensyms (test-lambda-args) | ||||||
|  |     `(perform-random-testing | ||||||
|  |       (list ,@(mapcar #'second bindings)) | ||||||
|  |       (lambda (,test-lambda-args) | ||||||
|  |         (destructuring-bind ,(mapcar #'first bindings) | ||||||
|  |             ,test-lambda-args | ||||||
|  |           (if (and ,@(delete-if #'null (mapcar #'third bindings))) | ||||||
|  |               (progn ,@body) | ||||||
|  |               (throw 'run-once | ||||||
|  |                 (list :guard-conditions-failed)))))))) | ||||||
|  | 
 | ||||||
|  | ;;;; *** Implementation | ||||||
|  | 
 | ||||||
|  | ;;;; We could just make FOR-ALL a monster macro, but having FOR-ALL be | ||||||
|  | ;;;; a preproccessor for the perform-random-testing function is | ||||||
|  | ;;;; actually much easier. | ||||||
|  | 
 | ||||||
|  | (defun perform-random-testing (generators body) | ||||||
|  |   (loop | ||||||
|  |      with random-state = *random-state* | ||||||
|  |      with total-counter = *max-trials* | ||||||
|  |      with counter = *num-trials* | ||||||
|  |      with run-at-least-once = nil | ||||||
|  |      until (or (zerop total-counter) | ||||||
|  |                (zerop counter)) | ||||||
|  |      do (let ((result (perform-random-testing/run-once generators body))) | ||||||
|  |           (ecase (first result) | ||||||
|  |             (:pass | ||||||
|  |              (decf counter) | ||||||
|  |              (decf total-counter) | ||||||
|  |              (setf run-at-least-once t)) | ||||||
|  |             (:no-tests | ||||||
|  |              (add-result 'for-all-test-no-tests | ||||||
|  |                          :reason "No tests" | ||||||
|  |                          :random-state random-state) | ||||||
|  |              (return-from perform-random-testing nil)) | ||||||
|  |             (:guard-conditions-failed | ||||||
|  |              (decf total-counter)) | ||||||
|  |             (:fail | ||||||
|  |              (add-result 'for-all-test-failed | ||||||
|  |                          :reason "Found failing test data" | ||||||
|  |                          :random-state random-state | ||||||
|  |                          :failure-values (second result) | ||||||
|  |                          :result-list (third result)) | ||||||
|  |              (return-from perform-random-testing nil)))) | ||||||
|  |      finally (if run-at-least-once | ||||||
|  |                  (add-result 'for-all-test-passed) | ||||||
|  |                  (add-result 'for-all-test-never-run | ||||||
|  |                              :reason "Guard conditions never passed")))) | ||||||
|  | 
 | ||||||
|  | (defun perform-random-testing/run-once (generators body) | ||||||
|  |   (catch 'run-once | ||||||
|  |     (bind-run-state ((result-list '())) | ||||||
|  |       (let ((values (mapcar #'funcall generators))) | ||||||
|  |         (funcall body values) | ||||||
|  |         (cond | ||||||
|  |           ((null result-list) | ||||||
|  |            (throw 'run-once (list :no-tests))) | ||||||
|  |           ((every #'test-passed-p result-list) | ||||||
|  |            (throw 'run-once (list :pass))) | ||||||
|  |           ((notevery #'test-passed-p result-list) | ||||||
|  |            (throw 'run-once (list :fail values result-list)))))))) | ||||||
|  | 
 | ||||||
|  | (defclass for-all-test-result () | ||||||
|  |   ((random-state :initarg :random-state))) | ||||||
|  | 
 | ||||||
|  | (defclass for-all-test-passed (test-passed for-all-test-result) | ||||||
|  |   ()) | ||||||
|  | 
 | ||||||
|  | (defclass for-all-test-failed (test-failure for-all-test-result) | ||||||
|  |   ((failure-values :initarg :failure-values) | ||||||
|  |    (result-list :initarg :result-list))) | ||||||
|  | 
 | ||||||
|  | (defgeneric for-all-test-failed-p (object) | ||||||
|  |   (:method ((object for-all-test-failed)) t) | ||||||
|  |   (:method ((object t)) nil)) | ||||||
|  | 
 | ||||||
|  | (defmethod reason ((result for-all-test-failed)) | ||||||
|  |   (format nil "Falsifiable with ~S" (slot-value result 'failure-values))) | ||||||
|  | 
 | ||||||
|  | (defclass for-all-test-no-tests (test-failure for-all-test-result) | ||||||
|  |   ()) | ||||||
|  | 
 | ||||||
|  | (defclass for-all-test-never-run (test-failure for-all-test-result) | ||||||
|  |   ()) | ||||||
|  | 
 | ||||||
|  | ;;;; *** Generators | ||||||
|  | 
 | ||||||
|  | ;;;; Since this is random testing we need some way of creating random | ||||||
|  | ;;;; data to feed to our code. Generators are regular functions which | ||||||
|  | ;;;; create this random data. | ||||||
|  | 
 | ||||||
|  | ;;;; We provide a set of built-in generators. | ||||||
|  | 
 | ||||||
|  | (defun gen-integer (&key (max (1+ most-positive-fixnum)) | ||||||
|  |                          (min (1- most-negative-fixnum))) | ||||||
|  |   "Returns a generator which produces random integers greater | ||||||
|  | than or equal to MIN and less than or equal to MAX." | ||||||
|  |   (lambda () | ||||||
|  |     (+ min (random (1+ (- max min)))))) | ||||||
|  | 
 | ||||||
|  | (defun gen-float (&key bound (type 'short-float)) | ||||||
|  |   "Returns a generator which produces floats of type TYPE. BOUND, | ||||||
|  | if specified, constrains the results to be in the range (-BOUND, | ||||||
|  | BOUND)." | ||||||
|  |   (lambda () | ||||||
|  |     (let* ((most-negative (ecase type | ||||||
|  |                             (short-float most-negative-short-float) | ||||||
|  |                             (single-float most-negative-single-float) | ||||||
|  |                             (double-float most-negative-double-float) | ||||||
|  |                             (long-float most-negative-long-float))) | ||||||
|  |            (most-positive (ecase type | ||||||
|  |                             (short-float most-positive-short-float) | ||||||
|  |                             (single-float most-positive-single-float) | ||||||
|  |                             (double-float most-positive-double-float) | ||||||
|  |                             (long-float most-positive-long-float))) | ||||||
|  |            (bound (or bound (max most-positive (- most-negative))))) | ||||||
|  |       (coerce | ||||||
|  |        (ecase (random 2) | ||||||
|  |          (0 ;; generate a positive number | ||||||
|  |           (random (min most-positive bound))) | ||||||
|  |          (1 ;; generate a negative number | ||||||
|  |           (- (random (min (- most-negative) bound))))) | ||||||
|  |        type)))) | ||||||
|  | 
 | ||||||
|  | (defun gen-character (&key (code-limit char-code-limit) | ||||||
|  |                            (code (gen-integer :min 0 :max (1- code-limit))) | ||||||
|  |                            (alphanumericp nil)) | ||||||
|  |   "Returns a generator of characters. | ||||||
|  | 
 | ||||||
|  | CODE must be a generator of random integers. ALPHANUMERICP, if | ||||||
|  | non-NIL, limits the returned chars to those which pass | ||||||
|  | alphanumericp." | ||||||
|  |   (lambda () | ||||||
|  |     (loop | ||||||
|  |        for count upfrom 0 | ||||||
|  |        for char = (code-char (funcall code)) | ||||||
|  |        until (and char | ||||||
|  |                   (or (not alphanumericp) | ||||||
|  |                       (alphanumericp char))) | ||||||
|  |        when (= 1000 count) | ||||||
|  |        do (error "After 1000 iterations ~S has still not generated ~:[a valid~;an alphanumeric~] character :(." | ||||||
|  |                  code alphanumericp) | ||||||
|  |        finally (return char)))) | ||||||
|  | 
 | ||||||
|  | (defun gen-string (&key (length (gen-integer :min 0 :max 80)) | ||||||
|  |                         (elements (gen-character)) | ||||||
|  |                         (element-type 'character)) | ||||||
|  |   "Returns a generator which produces random strings. LENGTH must | ||||||
|  | be a generator which produces integers, ELEMENTS must be a | ||||||
|  | generator which produces characters of type ELEMENT-TYPE." | ||||||
|  |   (lambda () | ||||||
|  |     (loop | ||||||
|  |        with length = (funcall length) | ||||||
|  |        with string = (make-string length :element-type element-type) | ||||||
|  |        for index below length | ||||||
|  |        do (setf (aref string index) (funcall elements)) | ||||||
|  |        finally (return string)))) | ||||||
|  | 
 | ||||||
|  | (defun gen-list (&key (length (gen-integer :min 0 :max 10)) | ||||||
|  |                       (elements (gen-integer :min -10 :max 10))) | ||||||
|  |   "Returns a generator which produces random lists. LENGTH must be | ||||||
|  | an integer generator and ELEMENTS must be a generator which | ||||||
|  | produces objects." | ||||||
|  |   (lambda () | ||||||
|  |     (loop | ||||||
|  |        repeat (funcall length) | ||||||
|  |        collect (funcall elements)))) | ||||||
|  | 
 | ||||||
|  | (defun gen-tree (&key (size 20) | ||||||
|  |                       (elements (gen-integer :min -10 :max 10))) | ||||||
|  |   "Returns a generator which produces random trees. SIZE controls | ||||||
|  | the approximate size of the tree, but don't try anything above | ||||||
|  |  30, you have been warned. ELEMENTS must be a generator which | ||||||
|  | will produce the elements." | ||||||
|  |   (labels ((rec (&optional (current-depth 0)) | ||||||
|  |              (let ((key (random (+ 3 (- size current-depth))))) | ||||||
|  |                (cond ((> key 2) | ||||||
|  |                       (list (rec (+ current-depth 1)) | ||||||
|  |                             (rec (+ current-depth 1)))) | ||||||
|  |                      (t (funcall elements)))))) | ||||||
|  |     (lambda () | ||||||
|  |       (rec)))) | ||||||
|  | 
 | ||||||
|  | (defun gen-buffer (&key (length (gen-integer :min 0 :max 50)) | ||||||
|  |                         (element-type '(unsigned-byte 8)) | ||||||
|  |                         (elements (gen-integer :min 0 :max (1- (expt 2 8))))) | ||||||
|  |   (lambda () | ||||||
|  |     (let ((buffer (make-array (funcall length) :element-type element-type))) | ||||||
|  |       (map-into buffer elements)))) | ||||||
|  | 
 | ||||||
|  | (defun gen-one-element (&rest elements) | ||||||
|  |   (lambda () | ||||||
|  |     (nth (random (length elements)) elements))) | ||||||
|  | 
 | ||||||
|  | ;;;; The trivial always-produce-the-same-thing generator is done using | ||||||
|  | ;;;; cl:constantly. | ||||||
							
								
								
									
										385
									
								
								src/run.lisp
									
										
									
									
									
										Normal file
									
								
							
							
						
						
									
										385
									
								
								src/run.lisp
									
										
									
									
									
										Normal file
									
								
							|  | @ -0,0 +1,385 @@ | ||||||
|  | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- | ||||||
|  | 
 | ||||||
|  | (in-package :it.bese.fiveam) | ||||||
|  | 
 | ||||||
|  | ;;;; * Running Tests | ||||||
|  | 
 | ||||||
|  | ;;;; Once the programmer has defined what the tests are these need to | ||||||
|  | ;;;; be run and the expected effects should be compared with the | ||||||
|  | ;;;; actual effects. FiveAM provides the function RUN for this | ||||||
|  | ;;;; purpose, RUN executes a number of tests and collects the results | ||||||
|  | ;;;; of each individual check into a list which is then | ||||||
|  | ;;;; returned. There are three types of test results: passed, failed | ||||||
|  | ;;;; and skipped, these are represented by TEST-RESULT objects. | ||||||
|  | 
 | ||||||
|  | ;;;; Generally running a test will return normally, but there are two | ||||||
|  | ;;;; exceptional situations which can occur: | ||||||
|  | 
 | ||||||
|  | ;;;; - An exception is signaled while running the test. If the | ||||||
|  | ;;;;   variable *on-error* is :DEBUG than FiveAM will enter the | ||||||
|  | ;;;;   debugger, otherwise a test failure (of type | ||||||
|  | ;;;;   unexpected-test-failure) is returned. When entering the | ||||||
|  | ;;;;   debugger two restarts are made available, one simply reruns the | ||||||
|  | ;;;;   current test and another signals a test-failure and continues | ||||||
|  | ;;;;   with the remaining tests. | ||||||
|  | 
 | ||||||
|  | ;;;; - A circular dependency is detected. An error is signaled and a | ||||||
|  | ;;;;   restart is made available which signals a test-skipped and | ||||||
|  | ;;;;   continues with the remaining tests. This restart also sets the | ||||||
|  | ;;;;   dependency status of the test to nil, so any tests which depend | ||||||
|  | ;;;;   on this one (even if the dependency is not circular) will be | ||||||
|  | ;;;;   skipped. | ||||||
|  | 
 | ||||||
|  | ;;;; The functions RUN!, !, !! and !!! are convenient wrappers around | ||||||
|  | ;;;; RUN and EXPLAIN. | ||||||
|  | 
 | ||||||
|  | (deftype on-problem-action () | ||||||
|  |   '(member :debug :backtrace nil)) | ||||||
|  | 
 | ||||||
|  | (declaim (type on-problem-action *on-error* *on-failure*)) | ||||||
|  | 
 | ||||||
|  | (defvar *on-error* nil | ||||||
|  |   "The action to perform on error: | ||||||
|  | - :DEBUG if we should drop into the debugger | ||||||
|  | - :BACKTRACE to print a backtrace | ||||||
|  | - NIL to simply continue") | ||||||
|  | 
 | ||||||
|  | (defvar *on-failure* nil | ||||||
|  |   "The action to perform on check failure: | ||||||
|  | - :DEBUG if we should drop into the debugger | ||||||
|  | - :BACKTRACE to print a backtrace | ||||||
|  | - NIL to simply continue") | ||||||
|  | 
 | ||||||
|  | (defvar *debug-on-error* nil | ||||||
|  |   "T if we should drop into the debugger on error, NIL otherwise. | ||||||
|  | OBSOLETE: superseded by *ON-ERROR*") | ||||||
|  | 
 | ||||||
|  | (defvar *debug-on-failure* nil | ||||||
|  |   "T if we should drop into the debugger on a failing check, NIL otherwise. | ||||||
|  | OBSOLETE: superseded by *ON-FAILURE*") | ||||||
|  | 
 | ||||||
|  | (defparameter *print-names* t | ||||||
|  |   "T if we should print test running progress, NIL otherwise.") | ||||||
|  | 
 | ||||||
|  | (defparameter *test-dribble-indent* (make-array 0 | ||||||
|  |                                         :element-type 'character | ||||||
|  |                                         :fill-pointer 0 | ||||||
|  |                                         :adjustable t) | ||||||
|  |   "Used to indent tests and test suites in their parent suite") | ||||||
|  | 
 | ||||||
|  | (defun import-testing-symbols (package-designator) | ||||||
|  |   (import '(5am::is 5am::is-true 5am::is-false 5am::signals 5am::finishes) | ||||||
|  |           package-designator)) | ||||||
|  | 
 | ||||||
|  | (defparameter *run-queue* '() | ||||||
|  |   "List of test waiting to be run.") | ||||||
|  | 
 | ||||||
|  | (define-condition circular-dependency (error) | ||||||
|  |   ((test-case :initarg :test-case)) | ||||||
|  |   (:report (lambda (cd stream) | ||||||
|  |              (format stream "A circular dependency wes detected in ~S." (slot-value cd 'test-case)))) | ||||||
|  |   (:documentation "Condition signaled when a circular dependency | ||||||
|  | between test-cases has been detected.")) | ||||||
|  | 
 | ||||||
|  | (defgeneric run-resolving-dependencies (test) | ||||||
|  |   (:documentation "Given a dependency spec determine if the spec | ||||||
|  | is satisfied or not, this will generally involve running other | ||||||
|  | tests. If the dependency spec can be satisfied the test is also | ||||||
|  | run.")) | ||||||
|  | 
 | ||||||
|  | (defmethod run-resolving-dependencies ((test test-case)) | ||||||
|  |   "Return true if this test, and its dependencies, are satisfied, | ||||||
|  |   NIL otherwise." | ||||||
|  |   (case (status test) | ||||||
|  |     (:unknown | ||||||
|  |      (setf (status test) :resolving) | ||||||
|  |      (if (or (not (depends-on test)) | ||||||
|  |              (eql t (resolve-dependencies (depends-on test)))) | ||||||
|  |          (progn | ||||||
|  |            (run-test-lambda test) | ||||||
|  |            (status test)) | ||||||
|  |          (with-run-state (result-list) | ||||||
|  |            (unless (eql :circular (status test)) | ||||||
|  |              (push (make-instance 'test-skipped | ||||||
|  |                                   :test-case test | ||||||
|  |                                   :reason "Dependencies not satisfied") | ||||||
|  |                    result-list) | ||||||
|  |              (setf (status test) :depends-not-satisfied))))) | ||||||
|  |     (:resolving | ||||||
|  |      (restart-case | ||||||
|  |          (error 'circular-dependency :test-case test) | ||||||
|  |        (skip () | ||||||
|  |          :report (lambda (s) | ||||||
|  |                    (format s "Skip the test ~S and all its dependencies." (name test))) | ||||||
|  |          (with-run-state (result-list) | ||||||
|  |            (push (make-instance 'test-skipped :reason "Circular dependencies" :test-case test) | ||||||
|  |                  result-list)) | ||||||
|  |          (setf (status test) :circular)))) | ||||||
|  |     (t (status test)))) | ||||||
|  | 
 | ||||||
|  | (defgeneric resolve-dependencies (depends-on)) | ||||||
|  | 
 | ||||||
|  | (defmethod resolve-dependencies ((depends-on symbol)) | ||||||
|  |   "A test which depends on a symbol is interpreted as `(AND | ||||||
|  |   ,DEPENDS-ON)." | ||||||
|  |   (run-resolving-dependencies (get-test depends-on))) | ||||||
|  | 
 | ||||||
|  | (defmethod resolve-dependencies ((depends-on list)) | ||||||
|  |   "Return true if the dependency spec DEPENDS-ON is satisfied, | ||||||
|  |   nil otherwise." | ||||||
|  |   (if (null depends-on) | ||||||
|  |       t | ||||||
|  |       (flet ((satisfies-depends-p (test) | ||||||
|  |                (funcall test (lambda (dep) | ||||||
|  |                                (eql t (resolve-dependencies dep))) | ||||||
|  |                         (cdr depends-on)))) | ||||||
|  |         (ecase (car depends-on) | ||||||
|  |           (and (satisfies-depends-p #'every)) | ||||||
|  |           (or  (satisfies-depends-p #'some)) | ||||||
|  |           (not (satisfies-depends-p #'notany)) | ||||||
|  |           (:before (every #'(lambda (dep) | ||||||
|  |                               (let ((status (status (get-test dep)))) | ||||||
|  |                                 (if (eql :unknown status) | ||||||
|  |                                     (run-resolving-dependencies (get-test dep)) | ||||||
|  |                                     status))) | ||||||
|  |                           (cdr depends-on))))))) | ||||||
|  | 
 | ||||||
|  | (defun results-status (result-list) | ||||||
|  |   "Given a list of test results (generated while running a test) | ||||||
|  |   return true if no results are of type TEST-FAILURE.  Returns second | ||||||
|  |   and third values, which are the set of failed tests and skipped | ||||||
|  |   tests respectively." | ||||||
|  |   (let ((failed-tests | ||||||
|  |           (remove-if-not #'test-failure-p result-list)) | ||||||
|  |         (skipped-tests | ||||||
|  |           (remove-if-not #'test-skipped-p result-list))) | ||||||
|  |     (values (null failed-tests) | ||||||
|  |             failed-tests | ||||||
|  |             skipped-tests))) | ||||||
|  | 
 | ||||||
|  | (defun return-result-list (test-lambda) | ||||||
|  |   "Run the test function TEST-LAMBDA and return a list of all | ||||||
|  |   test results generated, does not modify the special environment | ||||||
|  |   variable RESULT-LIST." | ||||||
|  |   (bind-run-state ((result-list '())) | ||||||
|  |     (funcall test-lambda) | ||||||
|  |     result-list)) | ||||||
|  | 
 | ||||||
|  | (defgeneric run-test-lambda (test)) | ||||||
|  | 
 | ||||||
|  | (defmethod run-test-lambda ((test test-case)) | ||||||
|  |   (with-run-state (result-list) | ||||||
|  |     (bind-run-state ((current-test test)) | ||||||
|  |       (labels ((abort-test (e &optional (reason (format nil "Unexpected Error: ~S~%~A." e e))) | ||||||
|  |                  (add-result 'unexpected-test-failure | ||||||
|  |                              :test-expr nil | ||||||
|  |                              :test-case test | ||||||
|  |                              :reason reason | ||||||
|  |                              :condition e)) | ||||||
|  |                (run-it () | ||||||
|  |                  (let ((result-list '())) | ||||||
|  |                    (declare (special result-list)) | ||||||
|  |                    (handler-bind ((check-failure (lambda (e) | ||||||
|  |                                                    (declare (ignore e)) | ||||||
|  |                                                    (cond | ||||||
|  |                                                      ((eql *on-failure* :debug) | ||||||
|  |                                                       nil) | ||||||
|  |                                                      (t | ||||||
|  |                                                       (when (eql *on-failure* :backtrace) | ||||||
|  |                                                         (trivial-backtrace:print-backtrace-to-stream | ||||||
|  |                                                          *test-dribble*)) | ||||||
|  |                                                       (invoke-restart | ||||||
|  |                                                        (find-restart 'ignore-failure)))))) | ||||||
|  |                                   (error (lambda (e) | ||||||
|  |                                            (unless (or (eql *on-error* :debug) | ||||||
|  |                                                        (typep e 'check-failure)) | ||||||
|  |                                              (when (eql *on-error* :backtrace) | ||||||
|  |                                                (trivial-backtrace:print-backtrace-to-stream | ||||||
|  |                                                 *test-dribble*)) | ||||||
|  |                                              (abort-test e) | ||||||
|  |                                              (return-from run-it result-list))))) | ||||||
|  |                      (restart-case | ||||||
|  |                          (handler-case | ||||||
|  |                              (let ((*readtable* (copy-readtable)) | ||||||
|  |                                    (*package* (runtime-package test))) | ||||||
|  |                                (when *print-names* | ||||||
|  |                                    (format *test-dribble* "~%~ARunning test ~A " *test-dribble-indent* (name test))) | ||||||
|  |                                (if (collect-profiling-info test) | ||||||
|  |                                    ;; Timing info doesn't get collected ATM, we need a portable library | ||||||
|  |                                    ;; (setf (profiling-info test) (collect-timing (test-lambda test))) | ||||||
|  |                                    (funcall (test-lambda test)) | ||||||
|  |                                    (funcall (test-lambda test)))) | ||||||
|  |                            (storage-condition (e) | ||||||
|  |                              ;; heap-exhausted/constrol-stack-exhausted | ||||||
|  |                              ;; handler-case unwinds the stack (unlike handler-bind) | ||||||
|  |                              (abort-test e (format nil "STORAGE-CONDITION: aborted for safety. ~S~%~A." e e)) | ||||||
|  |                              (return-from run-it result-list))) | ||||||
|  |                        (retest () | ||||||
|  |                          :report (lambda (stream) | ||||||
|  |                                    (format stream "~@<Rerun the test ~S~@:>" test)) | ||||||
|  |                          (return-from run-it (run-it))) | ||||||
|  |                        (ignore () | ||||||
|  |                          :report (lambda (stream) | ||||||
|  |                                    (format stream "~@<Signal an exceptional test failure and abort the test ~S.~@:>" test)) | ||||||
|  |                          (abort-test (make-instance 'test-failure :test-case test | ||||||
|  |                                                                   :reason "Failure restart.")))) | ||||||
|  |                      result-list)))) | ||||||
|  |         (let ((results (run-it))) | ||||||
|  |           (setf (status test) (results-status results) | ||||||
|  |                 result-list (nconc result-list results))))))) | ||||||
|  | 
 | ||||||
|  | (defgeneric %run (test-spec) | ||||||
|  |   (:documentation "Internal method for running a test. Does not | ||||||
|  |   update the status of the tests nor the special variables !, | ||||||
|  |   !!, !!!")) | ||||||
|  | 
 | ||||||
|  | (defmethod %run ((test test-case)) | ||||||
|  |   (run-resolving-dependencies test)) | ||||||
|  | 
 | ||||||
|  | (defmethod %run ((tests list)) | ||||||
|  |   (mapc #'%run tests)) | ||||||
|  | 
 | ||||||
|  | (defmethod %run ((suite test-suite)) | ||||||
|  |   (when *print-names* | ||||||
|  |     (format *test-dribble* "~%~ARunning test suite ~A" *test-dribble-indent* (name suite))) | ||||||
|  |   (let ((suite-results '())) | ||||||
|  |     (flet ((run-tests () | ||||||
|  |              (loop | ||||||
|  |                 for test being the hash-values of (tests suite) | ||||||
|  |                 do (%run test)))) | ||||||
|  |       (vector-push-extend #\space *test-dribble-indent*) | ||||||
|  |       (unwind-protect | ||||||
|  |            (bind-run-state ((result-list '())) | ||||||
|  |              (unwind-protect | ||||||
|  |                   (if (collect-profiling-info suite) | ||||||
|  |                       ;; Timing info doesn't get collected ATM, we need a portable library | ||||||
|  |                       ;; (setf (profiling-info suite) (collect-timing #'run-tests)) | ||||||
|  |                       (run-tests) | ||||||
|  |                       (run-tests))) | ||||||
|  |              (setf suite-results result-list | ||||||
|  |                    (status suite) (every #'test-passed-p suite-results))) | ||||||
|  |         (vector-pop *test-dribble-indent*) | ||||||
|  |         (with-run-state (result-list) | ||||||
|  |           (setf result-list (nconc result-list suite-results))))))) | ||||||
|  | 
 | ||||||
|  | (defmethod %run ((test-name symbol)) | ||||||
|  |   (when-let (test (get-test test-name)) | ||||||
|  |     (%run test))) | ||||||
|  | 
 | ||||||
|  | (defvar *initial-!* (lambda () (format t "Haven't run that many tests yet.~%"))) | ||||||
|  | 
 | ||||||
|  | (defvar *!* *initial-!*) | ||||||
|  | (defvar *!!* *initial-!*) | ||||||
|  | (defvar *!!!* *initial-!*) | ||||||
|  | 
 | ||||||
|  | ;;;; ** Public entry points | ||||||
|  | 
 | ||||||
|  | (defun run! (&optional (test-spec *suite*) | ||||||
|  |              &key ((:print-names *print-names*) *print-names*)) | ||||||
|  |   "Equivalent to (explain! (run TEST-SPEC))." | ||||||
|  |   (explain! (run test-spec))) | ||||||
|  | 
 | ||||||
|  | (defun explain! (result-list) | ||||||
|  |   "Explain the results of RESULT-LIST using a | ||||||
|  | detailed-text-explainer with output going to *test-dribble*. | ||||||
|  | Return a boolean indicating whether no tests failed." | ||||||
|  |   (explain (make-instance 'detailed-text-explainer) result-list *test-dribble*) | ||||||
|  |   (results-status result-list)) | ||||||
|  | 
 | ||||||
|  | (defun debug! (&optional (test-spec *suite*)) | ||||||
|  |   "Calls (run! test-spec) but enters the debugger if any kind of error happens." | ||||||
|  |   (let ((*on-error* :debug) | ||||||
|  |         (*on-failure* :debug)) | ||||||
|  |     (run! test-spec))) | ||||||
|  | 
 | ||||||
|  | (defun run (test-spec &key ((:print-names *print-names*) *print-names*)) | ||||||
|  |   "Run the test specified by TEST-SPEC. | ||||||
|  | 
 | ||||||
|  | TEST-SPEC can be either a symbol naming a test or test suite, or | ||||||
|  | a testable-object object. This function changes the operations | ||||||
|  | performed by the !, !! and !!! functions." | ||||||
|  |   (psetf *!* (lambda () | ||||||
|  |                (loop :for test :being :the :hash-keys :of *test* | ||||||
|  |                      :do (setf (status (get-test test)) :unknown)) | ||||||
|  |                (bind-run-state ((result-list '())) | ||||||
|  |                  (with-simple-restart (explain "Ignore the rest of the tests and explain current results") | ||||||
|  |                    (%run test-spec)) | ||||||
|  |                  result-list)) | ||||||
|  |          *!!* *!* | ||||||
|  |          *!!!* *!!*) | ||||||
|  |   (let ((*on-error* | ||||||
|  |           (or *on-error* (cond | ||||||
|  |                            (*debug-on-error* | ||||||
|  |                             (format *test-dribble* "*DEBUG-ON-ERROR* is obsolete. Use *ON-ERROR*.") | ||||||
|  |                             :debug) | ||||||
|  |                            (t nil)))) | ||||||
|  |         (*on-failure* | ||||||
|  |           (or *on-failure* (cond | ||||||
|  |                            (*debug-on-failure* | ||||||
|  |                             (format *test-dribble* "*DEBUG-ON-FAILURE* is obsolete. Use *ON-FAILURE*.") | ||||||
|  |                             :debug) | ||||||
|  |                            (t nil))))) | ||||||
|  |     (funcall *!*))) | ||||||
|  | 
 | ||||||
|  | (defun ! () | ||||||
|  |   "Rerun the most recently run test and explain the results." | ||||||
|  |   (explain! (funcall *!*))) | ||||||
|  | 
 | ||||||
|  | (defun !! () | ||||||
|  |   "Rerun the second most recently run test and explain the results." | ||||||
|  |   (explain! (funcall *!!*))) | ||||||
|  | 
 | ||||||
|  | (defun !!! () | ||||||
|  |   "Rerun the third most recently run test and explain the results." | ||||||
|  |   (explain! (funcall *!!!*))) | ||||||
|  | 
 | ||||||
|  | (defun run-all-tests (&key (summary :end)) | ||||||
|  |   "Runs all defined test suites, T if all tests passed and NIL otherwise. | ||||||
|  | SUMMARY can be :END to print a summary at the end, :SUITE to print it | ||||||
|  | after each suite or NIL to skip explanations." | ||||||
|  |   (check-type summary (member nil :suite :end)) | ||||||
|  |   (loop :for suite :in (cons 'nil (sort (copy-list *toplevel-suites*) #'string<=)) | ||||||
|  |         :for results := (if (suite-emptyp suite) nil (run suite)) | ||||||
|  |         :when (consp results) | ||||||
|  |           :collect results :into all-results | ||||||
|  |         :do (cond | ||||||
|  |               ((not (eql summary :suite)) | ||||||
|  |                nil) | ||||||
|  |               (results | ||||||
|  |                (explain! results)) | ||||||
|  |               (suite | ||||||
|  |                (format *test-dribble* "Suite ~A is empty~%" suite))) | ||||||
|  |         :finally (progn | ||||||
|  |                    (when (eql summary :end) | ||||||
|  |                      (explain! (alexandria:flatten all-results))) | ||||||
|  |                    (return (every #'results-status all-results))))) | ||||||
|  | 
 | ||||||
|  | ;; Copyright (c) 2002-2003, Edward Marco Baringer | ||||||
|  | ;; All rights reserved. | ||||||
|  | ;; | ||||||
|  | ;; Redistribution and use in source and binary forms, with or without | ||||||
|  | ;; modification, are permitted provided that the following conditions are | ||||||
|  | ;; met: | ||||||
|  | ;; | ||||||
|  | ;;  - Redistributions of source code must retain the above copyright | ||||||
|  | ;;    notice, this list of conditions and the following disclaimer. | ||||||
|  | ;; | ||||||
|  | ;;  - Redistributions in binary form must reproduce the above copyright | ||||||
|  | ;;    notice, this list of conditions and the following disclaimer in the | ||||||
|  | ;;    documentation and/or other materials provided with the distribution. | ||||||
|  | ;; | ||||||
|  | ;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names | ||||||
|  | ;;    of its contributors may be used to endorse or promote products | ||||||
|  | ;;    derived from this software without specific prior written permission. | ||||||
|  | ;; | ||||||
|  | ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS | ||||||
|  | ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT | ||||||
|  | ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR | ||||||
|  | ;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT | ||||||
|  | ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, | ||||||
|  | ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT | ||||||
|  | ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, | ||||||
|  | ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY | ||||||
|  | ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT | ||||||
|  | ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE | ||||||
|  | ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. | ||||||
							
								
								
									
										64
									
								
								src/style.css
									
										
									
									
									
										Normal file
									
								
							
							
						
						
									
										64
									
								
								src/style.css
									
										
									
									
									
										Normal file
									
								
							|  | @ -0,0 +1,64 @@ | ||||||
|  | body { | ||||||
|  |   background-color: #FFFFFF; | ||||||
|  |   color: #000000; | ||||||
|  |   padding: 0px; margin: 0px; | ||||||
|  | } | ||||||
|  | 
 | ||||||
|  | .qbook { width: 600px; background-color: #FFFFFF; margin: 0px;  | ||||||
|  |          border-left: 3em solid #660000; padding: 3px; } | ||||||
|  | 
 | ||||||
|  | h1 { text-align: center; margin: 0px; | ||||||
|  |      color: #333333;  | ||||||
|  |      border-bottom: 0.3em solid #660000;  | ||||||
|  | } | ||||||
|  | 
 | ||||||
|  | p { padding-left: 1em; } | ||||||
|  | 
 | ||||||
|  | h2 { border-bottom: 0.2em solid #000000; font-family: verdana; } | ||||||
|  | 
 | ||||||
|  | h3 { border-bottom: 0.1em solid #000000; } | ||||||
|  | 
 | ||||||
|  | pre.code { | ||||||
|  | 	background-color: #eeeeee; | ||||||
|  | 	border: solid 1px #d0d0d0; | ||||||
|  |         overflow: auto; | ||||||
|  | } | ||||||
|  | 
 | ||||||
|  | pre.code * .paren { color: #666666; }  | ||||||
|  | 
 | ||||||
|  | pre.code a:active  { color: #000000; } | ||||||
|  | pre.code a:link    { color: #000000; } | ||||||
|  | pre.code a:visited { color: #000000; } | ||||||
|  | 
 | ||||||
|  | pre.code .first-line { font-weight: bold; } | ||||||
|  | 
 | ||||||
|  | div.contents { font-family: verdana; } | ||||||
|  | 
 | ||||||
|  | div.contents a:active  { color: #000000; } | ||||||
|  | div.contents a:link    { color: #000000; } | ||||||
|  | div.contents a:visited { color: #000000; } | ||||||
|  | 
 | ||||||
|  | div.contents div.contents-heading-1 { padding-left: 0.5em; font-weight: bold; } | ||||||
|  | div.contents div.contents-heading-1 a:active  { color: #660000; } | ||||||
|  | div.contents div.contents-heading-1 a:link    { color: #660000; } | ||||||
|  | div.contents div.contents-heading-1 a:visited { color: #660000; } | ||||||
|  | 
 | ||||||
|  | div.contents div.contents-heading-2 { padding-left: 1.0em; } | ||||||
|  | div.contents div.contents-heading-2 a:active  { color: #660000; } | ||||||
|  | div.contents div.contents-heading-2 a:link    { color: #660000; } | ||||||
|  | div.contents div.contents-heading-2 a:visited { color: #660000; } | ||||||
|  | 
 | ||||||
|  | div.contents div.contents-heading-3 { padding-left: 1.5em; } | ||||||
|  | div.contents div.contents-heading-3 a:active  { color: #660000; } | ||||||
|  | div.contents div.contents-heading-3 a:link    { color: #660000; } | ||||||
|  | div.contents div.contents-heading-3 a:visited { color: #660000; } | ||||||
|  | 
 | ||||||
|  | div.contents div.contents-heading-4 { padding-left: 2em; } | ||||||
|  | div.contents div.contents-heading-4 a:active  { color: #660000; } | ||||||
|  | div.contents div.contents-heading-4 a:link    { color: #660000; } | ||||||
|  | div.contents div.contents-heading-4 a:visited { color: #660000; } | ||||||
|  | 
 | ||||||
|  | div.contents div.contents-heading-5 { padding-left: 2.5em; } | ||||||
|  | div.contents div.contents-heading-5 a:active  { color: #660000; } | ||||||
|  | div.contents div.contents-heading-5 a:link    { color: #660000; } | ||||||
|  | div.contents div.contents-heading-5 a:visited { color: #660000; } | ||||||
							
								
								
									
										140
									
								
								src/suite.lisp
									
										
									
									
									
										Normal file
									
								
							
							
						
						
									
										140
									
								
								src/suite.lisp
									
										
									
									
									
										Normal file
									
								
							|  | @ -0,0 +1,140 @@ | ||||||
|  | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- | ||||||
|  | 
 | ||||||
|  | (in-package :it.bese.fiveam) | ||||||
|  | 
 | ||||||
|  | ;;;; * Test Suites | ||||||
|  | 
 | ||||||
|  | ;;;; Test suites allow us to collect multiple tests into a single | ||||||
|  | ;;;; object and run them all using asingle name. Test suites do not | ||||||
|  | ;;;; affect the way test are run nor the way the results are handled, | ||||||
|  | ;;;; they are simply a test organizing group. | ||||||
|  | 
 | ||||||
|  | ;;;; Test suites can contain both tests and other test suites. Running | ||||||
|  | ;;;; a test suite causes all of its tests and test suites to be | ||||||
|  | ;;;; run. Suites do not affect test dependencies, running a test suite | ||||||
|  | ;;;; can cause tests which are not in the suite to be run. | ||||||
|  | 
 | ||||||
|  | ;;;; ** Current Suite | ||||||
|  | 
 | ||||||
|  | (defvar *suite* nil | ||||||
|  |   "The current test suite object") | ||||||
|  | (net.didierverna.asdf-flv:set-file-local-variable *suite*) | ||||||
|  | 
 | ||||||
|  | ;;;; ** Creating Suits | ||||||
|  | 
 | ||||||
|  | ;; Suites that have no parent suites. | ||||||
|  | (defvar *toplevel-suites* nil) | ||||||
|  | 
 | ||||||
|  | (defgeneric suite-emptyp (suite) | ||||||
|  |   (:method ((suite symbol)) | ||||||
|  |     (suite-emptyp (get-test suite))) | ||||||
|  |   (:method ((suite test-suite)) | ||||||
|  |     (= 0 (hash-table-count (tests suite))))) | ||||||
|  | 
 | ||||||
|  | (defmacro def-suite (name &key description in) | ||||||
|  |   "Define a new test-suite named NAME. | ||||||
|  | 
 | ||||||
|  | IN (a symbol), if provided, causes this suite te be nested in the | ||||||
|  | suite named by IN. NB: This macro is built on top of make-suite, | ||||||
|  | as such it, like make-suite, will overrwrite any existing suite | ||||||
|  | named NAME." | ||||||
|  |   `(eval-when (:compile-toplevel :load-toplevel :execute) | ||||||
|  |      (make-suite ',name | ||||||
|  |                  ,@(when description `(:description ,description)) | ||||||
|  |                  ,@(when in `(:in ',in))) | ||||||
|  |      ',name)) | ||||||
|  | 
 | ||||||
|  | (defmacro def-suite* (name &rest def-suite-args) | ||||||
|  |   `(progn | ||||||
|  |      (def-suite ,name ,@def-suite-args) | ||||||
|  |      (in-suite ,name))) | ||||||
|  | 
 | ||||||
|  | (defun make-suite (name &key description ((:in parent-suite))) | ||||||
|  |   "Create a new test suite object. | ||||||
|  | 
 | ||||||
|  | Overrides any existing suite named NAME." | ||||||
|  |   (let ((suite (make-instance 'test-suite :name name))) | ||||||
|  |     (when description | ||||||
|  |       (setf (description suite) description)) | ||||||
|  |     (when (and name | ||||||
|  |                (null (name *suite*)) | ||||||
|  |                (null parent-suite)) | ||||||
|  |       (pushnew name *toplevel-suites*)) | ||||||
|  |     (loop for i in (ensure-list parent-suite) | ||||||
|  |           for in-suite = (get-test i) | ||||||
|  |           do (progn | ||||||
|  |                (when (null in-suite) | ||||||
|  |                  (cerror "Create a new suite named ~A." "Unknown suite ~A." i) | ||||||
|  |                  (setf (get-test in-suite) (make-suite i) | ||||||
|  |                        in-suite (get-test in-suite))) | ||||||
|  |                (setf (gethash name (tests in-suite)) suite))) | ||||||
|  |     (setf (get-test name) suite) | ||||||
|  |     suite)) | ||||||
|  | 
 | ||||||
|  | (eval-when (:load-toplevel :execute) | ||||||
|  |   (setf *suite* | ||||||
|  |         (setf (get-test 'nil) | ||||||
|  |               (make-suite 'nil :description "Global Suite")))) | ||||||
|  | 
 | ||||||
|  | (defun list-all-suites () | ||||||
|  |   "Returns an unordered LIST of all suites." | ||||||
|  |   (hash-table-values *suite*)) | ||||||
|  | 
 | ||||||
|  | ;;;; ** Managing the Current Suite | ||||||
|  | 
 | ||||||
|  | (defmacro in-suite (suite-name) | ||||||
|  |   "Set the *suite* special variable so that all tests defined | ||||||
|  | after the execution of this form are, unless specified otherwise, | ||||||
|  | in the test-suite named SUITE-NAME. | ||||||
|  | 
 | ||||||
|  | See also: DEF-SUITE *SUITE*" | ||||||
|  |   `(eval-when (:compile-toplevel :load-toplevel :execute) | ||||||
|  |      (%in-suite ,suite-name))) | ||||||
|  | 
 | ||||||
|  | (defmacro in-suite* (suite-name &key in) | ||||||
|  |   "Just like in-suite, but silently creates missing suites." | ||||||
|  |   `(eval-when (:compile-toplevel :load-toplevel :execute) | ||||||
|  |      (%in-suite ,suite-name :in ,in :fail-on-error nil))) | ||||||
|  | 
 | ||||||
|  | (defmacro %in-suite (suite-name &key (fail-on-error t) in) | ||||||
|  |   (with-gensyms (suite) | ||||||
|  |     `(progn | ||||||
|  |        (if-let (,suite (get-test ',suite-name)) | ||||||
|  |          (setf *suite* ,suite) | ||||||
|  |          (progn | ||||||
|  |            (when ,fail-on-error | ||||||
|  |              (cerror "Create a new suite named ~A." | ||||||
|  |                      "Unknown suite ~A." ',suite-name)) | ||||||
|  |            (setf (get-test ',suite-name) (make-suite ',suite-name :in ',in) | ||||||
|  |                  *suite* (get-test ',suite-name)))) | ||||||
|  |        ',suite-name))) | ||||||
|  | 
 | ||||||
|  | ;; Copyright (c) 2002-2003, Edward Marco Baringer | ||||||
|  | ;; All rights reserved. | ||||||
|  | ;; | ||||||
|  | ;; Redistribution and use in source and binary forms, with or without | ||||||
|  | ;; modification, are permitted provided that the following conditions are | ||||||
|  | ;; met: | ||||||
|  | ;; | ||||||
|  | ;;  - Redistributions of source code must retain the above copyright | ||||||
|  | ;;    notice, this list of conditions and the following disclaimer. | ||||||
|  | ;; | ||||||
|  | ;;  - Redistributions in binary form must reproduce the above copyright | ||||||
|  | ;;    notice, this list of conditions and the following disclaimer in the | ||||||
|  | ;;    documentation and/or other materials provided with the distribution. | ||||||
|  | ;; | ||||||
|  | ;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names | ||||||
|  | ;;    of its contributors may be used to endorse or promote products | ||||||
|  | ;;    derived from this software without specific prior written permission. | ||||||
|  | ;; | ||||||
|  | ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS | ||||||
|  | ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT | ||||||
|  | ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR | ||||||
|  | ;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT | ||||||
|  | ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, | ||||||
|  | ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT | ||||||
|  | ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, | ||||||
|  | ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY | ||||||
|  | ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT | ||||||
|  | ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE | ||||||
|  | ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE | ||||||
							
								
								
									
										167
									
								
								src/test.lisp
									
										
									
									
									
										Normal file
									
								
							
							
						
						
									
										167
									
								
								src/test.lisp
									
										
									
									
									
										Normal file
									
								
							|  | @ -0,0 +1,167 @@ | ||||||
|  | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- | ||||||
|  | 
 | ||||||
|  | (in-package :it.bese.fiveam) | ||||||
|  | 
 | ||||||
|  | ;;;; * Tests | ||||||
|  | 
 | ||||||
|  | ;;;; While executing checks and collecting the results is the core job | ||||||
|  | ;;;; of a testing framework it is also important to be able to | ||||||
|  | ;;;; organize checks into groups, fiveam provides two mechanisms for | ||||||
|  | ;;;; organizing checks: tests and test suites. A test is a named | ||||||
|  | ;;;; collection of checks which can be run and a test suite is a named | ||||||
|  | ;;;; collection of tests and test suites. | ||||||
|  | 
 | ||||||
|  | (declaim (special *suite*)) | ||||||
|  | 
 | ||||||
|  | (defvar *test* | ||||||
|  |   (make-hash-table :test 'eql) | ||||||
|  |   "Lookup table mapping test (and test suite) | ||||||
|  |   names to objects.") | ||||||
|  | 
 | ||||||
|  | (defun get-test (key &optional default) | ||||||
|  |   (gethash key *test* default)) | ||||||
|  | 
 | ||||||
|  | (defun (setf get-test) (value key) | ||||||
|  |   (setf (gethash key *test*) value)) | ||||||
|  | 
 | ||||||
|  | (defun rem-test (key) | ||||||
|  |   (remhash key *test*)) | ||||||
|  | 
 | ||||||
|  | (defun test-names () | ||||||
|  |   (hash-table-keys *test*)) | ||||||
|  | 
 | ||||||
|  | (defmacro test (name &body body) | ||||||
|  |   "Create a test named NAME. If NAME is a list it must be of the | ||||||
|  | form: | ||||||
|  | 
 | ||||||
|  |   (name &key depends-on suite fixture compile-at profile) | ||||||
|  | 
 | ||||||
|  | NAME is the symbol which names the test. | ||||||
|  | 
 | ||||||
|  | DEPENDS-ON is a list of the form: | ||||||
|  | 
 | ||||||
|  |  (AND . test-names) - This test is run only if all of the tests | ||||||
|  |  in TEST-NAMES have passed, otherwise a single test-skipped | ||||||
|  |  result is generated. | ||||||
|  | 
 | ||||||
|  |  (OR . test-names) - If any of TEST-NAMES has passed this test is | ||||||
|  |  run, otherwise a test-skipped result is generated. | ||||||
|  | 
 | ||||||
|  |  (NOT test-name) - This is test is run only if TEST-NAME failed. | ||||||
|  | 
 | ||||||
|  | AND, OR and NOT can be combined to produce complex dependencies. | ||||||
|  | 
 | ||||||
|  | If DEPENDS-ON is a symbol it is interpreted as `(AND | ||||||
|  | ,depends-on), this is accomadate the common case of one test | ||||||
|  | depending on another. | ||||||
|  | 
 | ||||||
|  | FIXTURE specifies a fixture to wrap the body in. | ||||||
|  | 
 | ||||||
|  | If PROFILE is T profiling information will be collected as well." | ||||||
|  |   (destructuring-bind (name &rest args) | ||||||
|  |       (ensure-list name) | ||||||
|  |     `(def-test ,name (,@args) ,@body))) | ||||||
|  | 
 | ||||||
|  | (defvar *default-test-compilation-time* :definition-time) | ||||||
|  | 
 | ||||||
|  | (defmacro def-test (name (&key depends-on (suite '*suite* suite-p) fixture | ||||||
|  |                             (compile-at *default-test-compilation-time*) profile) | ||||||
|  |                     &body body) | ||||||
|  |   "Create a test named NAME. | ||||||
|  | 
 | ||||||
|  | NAME is the symbol which names the test. | ||||||
|  | 
 | ||||||
|  | DEPENDS-ON is a list of the form: | ||||||
|  | 
 | ||||||
|  |  (AND . test-names) - This test is run only if all of the tests | ||||||
|  |  in TEST-NAMES have passed, otherwise a single test-skipped | ||||||
|  |  result is generated. | ||||||
|  | 
 | ||||||
|  |  (OR . test-names) - If any of TEST-NAMES has passed this test is | ||||||
|  |  run, otherwise a test-skipped result is generated. | ||||||
|  | 
 | ||||||
|  |  (NOT test-name) - This is test is run only if TEST-NAME failed. | ||||||
|  | 
 | ||||||
|  | AND, OR and NOT can be combined to produce complex dependencies. | ||||||
|  | 
 | ||||||
|  | If DEPENDS-ON is a symbol it is interpreted as `(AND | ||||||
|  | ,depends-on), this is accomadate the common case of one test | ||||||
|  | depending on another. | ||||||
|  | 
 | ||||||
|  | FIXTURE specifies a fixture to wrap the body in. | ||||||
|  | 
 | ||||||
|  | If PROFILE is T profiling information will be collected as well." | ||||||
|  |   (check-type compile-at (member :run-time :definition-time)) | ||||||
|  |   (multiple-value-bind (forms decls docstring) | ||||||
|  |       (parse-body body :documentation t :whole name) | ||||||
|  |     (let* ((description (or docstring "")) | ||||||
|  |            (body-forms (append decls forms)) | ||||||
|  |            (suite-form (if suite-p | ||||||
|  |                            `(get-test ',suite) | ||||||
|  |                            (or suite '*suite*))) | ||||||
|  |            (effective-body (if fixture | ||||||
|  |                                (destructuring-bind (name &rest args) | ||||||
|  |                                    (ensure-list fixture) | ||||||
|  |                                  `((with-fixture ,name ,args ,@body-forms))) | ||||||
|  |                                body-forms))) | ||||||
|  |       `(progn | ||||||
|  |          (register-test ',name ,description ',effective-body ,suite-form ',depends-on ,compile-at ,profile) | ||||||
|  |          (when *run-test-when-defined* | ||||||
|  |            (run! ',name)) | ||||||
|  |          ',name)))) | ||||||
|  | 
 | ||||||
|  | (defun register-test (name description body suite depends-on compile-at profile) | ||||||
|  |   (let ((lambda-name | ||||||
|  |           (format-symbol t "%~A-~A" '#:test name)) | ||||||
|  |         (inner-lambda-name | ||||||
|  |           (format-symbol t "%~A-~A" '#:inner-test name))) | ||||||
|  |     (setf (get-test name) | ||||||
|  |           (make-instance 'test-case | ||||||
|  |                          :name name | ||||||
|  |                          :runtime-package (find-package (package-name *package*)) | ||||||
|  |                          :test-lambda | ||||||
|  |                          (eval | ||||||
|  |                           `(named-lambda ,lambda-name () | ||||||
|  |                              ,@(ecase compile-at | ||||||
|  |                                  (:run-time `((funcall | ||||||
|  |                                                (let ((*package* (find-package ',(package-name *package*)))) | ||||||
|  |                                                  (compile ',inner-lambda-name | ||||||
|  |                                                           '(lambda () ,@body)))))) | ||||||
|  |                                  (:definition-time body)))) | ||||||
|  |                          :description description | ||||||
|  |                          :depends-on depends-on | ||||||
|  |                          :collect-profiling-info profile)) | ||||||
|  |     (setf (gethash name (tests suite)) name))) | ||||||
|  | 
 | ||||||
|  | (defvar *run-test-when-defined* nil | ||||||
|  |   "When non-NIL tests are run as soon as they are defined.") | ||||||
|  | 
 | ||||||
|  | ;; Copyright (c) 2002-2003, Edward Marco Baringer | ||||||
|  | ;; All rights reserved. | ||||||
|  | ;; | ||||||
|  | ;; Redistribution and use in source and binary forms, with or without | ||||||
|  | ;; modification, are permitted provided that the following conditions are | ||||||
|  | ;; met: | ||||||
|  | ;; | ||||||
|  | ;;  - Redistributions of source code must retain the above copyright | ||||||
|  | ;;    notice, this list of conditions and the following disclaimer. | ||||||
|  | ;; | ||||||
|  | ;;  - Redistributions in binary form must reproduce the above copyright | ||||||
|  | ;;    notice, this list of conditions and the following disclaimer in the | ||||||
|  | ;;    documentation and/or other materials provided with the distribution. | ||||||
|  | ;; | ||||||
|  | ;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names | ||||||
|  | ;;    of its contributors may be used to endorse or promote products | ||||||
|  | ;;    derived from this software without specific prior written permission. | ||||||
|  | ;; | ||||||
|  | ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS | ||||||
|  | ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT | ||||||
|  | ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR | ||||||
|  | ;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT | ||||||
|  | ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, | ||||||
|  | ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT | ||||||
|  | ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, | ||||||
|  | ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY | ||||||
|  | ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT | ||||||
|  | ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE | ||||||
|  | ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. | ||||||
							
								
								
									
										226
									
								
								src/utils.lisp
									
										
									
									
									
										Normal file
									
								
							
							
						
						
									
										226
									
								
								src/utils.lisp
									
										
									
									
									
										Normal file
									
								
							|  | @ -0,0 +1,226 @@ | ||||||
|  | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- | ||||||
|  | 
 | ||||||
|  | (in-package :it.bese.fiveam) | ||||||
|  | 
 | ||||||
|  | (defmacro dolist* ((iterator list &optional return-value) &body body) | ||||||
|  |   "Like DOLIST but destructuring-binds the elements of LIST. | ||||||
|  | 
 | ||||||
|  | If ITERATOR is a symbol then dolist* is just like dolist EXCEPT | ||||||
|  | that it creates a fresh binding." | ||||||
|  |   (if (listp iterator) | ||||||
|  |       (let ((i (gensym "DOLIST*-I-"))) | ||||||
|  |         `(dolist (,i ,list ,return-value) | ||||||
|  |            (destructuring-bind ,iterator ,i | ||||||
|  |              ,@body))) | ||||||
|  |       `(dolist (,iterator ,list ,return-value) | ||||||
|  |          (let ((,iterator ,iterator)) | ||||||
|  |            ,@body)))) | ||||||
|  | 
 | ||||||
|  | (defun make-collector (&optional initial-value) | ||||||
|  |   "Create a collector function. | ||||||
|  | 
 | ||||||
|  | A Collector function will collect, into a list, all the values | ||||||
|  | passed to it in the order in which they were passed. If the | ||||||
|  | callector function is called without arguments it returns the | ||||||
|  | current list of values." | ||||||
|  |   (let ((value initial-value) | ||||||
|  |         (cdr (last initial-value))) | ||||||
|  |     (lambda (&rest items) | ||||||
|  |       (if items | ||||||
|  |           (progn | ||||||
|  |             (if value | ||||||
|  |                 (if cdr | ||||||
|  |                     (setf (cdr cdr) items | ||||||
|  |                           cdr (last items)) | ||||||
|  |                     (setf cdr (last items))) | ||||||
|  |                 (setf value items | ||||||
|  |                       cdr (last items))) | ||||||
|  |             items) | ||||||
|  |           value)))) | ||||||
|  | 
 | ||||||
|  | (defun partitionx (list &rest lambdas) | ||||||
|  |   (let ((collectors (mapcar (lambda (l) | ||||||
|  |                               (cons (if (and (symbolp l) | ||||||
|  |                                              (member l (list :otherwise t) | ||||||
|  |                                                      :test #'string=)) | ||||||
|  |                                         (constantly t) | ||||||
|  |                                         l) | ||||||
|  |                                     (make-collector))) | ||||||
|  |                             lambdas))) | ||||||
|  |     (dolist (item list) | ||||||
|  |       (block item | ||||||
|  |         (dolist* ((test-func . collector-func) collectors) | ||||||
|  |           (when (funcall test-func item) | ||||||
|  |             (funcall collector-func item) | ||||||
|  |             (return-from item))))) | ||||||
|  |     (mapcar #'funcall (mapcar #'cdr collectors)))) | ||||||
|  | 
 | ||||||
|  | ;;;; ** Anaphoric conditionals | ||||||
|  | 
 | ||||||
|  | (defmacro if-bind (var test &body then/else) | ||||||
|  |   "Anaphoric IF control structure. | ||||||
|  | 
 | ||||||
|  | VAR (a symbol) will be bound to the primary value of TEST. If | ||||||
|  | TEST returns a true value then THEN will be executed, otherwise | ||||||
|  | ELSE will be executed." | ||||||
|  |   (assert (first then/else) | ||||||
|  |           (then/else) | ||||||
|  |           "IF-BIND missing THEN clause.") | ||||||
|  |   (destructuring-bind (then &optional else) | ||||||
|  |       then/else | ||||||
|  |     `(let ((,var ,test)) | ||||||
|  |        (if ,var ,then ,else)))) | ||||||
|  | 
 | ||||||
|  | (defmacro aif (test then &optional else) | ||||||
|  |   "Just like IF-BIND but the var is always IT." | ||||||
|  |   `(if-bind it ,test ,then ,else)) | ||||||
|  | 
 | ||||||
|  | ;;;; ** Simple list matching based on code from Paul Graham's On Lisp. | ||||||
|  | 
 | ||||||
|  | (defmacro acond2 (&rest clauses) | ||||||
|  |   (if (null clauses) | ||||||
|  |       nil | ||||||
|  |       (with-gensyms (val foundp) | ||||||
|  |         (destructuring-bind ((test &rest progn) &rest others) | ||||||
|  |             clauses | ||||||
|  |           `(multiple-value-bind (,val ,foundp) | ||||||
|  |                ,test | ||||||
|  |              (if (or ,val ,foundp) | ||||||
|  |                  (let ((it ,val)) | ||||||
|  |                    (declare (ignorable it)) | ||||||
|  |                    ,@progn) | ||||||
|  |                  (acond2 ,@others))))))) | ||||||
|  | 
 | ||||||
|  | (defun varsymp (x) | ||||||
|  |   (and (symbolp x) | ||||||
|  |        (let ((name (symbol-name x))) | ||||||
|  |          (and (>= (length name) 2) | ||||||
|  |               (char= (char name 0) #\?))))) | ||||||
|  | 
 | ||||||
|  | (defun binding (x binds) | ||||||
|  |   (labels ((recbind (x binds) | ||||||
|  |              (aif (assoc x binds) | ||||||
|  |                   (or (recbind (cdr it) binds) | ||||||
|  |                       it)))) | ||||||
|  |     (let ((b (recbind x binds))) | ||||||
|  |       (values (cdr b) b)))) | ||||||
|  | 
 | ||||||
|  | (defun list-match (x y &optional binds) | ||||||
|  |   (acond2 | ||||||
|  |     ((or (eql x y) (eql x '_) (eql y '_)) | ||||||
|  |      (values binds t)) | ||||||
|  |     ((binding x binds) (list-match it y binds)) | ||||||
|  |     ((binding y binds) (list-match x it binds)) | ||||||
|  |     ((varsymp x) (values (cons (cons x y) binds) t)) | ||||||
|  |     ((varsymp y) (values (cons (cons y x) binds) t)) | ||||||
|  |     ((and (consp x) (consp y) (list-match (car x) (car y) binds)) | ||||||
|  |      (list-match (cdr x) (cdr y) it)) | ||||||
|  |     (t (values nil nil)))) | ||||||
|  | 
 | ||||||
|  | (defun vars (match-spec) | ||||||
|  |   (let ((vars nil)) | ||||||
|  |     (labels ((find-vars (spec) | ||||||
|  |                (cond | ||||||
|  |                  ((null spec) nil) | ||||||
|  |                  ((varsymp spec) (push spec vars)) | ||||||
|  |                  ((consp spec) | ||||||
|  |                   (find-vars (car spec)) | ||||||
|  |                   (find-vars (cdr spec)))))) | ||||||
|  |       (find-vars match-spec)) | ||||||
|  |     (delete-duplicates vars))) | ||||||
|  | 
 | ||||||
|  | (defmacro list-match-case (target &body clauses) | ||||||
|  |   (if clauses | ||||||
|  |       (destructuring-bind ((test &rest progn) &rest others) | ||||||
|  |           clauses | ||||||
|  |         (with-gensyms (tgt binds success) | ||||||
|  |           `(let ((,tgt ,target)) | ||||||
|  |              (multiple-value-bind (,binds ,success) | ||||||
|  |                  (list-match ,tgt ',test) | ||||||
|  |                (declare (ignorable ,binds)) | ||||||
|  |                (if ,success | ||||||
|  |                    (let ,(mapcar (lambda (var) | ||||||
|  |                                    `(,var (cdr (assoc ',var ,binds)))) | ||||||
|  |                                  (vars test)) | ||||||
|  |                      (declare (ignorable ,@(vars test))) | ||||||
|  |                      ,@progn) | ||||||
|  |                    (list-match-case ,tgt ,@others)))))) | ||||||
|  |       nil)) | ||||||
|  | 
 | ||||||
|  | ;;;; * def-special-environment | ||||||
|  | 
 | ||||||
|  | (defun check-required (name vars required) | ||||||
|  |   (dolist (var required) | ||||||
|  |     (assert (member var vars) | ||||||
|  |             (var) | ||||||
|  |             "Unrecognized symbol ~S in ~S." var name))) | ||||||
|  | 
 | ||||||
|  | (defmacro def-special-environment (name (&key accessor binder binder*) | ||||||
|  |                                   &rest vars) | ||||||
|  |   "Define two macros for dealing with groups or related special variables. | ||||||
|  | 
 | ||||||
|  | ACCESSOR is defined as a macro: (defmacro ACCESSOR (VARS &rest | ||||||
|  | BODY)).  Each element of VARS will be bound to the | ||||||
|  | current (dynamic) value of the special variable. | ||||||
|  | 
 | ||||||
|  | BINDER is defined as a macro for introducing (and binding new) | ||||||
|  | special variables. It is basically a readable LET form with the | ||||||
|  | prorpe declarations appended to the body. The first argument to | ||||||
|  | BINDER must be a form suitable as the first argument to LET. | ||||||
|  | 
 | ||||||
|  | ACCESSOR defaults to a new symbol in the same package as NAME | ||||||
|  | which is the concatenation of \"WITH-\" NAME. BINDER is built as | ||||||
|  | \"BIND-\" and BINDER* is BINDER \"*\"." | ||||||
|  |   (unless accessor | ||||||
|  |     (setf accessor (format-symbol (symbol-package name) "~A-~A" '#:with name))) | ||||||
|  |   (unless binder | ||||||
|  |     (setf binder   (format-symbol (symbol-package name) "~A-~A" '#:bind name))) | ||||||
|  |   (unless binder* | ||||||
|  |     (setf binder*  (format-symbol (symbol-package binder) "~A~A" binder '#:*))) | ||||||
|  |   `(eval-when (:compile-toplevel :load-toplevel :execute) | ||||||
|  |      (flet () | ||||||
|  |        (defmacro ,binder (requested-vars &body body) | ||||||
|  |          (check-required ',name ',vars (mapcar #'car requested-vars)) | ||||||
|  |          `(let ,requested-vars | ||||||
|  |             (declare (special ,@(mapcar #'car requested-vars))) | ||||||
|  |             ,@body)) | ||||||
|  |        (defmacro ,binder* (requested-vars &body body) | ||||||
|  |          (check-required ',name ',vars (mapcar #'car requested-vars)) | ||||||
|  |          `(let* ,requested-vars | ||||||
|  |             (declare (special ,@(mapcar #'car requested-vars))) | ||||||
|  |             ,@body)) | ||||||
|  |        (defmacro ,accessor (requested-vars &body body) | ||||||
|  |          (check-required ',name ',vars requested-vars) | ||||||
|  |          `(locally (declare (special ,@requested-vars)) | ||||||
|  |             ,@body)) | ||||||
|  |        ',name))) | ||||||
|  | 
 | ||||||
|  | ;; Copyright (c) 2002-2006, Edward Marco Baringer | ||||||
|  | ;; All rights reserved. | ||||||
|  | ;; | ||||||
|  | ;; Redistribution and use in source and binary forms, with or without | ||||||
|  | ;; modification, are permitted provided that the following conditions are | ||||||
|  | ;; met: | ||||||
|  | ;; | ||||||
|  | ;;  - Redistributions of source code must retain the above copyright | ||||||
|  | ;;    notice, this list of conditions and the following disclaimer. | ||||||
|  | ;; | ||||||
|  | ;;  - Redistributions in binary form must reproduce the above copyright | ||||||
|  | ;;    notice, this list of conditions and the following disclaimer in the | ||||||
|  | ;;    documentation and/or other materials provided with the distribution. | ||||||
|  | ;; | ||||||
|  | ;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names | ||||||
|  | ;;    of its contributors may be used to endorse or promote products | ||||||
|  | ;;    derived from this software without specific prior written permission. | ||||||
|  | ;; | ||||||
|  | ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS | ||||||
|  | ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT | ||||||
|  | ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR | ||||||
|  | ;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT | ||||||
|  | ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, | ||||||
|  | ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT | ||||||
|  | ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, | ||||||
|  | ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY | ||||||
|  | ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT | ||||||
|  | ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE | ||||||
|  | ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE | ||||||
							
								
								
									
										126
									
								
								t/example.lisp
									
										
									
									
									
										Normal file
									
								
							
							
						
						
									
										126
									
								
								t/example.lisp
									
										
									
									
									
										Normal file
									
								
							|  | @ -0,0 +1,126 @@ | ||||||
|  | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- | ||||||
|  | 
 | ||||||
|  | ;;;; * FiveAM Example (poor man's tutorial) | ||||||
|  | 
 | ||||||
|  | (asdf:oos 'asdf:load-op :fiveam) | ||||||
|  | 
 | ||||||
|  | (defpackage :it.bese.fiveam.example | ||||||
|  |   (:use :common-lisp | ||||||
|  | 	:it.bese.fiveam)) | ||||||
|  | 
 | ||||||
|  | (in-package :it.bese.fiveam.example) | ||||||
|  | 
 | ||||||
|  | ;;;; First we need some functions to test. | ||||||
|  | 
 | ||||||
|  | (defun add-2 (n) | ||||||
|  |   (+ n 2)) | ||||||
|  | 
 | ||||||
|  | (defun add-4 (n)  | ||||||
|  |   (+ n 4)) | ||||||
|  | 
 | ||||||
|  | ;;;; Now we need to create a test which makes sure that add-2 and add-4 | ||||||
|  | ;;;; work as specified. | ||||||
|  | 
 | ||||||
|  | ;;;; we create a test named ADD-2 and supply a short description. | ||||||
|  | (test add-2 | ||||||
|  |  "Test the ADD-2 function" ;; a short description | ||||||
|  |  ;; the checks | ||||||
|  |  (is (= 2 (add-2 0))) | ||||||
|  |  (is (= 0 (add-2 -2)))) | ||||||
|  | 
 | ||||||
|  | ;;;; we can already run add-2. This will return the list of test | ||||||
|  | ;;;; results, it should be a list of two test-passed objects. | ||||||
|  | 
 | ||||||
|  | (run 'add-2)  | ||||||
|  | 
 | ||||||
|  | ;;;; since we'd like to have some kind of readbale output we'll explain | ||||||
|  | ;;;; the results | ||||||
|  | 
 | ||||||
|  | (explain! (run 'add-2)) | ||||||
|  | 
 | ||||||
|  | ;;;; or we could do both at once: | ||||||
|  | 
 | ||||||
|  | (run! 'add-2) | ||||||
|  | 
 | ||||||
|  | ;;;; So now we've defined and run a single test. Since we plan on | ||||||
|  | ;;;; having more than one test and we'd like to run them together let's | ||||||
|  | ;;;; create a simple test suite. | ||||||
|  | 
 | ||||||
|  | (def-suite example-suite :description "The example test suite.") | ||||||
|  | 
 | ||||||
|  | ;;;; we could explictly specify that every test we create is in the the | ||||||
|  | ;;;; example-suite suite, but it's easier to just change the default | ||||||
|  | ;;;; suite: | ||||||
|  | 
 | ||||||
|  | (in-suite example-suite) | ||||||
|  | 
 | ||||||
|  | ;;;; now we'll create a new test for the add-4 function. | ||||||
|  | 
 | ||||||
|  | (test add-4 | ||||||
|  |   (is (= 0 (add-4 -4)))) | ||||||
|  | 
 | ||||||
|  | ;;;; now let's run the test | ||||||
|  | 
 | ||||||
|  | (run! 'add-4) | ||||||
|  | 
 | ||||||
|  | ;;;; we can get the same effect by running the suite: | ||||||
|  | 
 | ||||||
|  | (run! 'example-suite) | ||||||
|  | 
 | ||||||
|  | ;;;; since we'd like both add-2 and add-4 to be in the same suite, let's | ||||||
|  | ;;;; redefine add-2 to be in this suite: | ||||||
|  | 
 | ||||||
|  | (test add-2 "Test the ADD-2 function" | ||||||
|  |  (is (= 2 (add-2 0))) | ||||||
|  |  (is (= 0 (add-2 -2)))) | ||||||
|  | 
 | ||||||
|  | ;;;; now we can run the suite and we'll see that both add-2 and add-4 | ||||||
|  | ;;;; have been run (we know this since we no get 4 checks as opposed to | ||||||
|  | ;;;; 2 as before. | ||||||
|  | 
 | ||||||
|  | (run! 'example-suite) | ||||||
|  | 
 | ||||||
|  | ;;;; Just for fun let's see what happens when a test fails. Again we'll | ||||||
|  | ;;;; redefine add-2, but add in a third, failing, check: | ||||||
|  | 
 | ||||||
|  | (test add-2 "Test the ADD-2 function" | ||||||
|  |  (is (= 2 (add-2 0))) | ||||||
|  |  (is (= 0 (add-2 -2))) | ||||||
|  |  (is (= 0 (add-2 0)))) | ||||||
|  | 
 | ||||||
|  | ;;;; Finally let's try out the specification based testing. | ||||||
|  | 
 | ||||||
|  | (defun dummy-add (a b) | ||||||
|  |   (+ a b)) | ||||||
|  | 
 | ||||||
|  | (defun dummy-strcat (a b) | ||||||
|  |   (concatenate 'string a b)) | ||||||
|  | 
 | ||||||
|  | (test dummy-add | ||||||
|  |   (for-all ((a (gen-integer)) | ||||||
|  |             (b (gen-integer))) | ||||||
|  |     ;; assuming we have an "oracle" to compare our function results to | ||||||
|  |     ;; we can use it: | ||||||
|  |     (is (= (+ a b) (dummy-add a b))) | ||||||
|  |     ;; if we don't have an oracle (as in most cases) we just ensure | ||||||
|  |     ;; that certain properties hold: | ||||||
|  |     (is (= (dummy-add a b) | ||||||
|  |            (dummy-add b a))) | ||||||
|  |     (is (= a (dummy-add a 0))) | ||||||
|  |     (is (= 0 (dummy-add a (- a)))) | ||||||
|  |     (is (< a (dummy-add a 1))) | ||||||
|  |     (is (= (* 2 a) (dummy-add a a))))) | ||||||
|  | 
 | ||||||
|  | (test dummy-strcat | ||||||
|  |   (for-all ((result (gen-string)) | ||||||
|  |             (split-point (gen-integer :min 0 :max 10000) | ||||||
|  |                          (< split-point (length result)))) | ||||||
|  |     (is (string= result (dummy-strcat (subseq result 0 split-point) | ||||||
|  |                                       (subseq result split-point)))))) | ||||||
|  | 
 | ||||||
|  | (test random-failure | ||||||
|  |   (for-all ((result (gen-integer :min 0 :max 1))) | ||||||
|  |     (is (plusp result)) | ||||||
|  |     (is (= result 0)))) | ||||||
|  | 
 | ||||||
|  | (run! 'example-suite) | ||||||
							
								
								
									
										280
									
								
								t/tests.lisp
									
										
									
									
									
										Normal file
									
								
							
							
						
						
									
										280
									
								
								t/tests.lisp
									
										
									
									
									
										Normal file
									
								
							|  | @ -0,0 +1,280 @@ | ||||||
|  | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- | ||||||
|  | 
 | ||||||
|  | (in-package :it.bese.fiveam) | ||||||
|  | 
 | ||||||
|  | (in-suite* :it.bese.fiveam) | ||||||
|  | 
 | ||||||
|  | (def-suite test-suite :description "Suite for tests which should fail.") | ||||||
|  | 
 | ||||||
|  | (defmacro with-test-results ((results test-name) &body body) | ||||||
|  |   `(let ((,results (with-*test-dribble* nil (run ',test-name)))) | ||||||
|  |      ,@body)) | ||||||
|  | 
 | ||||||
|  | (def-fixture null-fixture () | ||||||
|  |   `(progn ,@(&body))) | ||||||
|  | 
 | ||||||
|  | ;;;; Test the checks | ||||||
|  | 
 | ||||||
|  | (def-test is1 (:suite test-suite) | ||||||
|  |   (is (plusp 1)) | ||||||
|  |   (is (< 0 1)) | ||||||
|  |   (is (not (plusp -1))) | ||||||
|  |   (is (not (< 1 0))) | ||||||
|  |   (is-true t) | ||||||
|  |   (is-false nil)) | ||||||
|  | 
 | ||||||
|  | (def-test is2 (:suite test-suite :fixture null-fixture) | ||||||
|  |   (is (plusp 0)) | ||||||
|  |   (is (< 0 -1)) | ||||||
|  |   (is (not (plusp 1))) | ||||||
|  |   (is (not (< 0 1))) | ||||||
|  |   (is-true nil) | ||||||
|  |   (is-false t)) | ||||||
|  | 
 | ||||||
|  | (def-test is (:profile t) | ||||||
|  |   (with-test-results (results is1) | ||||||
|  |     (is (= 6 (length results))) | ||||||
|  |     (is (every #'test-passed-p results))) | ||||||
|  |   (with-test-results (results is2) | ||||||
|  |     (is (= 6 (length results))) | ||||||
|  |     (is (every #'test-failure-p results)))) | ||||||
|  | 
 | ||||||
|  | (def-test signals/finishes () | ||||||
|  |   (signals error | ||||||
|  |     (error "an error")) | ||||||
|  |   (finishes | ||||||
|  |    (signals error | ||||||
|  |     (error "an error")))) | ||||||
|  | 
 | ||||||
|  | (def-test pass () | ||||||
|  |   (pass)) | ||||||
|  | 
 | ||||||
|  | (def-test fail1 (:suite test-suite) | ||||||
|  |   (fail "This is supposed to fail")) | ||||||
|  | 
 | ||||||
|  | (def-test fail () | ||||||
|  |   (with-test-results (results fail1) | ||||||
|  |     (is (= 1 (length results))) | ||||||
|  |     (is (test-failure-p (first results))))) | ||||||
|  | 
 | ||||||
|  | ;;;; non top level checks | ||||||
|  | 
 | ||||||
|  | (def-test foo-bar () | ||||||
|  |   (let ((state 0)) | ||||||
|  |     (is (= 0 state)) | ||||||
|  |     (is (= 1 (incf state))))) | ||||||
|  | 
 | ||||||
|  | ;;;; Test dependencies | ||||||
|  | 
 | ||||||
|  | (def-test ok (:suite test-suite) | ||||||
|  |   (pass)) | ||||||
|  | 
 | ||||||
|  | (def-test not-ok (:suite test-suite) | ||||||
|  |   (fail "This is supposed to fail.")) | ||||||
|  | 
 | ||||||
|  | (def-test and1 (:depends-on (and ok not-ok) :suite test-suite) | ||||||
|  |   (fail)) | ||||||
|  | 
 | ||||||
|  | (def-test and2 (:depends-on (and ok) :suite test-suite) | ||||||
|  |   (pass)) | ||||||
|  | 
 | ||||||
|  | (def-test dep-and () | ||||||
|  |   (with-test-results (results and1) | ||||||
|  |     (is (= 3 (length results))) | ||||||
|  |     ;; we should have one skippedw one failed and one passed | ||||||
|  |     (is (some #'test-passed-p results)) | ||||||
|  |     (is (some #'test-skipped-p results)) | ||||||
|  |     (is (some #'test-failure-p results))) | ||||||
|  |   (with-test-results (results and2) | ||||||
|  |     (is (= 2 (length results))) | ||||||
|  |     (is (every #'test-passed-p results)))) | ||||||
|  | 
 | ||||||
|  | (def-test or1 (:depends-on (or ok not-ok) :suite test-suite) | ||||||
|  |   (pass)) | ||||||
|  | 
 | ||||||
|  | (def-test or2 (:depends-on (or not-ok ok) :suite test-suite) | ||||||
|  |   (pass)) | ||||||
|  | 
 | ||||||
|  | (def-test dep-or () | ||||||
|  |   (with-test-results (results or1) | ||||||
|  |     (is (= 2 (length results))) | ||||||
|  |     (is (every #'test-passed-p results))) | ||||||
|  |   (with-test-results (results or2) | ||||||
|  |     (is (= 3 (length results))) | ||||||
|  |     (is (= 2 (length (remove-if-not #'test-passed-p results)))))) | ||||||
|  | 
 | ||||||
|  | (def-test not1 (:depends-on (not not-ok) :suite test-suite) | ||||||
|  |   (pass)) | ||||||
|  | 
 | ||||||
|  | (def-test not2 (:depends-on (not ok) :suite test-suite) | ||||||
|  |   (fail)) | ||||||
|  | 
 | ||||||
|  | (def-test not () | ||||||
|  |   (with-test-results (results not1) | ||||||
|  |     (is (= 2 (length results))) | ||||||
|  |     (is (some #'test-passed-p results)) | ||||||
|  |     (is (some #'test-failure-p results))) | ||||||
|  |   (with-test-results (results not2) | ||||||
|  |     (is (= 2 (length results))) | ||||||
|  |     (is (some #'test-passed-p results)) | ||||||
|  |     (is (some #'test-skipped-p results)))) | ||||||
|  | 
 | ||||||
|  | (def-test nested-logic (:depends-on (and ok (not not-ok) (not not-ok)) | ||||||
|  |                         :suite test-suite) | ||||||
|  |   (pass)) | ||||||
|  | 
 | ||||||
|  | (def-test dep-nested () | ||||||
|  |   (with-test-results (results nested-logic) | ||||||
|  |     (is (= 3 (length results))) | ||||||
|  |     (is (= 2 (length (remove-if-not #'test-passed-p results)))) | ||||||
|  |     (is (= 1 (length (remove-if-not #'test-failure-p results)))))) | ||||||
|  | 
 | ||||||
|  | (def-test circular-0 (:depends-on (and circular-1 circular-2 or1)  | ||||||
|  |                       :suite test-suite) | ||||||
|  |   (fail "we depend on a circular dependency, we should not be tested.")) | ||||||
|  | 
 | ||||||
|  | (def-test circular-1 (:depends-on (and circular-2) | ||||||
|  |                       :suite test-suite) | ||||||
|  |   (fail "we have a circular depednency, we should not be tested.")) | ||||||
|  | 
 | ||||||
|  | (def-test circular-2 (:depends-on (and circular-1) | ||||||
|  |                       :suite test-suite) | ||||||
|  |   (fail "we have a circular depednency, we should not be tested.")) | ||||||
|  | 
 | ||||||
|  | (def-test circular () | ||||||
|  |   (signals circular-dependency | ||||||
|  |     (run 'circular-0)) | ||||||
|  |   (signals circular-dependency | ||||||
|  |     (run 'circular-1)) | ||||||
|  |   (signals circular-dependency | ||||||
|  |     (run 'circular-2))) | ||||||
|  | 
 | ||||||
|  | 
 | ||||||
|  | (defun stack-exhaust () | ||||||
|  |   (declare (optimize (debug 3) (speed 0) (space 0) (safety 3))) | ||||||
|  |   (cons 42 (stack-exhaust))) | ||||||
|  | 
 | ||||||
|  | ;; Disable until we determine on which implementations it's actually safe | ||||||
|  | ;; to exhaust the stack. | ||||||
|  | #| | ||||||
|  | (def-test stack-exhaust (:suite test-suite) | ||||||
|  |   (stack-exhaust)) | ||||||
|  | 
 | ||||||
|  | (def-test test-stack-exhaust () | ||||||
|  |   (with-test-results (results stack-exhaust) | ||||||
|  |     (is (= 1 (length results))) | ||||||
|  |     (is (test-failure-p (first results))))) | ||||||
|  | |# | ||||||
|  | 
 | ||||||
|  | (def-suite before-test-suite :description "Suite for before test") | ||||||
|  | 
 | ||||||
|  | (def-test before-0 (:suite before-test-suite) | ||||||
|  |   (fail)) | ||||||
|  | 
 | ||||||
|  | (def-test before-1 (:depends-on (:before before-0) | ||||||
|  |                     :suite before-test-suite) | ||||||
|  |   (pass)) | ||||||
|  | 
 | ||||||
|  | (def-suite before-test-suite-2 :description "Suite for before test") | ||||||
|  | 
 | ||||||
|  | (def-test before-2 (:depends-on (:before before-3) | ||||||
|  |                     :suite before-test-suite-2) | ||||||
|  |   (pass)) | ||||||
|  | 
 | ||||||
|  | (def-test before-3 (:suite before-test-suite-2) | ||||||
|  |   (pass)) | ||||||
|  | 
 | ||||||
|  | (def-test before () | ||||||
|  |   (with-test-results (results before-test-suite) | ||||||
|  |     (is (some #'test-skipped-p results))) | ||||||
|  |    | ||||||
|  |   (with-test-results (results before-test-suite-2) | ||||||
|  |     (is (every #'test-passed-p results)))) | ||||||
|  | 
 | ||||||
|  | 
 | ||||||
|  | ;;;; dependencies with symbol | ||||||
|  | (def-test dep-with-symbol-first (:suite test-suite) | ||||||
|  |   (pass)) | ||||||
|  | 
 | ||||||
|  | (def-test dep-with-symbol-dependencies-not-met (:depends-on (not dep-with-symbol-first) | ||||||
|  |                                                 :suite test-suite) | ||||||
|  |   (fail "Error in the test of the test, this should not ever happen")) | ||||||
|  | 
 | ||||||
|  | (def-test dep-with-symbol-depends-on-ok (:depends-on dep-with-symbol-first :suite test-suite) | ||||||
|  |   (pass)) | ||||||
|  | 
 | ||||||
|  | (def-test dep-with-symbol-depends-on-failed-dependency (:depends-on dep-with-symbol-dependencies-not-met | ||||||
|  |                                                         :suite test-suite) | ||||||
|  |   (fail "No, I should not be tested because I depend on a test that in its turn has a failed dependecy.")) | ||||||
|  | 
 | ||||||
|  | (def-test dependencies-with-symbol () | ||||||
|  |   (with-test-results (results dep-with-symbol-first) | ||||||
|  |     (is (some #'test-passed-p results))) | ||||||
|  | 
 | ||||||
|  |   (with-test-results (results dep-with-symbol-depends-on-ok) | ||||||
|  |     (is (some #'test-passed-p results))) | ||||||
|  | 
 | ||||||
|  |   (with-test-results (results dep-with-symbol-dependencies-not-met) | ||||||
|  |     (is (some #'test-skipped-p results))) | ||||||
|  | 
 | ||||||
|  |   ;; No failure here, because it means the test was run. | ||||||
|  |   (with-test-results (results dep-with-symbol-depends-on-failed-dependency) | ||||||
|  |     (is (not (some #'test-failure-p results))))) | ||||||
|  | 
 | ||||||
|  | 
 | ||||||
|  | ;;;; test for-all | ||||||
|  | 
 | ||||||
|  | (def-test gen-integer () | ||||||
|  |   (for-all ((a (gen-integer))) | ||||||
|  |     (is (integerp a)))) | ||||||
|  | 
 | ||||||
|  | (def-test for-all-guarded () | ||||||
|  |   (for-all ((less (gen-integer)) | ||||||
|  |             (more (gen-integer) (< less more))) | ||||||
|  |     (is (< less more)))) | ||||||
|  | 
 | ||||||
|  | (def-test gen-float () | ||||||
|  |   (macrolet ((test-gen-float (type) | ||||||
|  |                `(for-all ((unbounded (gen-float :type ',type)) | ||||||
|  |                           (bounded   (gen-float :type ',type :bound 42))) | ||||||
|  |                   (is (typep unbounded ',type)) | ||||||
|  |                   (is (typep bounded ',type)) | ||||||
|  |                   (is (<= (abs bounded) 42))))) | ||||||
|  |     (test-gen-float single-float) | ||||||
|  |     (test-gen-float short-float) | ||||||
|  |     (test-gen-float double-float) | ||||||
|  |     (test-gen-float long-float))) | ||||||
|  | 
 | ||||||
|  | (def-test gen-character () | ||||||
|  |   (for-all ((c (gen-character))) | ||||||
|  |     (is (characterp c))) | ||||||
|  |   (for-all ((c (gen-character :code (gen-integer :min 32 :max 40)))) | ||||||
|  |     (is (characterp c)) | ||||||
|  |     (member c (list #\Space #\! #\" #\# #\$ #\% #\& #\' #\()))) | ||||||
|  | 
 | ||||||
|  | (def-test gen-string () | ||||||
|  |   (for-all ((s (gen-string))) | ||||||
|  |     (is (stringp s))) | ||||||
|  |   (for-all ((s (gen-string :length (gen-integer :min 0 :max 2)))) | ||||||
|  |     (is (<= (length s) 2))) | ||||||
|  |   (for-all ((s (gen-string :elements (gen-character :code (gen-integer :min 0 :max 0)) | ||||||
|  |                            :length (constantly 2)))) | ||||||
|  |     (is (= 2 (length s))) | ||||||
|  |     (is (every (curry #'char= #\Null) s)))) | ||||||
|  | 
 | ||||||
|  | (defun dummy-mv-generator () | ||||||
|  |   (lambda () | ||||||
|  |     (list 1 1))) | ||||||
|  | 
 | ||||||
|  | (def-test for-all-destructuring-bind () | ||||||
|  |   (for-all (((a b) (dummy-mv-generator))) | ||||||
|  |     (is (= 1 a)) | ||||||
|  |     (is (= 1 b)))) | ||||||
|  | 
 | ||||||
|  | (def-test return-values () | ||||||
|  |   "Return values indicate test failures." | ||||||
|  |   (is-true (with-*test-dribble* nil (explain! (run 'is1)))) | ||||||
|  |   (is-true (with-*test-dribble* nil (run! 'is1))) | ||||||
|  | 
 | ||||||
|  |   (is-false (with-*test-dribble* nil (explain! (run 'is2)))) | ||||||
|  |   (is-false (with-*test-dribble* nil (run! 'is2)))) | ||||||
							
								
								
									
										2
									
								
								version.sexp
									
										
									
									
									
										Normal file
									
								
							
							
						
						
									
										2
									
								
								version.sexp
									
										
									
									
									
										Normal file
									
								
							|  | @ -0,0 +1,2 @@ | ||||||
|  | ;; -*- lisp -*- | ||||||
|  | "1.4.1" | ||||||
		Loading…
	
	Add table
		Add a link
		
	
		Reference in a new issue