X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fsuite.lisp;h=c0cac8b16dcaa5de8d75613b21c54e14186d8aca;hb=106e91b038191cec3271413a7a2bdd8317352277;hp=0118e1a5012c5b3324a04cc9cc5436219559a3cb;hpb=7caced9155e32d2e04db2f574057c33f3fda85ab;p=fiveam.git diff --git a/src/suite.lisp b/src/suite.lisp index 0118e1a..c0cac8b 100644 --- a/src/suite.lisp +++ b/src/suite.lisp @@ -1,6 +1,6 @@ -;; -*- lisp -*- +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- -(in-package :it.bese.FiveAM) +(in-package :it.bese.fiveam) ;;;; * Test Suites @@ -16,66 +16,102 @@ ;;;; ** Creating Suits -(defmacro def-suite (name &key description in) +(defvar *suites* (make-hash-table :test 'eql)) + +(defmacro def-suite (name &key description (in nil in-p) (fixture nil fixture-p)) "Define a new test-suite named NAME. -IN (a symbol), if provided, causes this suite te be nested in the -suite named by IN." - `(progn +NAME:: + The symbol naming the test. + +DESCRIPTION:: + A string describing the contents/purpose of this suite. + +IN (a symbol):: + If provided, causes this suite te be nested in the suite named by + `IN`. If `IN` is `NIL`, as opposed to not being passed at all, the + new suite will not be a part of any existing suite. + +FIXTURE:: + Whatever value is passed here will be passed, unevaluated, to all + tests defined in this suite. + +[NOTE] +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))) + ,@(when description `(:description ,description)) + ,@(when in-p `(:in ',in)) + ,@(when fixture-p `(:fixture ',fixture))) ',name)) -(defun make-suite (name &key description in) - "Create a new test suite object." - (let ((suite (make-instance 'test-suite :name name))) +(defun remove-from-suites (test-name) + (when (get-test test-name) + ;; if this suite alruady exists, and its :IN some other suite, remove it. + (dolist (s (list-all-suites)) + (when (gethash test-name (tests s)) + (remhash test-name (tests s)))))) + +(defun make-suite (name &key description ((:in parent-suite) *suite*) fixture) + "Create a new test suite object. + +Overrides any existing suite named NAME." + (remove-from-suites name) + (let ((suite (make-instance 'test-suite :name name :fixture fixture))) (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))) + (setf (gethash name *suites*) suite) + (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)) +(defun list-all-suites () + (loop for suite being the hash-value in *suites* + collect suite)) + ;;;; ** Managing the Current Suite -(defvar *suite* (setf (get-test 'NIL) - (make-suite 'NIL :description "Global Suite")) +(defvar *suite* (setf (get-test 'T) (make-suite 'T :description "Default global suite" :in nil)) "The current test suite object") (defmacro in-suite (suite-name) - "Set the *suite* special variable so that all tests defined + "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. +in the test-suite named `SUITE-NAME`. + +See also: `DEF-SUITE` and `*SUITE*`. " + `(eval-when (:compile-toplevel :load-toplevel :execute) + (%in-suite ,suite-name))) -See also: DEF-SUITE *SUITE*" - (with-unique-names (suite) +(defmacro %in-suite (suite-name &rest def-suite-args) + (with-gensyms (suite) `(progn - (if-bind ,suite (get-test ',suite-name) - (setf *suite* ,suite) - (progn - (cerror "Create a new suite named ~A." - "Unkown suite ~A." ',suite-name) - (setf (get-test ',suite-name) (make-suite ',suite-name) - *suite* (get-test ',suite-name)))) + (if-let (,suite (get-test ',suite-name)) + (setf *suite* ,suite) + (progn + (cerror "Create a new suite named ~A." "Unknown suite ~A." ',suite-name) + (setf (get-test ',suite-name) (make-suite ',suite-name ,@def-suite-args) + *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. @@ -83,7 +119,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