From 1b24abf09e9fbb2a23c25a9583e5547514482f1b Mon Sep 17 00:00:00 2001 From: Stelian Ionescu Date: Sat, 21 Apr 2012 16:38:26 +0200 Subject: [PATCH] Fix indentation, whitespace --- fiveam.asd | 2 +- src/check.lisp | 70 ++++++++++++++++----------------- src/classes.lisp | 24 ++++++------ src/explain.lisp | 68 ++++++++++++++++---------------- src/fixture.lisp | 10 ++--- src/packages.lisp | 113 +++++++++++++++++++++++++++-------------------------- src/random.lisp | 4 +- src/run.lisp | 56 +++++++++++++------------- src/suite.lisp | 40 +++++++++---------- src/test.lisp | 43 ++++++++++---------- 10 files changed, 215 insertions(+), 215 deletions(-) diff --git a/fiveam.asd b/fiveam.asd index 372609d..ee2792c 100644 --- a/fiveam.asd +++ b/fiveam.asd @@ -1,4 +1,4 @@ -;; -*- lisp -*- +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- (defpackage :it.bese.FiveAM.system (:use :common-lisp diff --git a/src/check.lisp b/src/check.lisp index cdf57fd..8325bde 100644 --- a/src/check.lisp +++ b/src/check.lisp @@ -29,7 +29,7 @@ ;;;; ** Types of test results -;;;; Every check produces a result object. +;;;; Every check produces a result object. (defclass test-result () ((reason :accessor reason :initarg :reason :initform "no reason given") @@ -58,9 +58,9 @@ (defmacro process-failure (&rest args) `(progn - (with-simple-restart (ignore-failure "Continue the test run.") - (error 'check-failure ,@args)) - (add-result 'test-failure ,@args))) + (with-simple-restart (ignore-failure "Continue the test run.") + (error 'check-failure ,@args)) + (add-result 'test-failure ,@args))) (defclass test-failure (test-result) () @@ -97,10 +97,10 @@ when appropiate.")) (let ((result (apply #'make-instance result-type (append make-instance-args (list :test-case current-test))))) (etypecase result - (test-passed (format *test-dribble* ".")) + (test-passed (format *test-dribble* ".")) (unexpected-test-failure (format *test-dribble* "X")) - (test-failure (format *test-dribble* "f")) - (test-skipped (format *test-dribble* "s"))) + (test-failure (format *test-dribble* "f")) + (test-skipped (format *test-dribble* "s"))) (push result result-list)))) ;;;; ** The check operators @@ -154,10 +154,10 @@ REASON-ARGS is provided, is generated based on the form of TEST: (setf bindings (list (list e expected) (list a actual)))) (setf effective-test `(progn - ,@setf-forms - ,(if negatedp - `(not (,predicate ,e ,a)) - `(,predicate ,e ,a))))))) + ,@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) @@ -203,13 +203,13 @@ REASON-ARGS is provided, is generated based on the form of TEST: "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))))))) + ,@(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 @@ -217,12 +217,12 @@ REASON-ARGS is provided, is generated based on the form of TEST: does not inspect CONDITION to determine how to report the failure." `(if ,condition - (add-result 'test-passed :test-expr ',condition) - (process-failure - :reason ,(if reason-args - `(format nil ,@reason-args) - `(format nil "~S did not return a true value" ',condition)) - :test-expr ',condition))) + (add-result 'test-passed :test-expr ',condition) + (process-failure + :reason ,(if reason-args + `(format nil ,@reason-args) + `(format nil "~S did not return a true value" ',condition)) + :test-expr ',condition))) (defmacro is-false (condition &rest reason-args) "Generates a pass if CONDITION returns false, generates a @@ -252,7 +252,7 @@ not evaluated." (handler-bind ((,condition (lambda (c) (declare (ignore c)) ;; ok, body threw condition - (add-result 'test-passed + (add-result 'test-passed :test-expr ',condition) (return-from ,block-name t)))) (block nil @@ -270,18 +270,18 @@ other words if body does signal, return-from or throw this test fails." `(let ((ok nil)) (unwind-protect - (progn - ,@body - (setf ok t)) + (progn + ,@body + (setf ok t)) (if ok - (add-result 'test-passed :test-expr ',body) + (add-result 'test-passed :test-expr ',body) (process-failure :reason (format nil "Test didn't finish") :test-expr ',body))))) (defmacro pass (&rest message-args) "Simply generate a PASS." - `(add-result 'test-passed + `(add-result 'test-passed :test-expr ',message-args ,@(when message-args `(:reason (format nil ,@message-args))))) @@ -294,15 +294,15 @@ fails." `(:reason (format nil ,@message-args))))) ;; Copyright (c) 2002-2003, Edward Marco Baringer -;; All rights reserved. -;; +;; 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. @@ -310,7 +310,7 @@ fails." ;; - 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 diff --git a/src/classes.lisp b/src/classes.lisp index a0e8659..5459580 100644 --- a/src/classes.lisp +++ b/src/classes.lisp @@ -3,14 +3,14 @@ (in-package :it.bese.FiveAM) (defclass testable-object () - ((name :initarg :name :accessor name - :documentation "A symbol naming this test 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.") + :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.") + :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 + :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 @@ -34,7 +34,7 @@ (defclass test-suite (testable-object) ((tests :accessor tests :initform (make-hash-table :test 'eql) - :documentation "The hash table mapping names to test + :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. @@ -52,7 +52,7 @@ suite) in the suite.")) (defclass test-case (testable-object) ((test-lambda :initarg :test-lambda :accessor test-lambda - :documentation "The function to run.") + :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 @@ -98,15 +98,15 @@ test-skipped result is added to the results.")) ()) ;; Copyright (c) 2002-2003, Edward Marco Baringer -;; All rights reserved. -;; +;; 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. @@ -114,7 +114,7 @@ test-skipped result is added to the results.")) ;; - 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 diff --git a/src/explain.lisp b/src/explain.lisp index 84d6871..7218733 100644 --- a/src/explain.lisp +++ b/src/explain.lisp @@ -15,17 +15,17 @@ (defmethod explain ((exp detailed-text-explainer) results &optional (stream *test-dribble*) (recursive-depth 0)) #| "Given a list of test results report write to stream detailed - human readable statistics regarding the results." |# + human readable statistics regarding the results." |# (multiple-value-bind (num-checks passed num-passed passed% - skipped num-skipped skipped% - failed num-failed failed% - unknown num-unknown unknown%) + 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)) @@ -40,7 +40,7 @@ (output "Failure Details:~%") (dolist (f (reverse failed)) (output "--------------------------------~%") - (output "~A ~@{[~A]~}: ~%" + (output "~A ~@{[~A]~}: ~%" (name (test-case f)) (description (test-case f))) (output " ~A.~%" (reason f)) @@ -55,7 +55,7 @@ (when skipped (output "Skip Details:~%") (dolist (f skipped) - (output "~A ~@{[~A]~}: ~%" + (output "~A ~@{[~A]~}: ~%" (name (test-case f)) (description (test-case f))) (output " ~A.~%" (reason f))) @@ -64,9 +64,9 @@ (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%) + 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) @@ -79,37 +79,37 @@ (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) + (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)))))))) + (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. -;; +;; 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. @@ -117,7 +117,7 @@ ;; - 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 diff --git a/src/fixture.lisp b/src/fixture.lisp index d5ff664..a3de037 100644 --- a/src/fixture.lisp +++ b/src/fixture.lisp @@ -41,15 +41,15 @@ See Also: DEF-FIXTURE" (funcall (lambda ,largs ,@lbody) ,@args)))) ;; Copyright (c) 2002-2003, Edward Marco Baringer -;; All rights reserved. -;; +;; 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. @@ -57,7 +57,7 @@ See Also: DEF-FIXTURE" ;; - 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 diff --git a/src/packages.lisp b/src/packages.lisp index 0267a03..7e091e8 100644 --- a/src/packages.lisp +++ b/src/packages.lisp @@ -20,57 +20,58 @@ (defpackage :it.bese.FiveAM (:use :common-lisp :it.bese.arnesi) (:nicknames :5am :fiveam) - (:export ;; creating tests and test-suites - #:make-suite - #:def-suite - #:in-suite - #:in-suite* - #:make-test - #:test - #:get-test - #:rem-test - #:test-names - ;; fixtures - #:make-fixture - #: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 - #: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* - #:*verbose-failures* - #:results-status)) + (:export + ;; creating tests and test-suites + #:make-suite + #:def-suite + #:in-suite + #:in-suite* + #:make-test + #:test + #:get-test + #:rem-test + #:test-names + ;; fixtures + #:make-fixture + #: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 + #: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* + #:*verbose-failures* + #: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 @@ -100,15 +101,15 @@ ;;;; ** COPYRIGHT ;;;; Copyright (c) 2002-2003, Edward Marco Baringer -;;;; All rights reserved. - +;;;; 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. @@ -116,7 +117,7 @@ ;;;; - 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 diff --git a/src/random.lisp b/src/random.lisp index f46d3ba..615e9ea 100644 --- a/src/random.lisp +++ b/src/random.lisp @@ -77,7 +77,7 @@ Examples: (throw 'run-once (list :guard-conditions-failed)))))))) -;;;; *** Implementation +;;;; *** Implementation ;;;; We could just make FOR-ALL a monster macro, but having FOR-ALL be ;;;; a preproccessor for the perform-random-testing function is @@ -183,7 +183,7 @@ BOUND)." (double-float most-positive-double-float) (long-float most-positive-long-float))) (bound (or bound (max most-positive (- most-negative))))) - (coerce + (coerce (ecase (random 2) (0 ;; generate a positive number (random (min most-positive bound))) diff --git a/src/run.lisp b/src/run.lisp index 579db2f..0ebc771 100644 --- a/src/run.lisp +++ b/src/run.lisp @@ -41,7 +41,7 @@ (defun import-testing-symbols (package-designator) (import '(5am::is 5am::is-true 5am::is-false 5am::signals 5am::finishes) - package-designator)) + package-designator)) (defparameter *run-queue* '() "List of test waiting to be run.") @@ -76,17 +76,17 @@ run.")) :test-case test :reason "Dependencies not satisfied") result-list) - (setf (status test) :depends-not-satisfied))))) + (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)))) + :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)))) (defmethod resolve-dependencies ((depends-on symbol)) @@ -100,31 +100,31 @@ run.")) (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)) + (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)))) (eql :unknown status))) - (cdr depends-on))))))) + (cdr depends-on))))))) (defun results-status (result-list) "Given a list of test results (generated while running a test) return true if all of the results are of type TEST-PASSED, faile otherwise." (every (lambda (res) - (typep res 'test-passed)) - result-list)) + (typep res 'test-passed)) + result-list)) (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 '())) + (bind-run-state ((result-list '())) (funcall test-lambda) result-list)) @@ -173,7 +173,7 @@ run.")) (defgeneric %run (test-spec) (:documentation "Internal method for running a test. Does not - update the status of the tests nor the special vairables !, + update the status of the tests nor the special variables !, !!, !!!")) (defmethod %run ((test test-case)) @@ -245,28 +245,28 @@ performed by the !, !! and !!! functions." *!!!* *!!*) (funcall *!*)) -(defun ! () +(defun ! () "Rerun the most recently run test and explain the results." (explain! (funcall *!*))) -(defun !! () +(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 *!!!*))) ;; Copyright (c) 2002-2003, Edward Marco Baringer -;; All rights reserved. -;; +;; 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. @@ -274,7 +274,7 @@ performed by the !, !! and !!! functions." ;; - 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 diff --git a/src/suite.lisp b/src/suite.lisp index 14427c6..505a66f 100644 --- a/src/suite.lisp +++ b/src/suite.lisp @@ -42,20 +42,20 @@ Overides any existing suite named NAME." (when description (setf (description suite) description)) (loop for i in (ensure-list in) - 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))) + 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)) ;;;; ** Managing the Current Suite (defvar *suite* (setf (get-test 'NIL) - (make-suite 'NIL :description "Global Suite")) + (make-suite 'NIL :description "Global Suite")) "The current test suite object") (defmacro in-suite (suite-name) @@ -75,25 +75,25 @@ See also: DEF-SUITE *SUITE*" (with-unique-names (suite) `(progn (if-bind ,suite (get-test ',suite-name) - (setf *suite* ,suite) - (progn - (when ,fail-on-error - (cerror "Create a new suite named ~A." - "Unkown suite ~A." ',suite-name)) - (setf (get-test ',suite-name) (make-suite ',suite-name :in ',in) - *suite* (get-test ',suite-name)))) + (setf *suite* ,suite) + (progn + (when ,fail-on-error + (cerror "Create a new suite named ~A." + "Unkown 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. -;; +;; 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. @@ -101,7 +101,7 @@ See also: DEF-SUITE *SUITE*" ;; - 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 diff --git a/src/test.lisp b/src/test.lisp index 7de4941..e046859 100644 --- a/src/test.lisp +++ b/src/test.lisp @@ -6,7 +6,7 @@ ;;;; 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 +;;;; 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. @@ -67,22 +67,21 @@ If PROFILE is T profiling information will be collected as well." `((with-fixture ,name ,args ,@body))) body))) `(progn - (setf (get-test ',name) (make-instance 'test-case - :name ',name - :runtime-package - #-ecl ,*package* - #+ecl (find-package ,(package-name *package*)) - :test-lambda - (lambda () - ,@ (ecase compile-at - (:run-time `((funcall - (let ((*package* (find-package ',(package-name *package*)))) - (compile nil '(lambda () - ,@effective-body)))))) - (:definition-time effective-body))) - :description ,description - :depends-on ',depends-on - :collect-profiling-info ,profile)) + (setf (get-test ',name) + (make-instance 'test-case + :name ',name + :runtime-package (find-package ,(package-name *package*)) + :test-lambda + (lambda () + ,@ (ecase compile-at + (:run-time `((funcall + (let ((*package* (find-package ',(package-name *package*)))) + (compile nil '(lambda () + ,@effective-body)))))) + (:definition-time effective-body))) + :description ,description + :depends-on ',depends-on + :collect-profiling-info ,profile)) (setf (gethash ',name (tests ,suite-form)) ',name) (when *run-test-when-defined* (run! ',name)) @@ -92,15 +91,15 @@ If PROFILE is T profiling information will be collected as well." "When non-NIL tests are run as soon as they are defined.") ;; Copyright (c) 2002-2003, Edward Marco Baringer -;; All rights reserved. -;; +;; 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. @@ -108,7 +107,7 @@ If PROFILE is T profiling information will be collected as well." ;; - 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 -- 1.7.10.4