clucumber 0.1.1 → 0.2.0

data/lib/clucumber/vendor/lift/dev/config.lisp

@@ -0,0 +1,354 @@
+(in-package #:lift)
+
+#|
+
+(:report-property :if-exists :supersede)
+(:report-property :unique-name nil)
+(:report-property :format :html)
+(:report-property :name "index")
+(:report-property :relative-to db.agraph.tests)
+
+For text based reports like :describe, the report name is the filename
+where the report is placed or a stream (e.g., *standard-output*).
+
+The :name property specifies the name and type.
+
+There are three ways to specify the directory:
+
+1. :full-name
+2. :relative-to
+3. the current directory (via *default-pathname-defaults*)
+
+If :full-name is a pathname with a name and type, then these will be
+used rather than :name. If :unique-name is true (and the destination
+is not a stream), then the date and an integer tag will be added to the 
+name. E.g., the path `/tmp/lift-tests/report.txt` will become 
+`/tmp/lift-tests/report-2009-02-01-1.txt`.
+
+
+For HTML, The report name specifies a _directory_. The :name property
+is ignored.
+
+There are three ways to specify the directory location. 
+
+1. :full-name
+2. :relative-to
+3. the current directory (via *default-pathname-defaults*)
+
+In all cases, the report will go into 
+
+|#
+
+(defgeneric generate-report-summary-pathname ()
+  )
+
+(defgeneric handle-config-preference (name args)
+  )
+
+
+(defvar *current-configuration-stream* nil)
+
+(defvar *current-asdf-system-name* nil
+  "Holds the name of the system being tested when using the `:generic` 
+configuration.
+
+LIFT needs this to run the `:generic` configuration because this is
+how it determines which configuration file to load. If you use 
+`asdf:test-op` then this value will be set automatically. 
+Otherwise, you will need to set it yourself.")
+
+(eval-when (:load-toplevel :execute)
+  (when (find-package :asdf)
+    (defmethod asdf:perform :around ((operation asdf:test-op) (c asdf:system))
+      (let ((*current-asdf-system-name* (asdf:component-name c)))
+	(call-next-method)))))
+
+(defun lift-relative-pathname (pathname &optional (errorp nil))
+  "Merges pathname with either the path to the currently loading system
+\(if there is one\) or the *default-pathname-defaults*."
+  (let* ((asdf-package (find-package :asdf))
+	 (srp-symbol (and asdf-package
+			  (find-symbol (symbol-name 'system-relative-pathname) 
+				       asdf-package)))
+	 (srp (and *current-asdf-system-name* srp-symbol)))
+    (labels ((try-it (path)
+	       (let ((pathname (merge-pathnames pathname path)))
+		 (if errorp (and pathname (probe-file pathname)) pathname))))
+      (or (and srp (try-it (funcall srp *current-asdf-system-name* "")))
+	  (try-it *default-pathname-defaults*)
+	  (not errorp)
+	  (and (not asdf-package)
+	       (error "Unable to use :generic configuration option because ASDF is not loaded."))
+	  (and (not srp-symbol)
+	       (error "Unable to use :generic configuration option because asdf:system-relative-pathname is not function bound (maybe try updating ASDF?)"))
+	  (and (not *current-asdf-system-name*)
+	       (error "Unable to use :generic configuration option 
+because the current system cannot be determined. You can either 
+use asdf:test-op or bind *current-asdf-system-name* yourself."))))))
+
+(defun find-generic-test-configuration (&optional (errorp nil))
+  (flet ((try-it (path)
+	   (and path (probe-file path))))
+    (or (try-it (lift-relative-pathname "lift-local.config" errorp))
+	(try-it (lift-relative-pathname "lift-standard.config" errorp))
+	(and errorp
+	     (error "Unable to use :generic configuration file neither lift-local.config nor lift-standard.config can be found.")))))
+
+(defun report-summary-pathname ()
+  (unique-filename (generate-report-summary-pathname)))
+
+(defmethod generate-report-summary-pathname ()
+  (lift-relative-pathname "test-results/summary.sav"))
+
+#+(or)
+(generate-report-summary-pathname)
+
+(defun run-tests-from-file (path)
+  (let ((real-path (cond ((eq path :generic)
+			  (setf path 
+				(find-generic-test-configuration t)))
+			 (t
+			  (probe-file path)))))
+    (unless real-path
+      (error "Unable to find configuration file ~s" path)) 
+    (setf *test-result*
+	  (let* ((*package* *package*)
+		 (*read-eval* nil)
+		 (result (make-test-result path :multiple))
+		 (*lift-dribble-pathname* nil)
+		 (*lift-debug-output* *debug-io*)
+		 (*lift-standard-output* *standard-output*)
+		 (*test-break-on-errors?* nil)
+		 (*test-do-children?* t)
+		 (*lift-equality-test* 'equal)
+		 (*test-print-length* :follow-print)
+		 (*test-print-level* :follow-print)
+		 (*lift-if-dribble-exists* :append)
+		 (*test-result* result))
+	    (%run-tests-from-file path)))))
+
+(defun %run-tests-from-file (path)
+  (with-open-file (*current-configuration-stream* path
+						  :direction :input
+						  :if-does-not-exist :error)
+    (let ((form nil)
+	  (run-tests-p t))
+      (loop while (not (eq (setf form (read *current-configuration-stream* 
+					    nil :eof nil)) :eof)) 
+	 collect
+	 (handler-bind 
+	     ((error (lambda (c) (format 
+				  *error-output* 
+				  "Error while running ~a from ~a: ~a"
+				  form path c)
+			     (pprint (get-backtrace c))
+			     (invoke-debugger c))))
+	   (destructuring-bind
+		 (name &rest args)
+	       form
+	     (assert (typep name 'symbol) nil
+		     "Each command must be a symbol and ~s is not." name)
+	     (setf args (massage-arguments args))
+	     (cond 
+	       ;; check for preferences first (i.e., keywords)
+	       ((eq (symbol-package name) 
+		    (symbol-package :keyword))
+		;; must be a preference
+		(handle-config-preference name args))
+	       ((and run-tests-p (find-testsuite name :errorp nil))
+		(multiple-value-bind (_ restartedp)
+		    (with-simple-restart (cancel-testing-from-configuration
+					  "Cancel testing from file ~a" path)
+		      (run-tests :suite name 
+				 :result *test-result* 
+				 :testsuite-initargs args))
+		  (declare (ignore _))
+		  ;; no more testing; continue to process commands
+		  (when restartedp 
+		    (setf run-tests-p nil))))
+	       (t
+		(warn "Don't understand '~s' while reading from ~s" 
+		      form path))))))))
+  (values *test-result*))
+
+(defun massage-arguments (args)
+  (loop for arg in args collect
+       (cond ((and (symbolp arg)
+		   (string= (symbol-name arg) (symbol-name '*standard-output*)))
+	      *standard-output*)
+	     (t arg))))
+
+(defmethod handle-config-preference ((name t) args)
+  (warn "Unknown preference ~s (with arguments ~s)" 
+	 name args))
+
+(defmethod handle-config-preference ((name (eql :include)) args)
+  (%run-tests-from-file (merge-pathnames (first args) 
+					 *current-configuration-stream*)))
+
+(defconfig-variable :dribble *lift-dribble-pathname*)
+
+(defconfig-variable :debug-output *lift-debug-output*)
+
+(defconfig-variable :standard-output *lift-standard-output*)
+
+(defconfig-variable :break-on-errors? *test-break-on-errors?*)
+
+(defconfig-variable :do-children? *test-do-children?*)
+
+(defconfig-variable :equality-test *lift-equality-test*)
+
+(defconfig-variable :print-length *test-print-length*)
+
+(defconfig-variable :print-level *test-print-level*)
+
+(defconfig-variable :print-suite-names *test-print-testsuite-names*)
+
+(defconfig-variable :print-test-case-names *test-print-test-case-names*)
+
+(defconfig-variable :if-dribble-exists *lift-if-dribble-exists*)
+
+(defmethod handle-config-preference ((name (eql :report-property))
+				     args)
+  (setf (test-result-property *test-result* (first args)) (second args)))
+
+(defconfig-variable :profiling-threshold *profiling-threshold*)
+
+(defconfig-variable :count-calls-p *count-calls-p*)
+
+(defconfig-variable :log-pathname *lift-report-pathname*)
+
+(defconfig-variable :maximum-failures *test-maximum-failure-count*)
+(defconfig-variable :maximum-failure-count *test-maximum-failure-count*)
+
+(defconfig-variable :maximum-errors *test-maximum-error-count*)
+(defconfig-variable :maximum-error-count *test-maximum-error-count*)
+
+(defgeneric report-pathname (method &optional result))
+
+(defmethod report-pathname :around ((method (eql :html)) 
+				    &optional (result *test-result*))
+  (cond ((and (test-result-property result :full-pathname)
+	      (streamp (test-result-property result :full-pathname)))
+	 (call-next-method))
+	(t
+	 (let ((old-name (test-result-property result :name))
+	       (old-full-pathname (test-result-property result :full-pathname))
+	       (old-unique-name (test-result-property result :unique-name)))
+	   (unwind-protect
+		(progn
+		  (setf (test-result-property result :name) t
+			(test-result-property result :unique-name) nil)
+		  (let ((destination (pathname-sans-name+type (call-next-method))))
+		    (when old-name
+		      (setf destination
+			    (merge-pathnames
+			     (make-pathname :directory `(:relative ,old-name))
+			     destination)))
+		    (print destination)
+		    (merge-pathnames
+		     (make-pathname :name "index" :type "html")
+		     (pathname-sans-name+type
+		      (if old-unique-name 
+			  (unique-directory destination)
+			  destination)))))
+	     (setf (test-result-property result :name) old-name
+		   (test-result-property result :full-pathname) 
+		   old-full-pathname
+		   (test-result-property result :unique-name) 
+		   old-unique-name))))))
+
+#+(or)
+(defmethod report-pathname :around ((method t) &optional (result *test-result*))
+  "Make sure that directories exist"
+  (let ((output (call-next-method)))
+    (cond ((streamp output)
+	   output)
+	  (t
+	   (ensure-directories-exist output)
+	   output))))
+
+(defmethod report-pathname ((method t) &optional (result *test-result*))
+  (let* ((given-report-name (test-result-property result :name))
+	 (report-type (string-downcase
+		       (ensure-string 
+			(test-result-property result :format))))
+	 (report-name (or (and given-report-name
+			       (not (eq given-report-name t))
+			       (merge-pathnames
+				given-report-name 
+				(make-pathname :type report-type)))
+			  (format nil "report.~a" report-type)))
+	 (via nil)
+	 (dest (or (and (setf via :full-pathname)
+			(test-result-property result :full-pathname)
+			(streamp
+			 (test-result-property result :full-pathname))
+			(test-result-property result :full-pathname))
+		   (and (setf via :full-pathname)
+			(test-result-property result :full-pathname)
+			(not (streamp
+			      (test-result-property result :full-pathname)))
+			(cond ((eq given-report-name t)
+			       (test-result-property result :full-pathname))
+			      ((null given-report-name)
+			       (merge-pathnames
+				(test-result-property result :full-pathname)
+				report-name))
+			      (t
+			       (merge-pathnames
+				(test-result-property result :full-pathname)
+				given-report-name))))
+		   (and (setf via :relative-to)
+			(let ((relative-to 
+			       (test-result-property result :relative-to)))
+			  (and relative-to
+			       (asdf:find-system relative-to nil)
+			       (asdf:system-relative-pathname 
+				relative-to report-name))))
+		   (and (setf via :current-directory)
+			(merge-pathnames
+			 (make-pathname :defaults report-name)))))
+	 (unique-name? (test-result-property result :unique-name)))
+    (values 
+     (if (and unique-name? (not (streamp dest)))
+	 (unique-filename dest)
+	 dest)
+     via)))
+
+(defmethod handle-config-preference ((name (eql :build-report))
+				     args)
+ (declare (ignore args))
+ (let* ((format (or (test-result-property *test-result* :format)
+		     :html))
+	 (dest (report-pathname format *test-result*)))
+   (with-standard-io-syntax 
+     (let ((*print-readably* nil))
+	(handler-bind 
+	    ((error 
+	      (lambda (c)
+		(format *debug-io*
+			"Error ~a while generating report (format ~s) to ~a"
+			c format dest)
+		(format *debug-io*
+			"~%~%Backtrace~%~%~s" 
+			(get-backtrace c)))))
+	  (cond
+	    ((or (streamp dest) 
+		 (ensure-directories-exist dest)
+		 (writable-directory-p dest))
+	     (format *debug-io* "~&Sending report (format ~s) to ~a" 
+		     format dest)
+	     (test-result-report
+	      *test-result* dest format))
+	    (t
+	     (format *debug-io* "~&Unable to write report (format ~s) to ~a" 
+		     format dest))))))))
+ 
+
+(defconfig :trace 
+  "Start tracing each of the arguments to :trace."
+  (eval `(trace ,@args)))
+
+(defconfig :untrace
+  (eval `(untrace ,@args)))

data/lib/clucumber/vendor/lift/dev/copy-file.lisp

@@ -0,0 +1,117 @@
+;;;;
+;;; directly pullled from metatilities, sigh
+
+(in-package #:lift)
+;(in-package #:metatilities)
+        
+(define-condition source/target-file-error (file-error)
+                  ((pathname :reader source-pathname
+                             :initarg :source-pathname)
+                   (target-pathname :reader target-pathname 
+                                    :initarg :target-pathname :initform nil))
+  (:report (lambda (c s)
+             (format s "Copy of ~S to ~S failed" 
+                     (source-pathname c) (target-pathname c))))
+  (:documentation "General condition for file errors that have a source and target."))
+
+(define-condition source/target-target-already-exists-error (source/target-file-error)
+                  ()
+  (:report (lambda (c s)
+             (format s "File action failed because target ~S already exists"
+                     (target-pathname c))))
+  (:documentation "This error is signaled when the target pathname already exists."))
+
+(define-condition source/target-source-does-not-exist-error
+    (source/target-file-error)
+                  ()
+  (:report (lambda (c s)
+             (format s "File action failed because source ~S does not exist"
+                     (source-pathname c))))
+  (:documentation "This error is signaled when the source file does not exist."))
+
+(defun copy-file (from to &key (if-does-not-exist :error)
+                       (if-exists :error))
+  "Copies the file designated by the non-wild pathname designator FROM
+to the file designated by the non-wild pathname designator TO. The following
+keyword parameters are supported:
+
+* :if-exists
+    this can be either :supersede or :error (the default). If it is :error then
+a source/target-target-already-exists-error will be signaled if the file designated
+by the TO pathname already exists.
+
+* :if-does-not-exist 
+    this can be either :ignore or :error (the default). If it is :error then
+a source/target-source-does-not-exist-error will be signaled if the FROM pathname
+designator does not exist.
+"
+  (assert (member if-exists '(:error :supersede))
+          nil
+          "The if-exists keyword parameter must be one of :error or :supersede. It is currently set to ~S" 
+          if-exists)
+  (assert (member if-does-not-exist '(:error :ignore))
+          nil
+          "The if-does-not-exist keyword parameter must be one of :error or :ignore. It is currently set to ~S" 
+          if-does-not-exist)
+  (ensure-directories-exist to)
+  (cond ((probe-file from)
+         #+:allegro 
+         (excl.osi:copy-file 
+	  from to 
+	  :overwrite (if (eq if-exists :supersede) :ignore nil)) 
+         #-:allegro
+         (let ((element-type #-:cormanlisp '(unsigned-byte 8)
+                             #+:cormanlisp 'unsigned-byte))
+           (with-open-file (in from :element-type element-type)
+             (with-open-file (out to :element-type element-type
+                                  :direction :output
+                                  :if-exists if-exists)
+               (unless out
+                 (error (make-condition 'source/target-target-already-exists
+                                        :pathname from
+                                        :target-pathname to)))
+               (copy-stream in out))))
+         (values t))
+        (t
+         ;; no source file!
+         (ecase if-does-not-exist
+           ((:error) (error 'source/target-source-does-not-exist-error
+                            :pathname from :target-pathname to))
+           ((:ignore) nil)))))
+
+(defun move-file (from to &rest args &key (if-does-not-exist :error)
+		  (if-exists :error))
+  (declare (dynamic-extent args)
+	   (ignore if-exists if-does-not-exist))
+  (when (apply #'copy-file from to args)
+    (delete-file from)))
+
+;;; borrowed from asdf-install -- how did this ever work ?!
+;; for non-SBCL we just steal this from SB-EXECUTABLE
+#-(or :digitool)
+(defvar *stream-buffer-size* 8192)
+#-(or :digitool)
+(defun copy-stream (from to)
+  "Copy into TO from FROM until end of the input stream, in blocks of
+*stream-buffer-size*.  The streams should have the same element type."
+  (unless (subtypep (stream-element-type to) (stream-element-type from))
+    (error "Incompatible streams ~A and ~A." from to))
+  (let ((buf (make-array *stream-buffer-size*
+			 :element-type (stream-element-type from))))
+    (loop
+      (let ((pos #-(or :clisp :cmu) (read-sequence buf from)
+                 #+:clisp (ext:read-byte-sequence buf from :no-hang nil)
+                 #+:cmu (sys:read-n-bytes from buf 0 *stream-buffer-size* nil)))
+        (when (zerop pos) (return))
+        (write-sequence buf to :end pos)))))
+
+#+:digitool
+(defun copy-stream (from to)
+  "Perform copy and map EOL mode."
+  (multiple-value-bind (reader reader-arg) (ccl::stream-reader from)
+    (multiple-value-bind (writer writer-arg) (ccl::stream-writer to)
+      (let ((datum nil))
+        (loop (unless (setf datum (funcall reader reader-arg))
+                (return))
+              (funcall writer writer-arg datum))))))
+

data/lib/clucumber/vendor/lift/dev/introspection.lisp

@@ -0,0 +1,232 @@
+(in-package #:lift)
+
+(defgeneric find-testsuite (suite &key errorp)
+  (:documentation "Search for a testsuite named `suite`. 
+
+The search is conducted across all packages so `suite` can be 
+a symbol in any package. I.e., find-testsuite looks for testsuite 
+classes whose symbol-name is string= to `suite`. If `errorp` is 
+true, then find-testsuite can raise two possible errors:
+
+ * If more than one matching testsuite is found, 
+then an error of type `testsuite-ambiguous` will be raised. 
+ * If no matching testsuites are found, then an error of type 
+`testsuite-not-defined` will be raised. 
+
+The default for `errorp` is nil."))
+
+(defgeneric find-test-case (suite name &key errorp)
+  (:documentation "Search for a test-case named `name` in a 
+testsuite named `suite`. 
+
+The search is conducted across all packages so `suite` and `name` 
+can be symbols in any package. I.e., find-test-case looks for a
+testsuites and test-cases whose symbol-names are string= to
+`suite` and `name`. If `errorp` is 
+true, then find-test-case can raise two possible errors:
+
+ * If more than one matching test-case is found, 
+then an error of type `test-case-ambiguous` will be raised. 
+ * If no matching test-cases are found, then an error of type 
+`test-case-not-defined` will be raised. 
+
+The default for `errorp` is nil. If `suite` is nil, then
+find-test-case will search for matching test-cases across 
+all suites. This is equivalent to the behavior of [find-test-cases][]."))
+
+(defgeneric find-test-cases (name &key errorp)
+  )
+
+;;;;;
+;; some introspection
+
+(defun liftpropos (string &key (include-cases? nil))
+  "Returns a list of testsuites whose name contains `string`."
+  (let ((result nil)
+	(name-as-string (ensure-string string)))
+    (flet ((add-if-match (suite-name &optional (to-add suite-name))
+	     (when (search name-as-string (ensure-string suite-name)
+			   :test #'char-equal)
+	       (push to-add result))))
+      (map-testsuites
+       (lambda (suite level)
+	 (declare (ignore level))
+	 (let ((suite-name (class-name suite)))
+	   (add-if-match suite-name)
+	   (when include-cases?
+	     (loop for method-name in (testsuite-tests suite-name) do
+		  (add-if-match 
+		   method-name (cons suite-name method-name))))))
+       'test-mixin))
+    (sort result #'string-lessp :key (lambda (it)
+				       (typecase it
+					 (atom it)
+					 (cons (cdr it)))))))
+
+(defun map-testsuites (fn start-at)
+  (let ((visited (make-hash-table)))
+    (labels ((do-it (suite level)
+	       (unless (gethash suite visited)
+		 (setf (gethash suite visited) t)
+		 (funcall fn suite level)
+		 (loop for subclass in (subclasses suite :proper? t) do
+		      (do-it subclass (1+ level))))))
+    (do-it (find-class (find-testsuite start-at) nil) 0))))
+
+(defun testsuites (&optional (start-at 'test-mixin))
+  "Returns a list of testsuite classes. The optional parameter provides
+control over where in the test hierarchy the search begins."
+  (let ((result nil))
+    (map-testsuites (lambda (suite level)
+		      (declare (ignore level))
+		      (push suite result))
+		    start-at)
+    (nreverse result)))
+
+(defun print-tests (&key (include-cases? t) (start-at 'test-mixin) (stream t))
+  "Prints all of the defined test classes from :start-at on down." 
+  (map-testsuites
+   (lambda (suite level)
+     (let ((indent (coerce (make-list (* level 3) :initial-element #\Space)
+			   'string))
+	   (name (class-name suite)))
+       (format stream "~&~a~s (~:d)" 
+	       indent
+	       name
+	       (length (testsuite-methods name)))
+       (when include-cases?
+	 (loop for method-name in (testsuite-tests name) do
+	      (format stream "~&~a  ~a" indent method-name)))))
+   start-at))
+     
+(defun list-tests (&key (include-cases? t) (start-at 'test-mixin) (stream t))
+  "Lists all of the defined test classes from :start-at on down." 
+  (mapc (lambda (subclass)
+	  (let ((subclass-name (class-name subclass)))
+	    (format stream "~&~s (~:d)" 
+		    subclass-name
+		    (length (testsuite-methods subclass-name)))
+	    (when include-cases?
+	      (loop for method-name in (testsuite-tests subclass-name) do
+		   (format stream "~&  ~a" method-name)))))
+        (testsuites start-at))
+  (values))
+
+(defun testsuite-test-count (testsuite)
+  (or (and *testsuite-test-count* 
+           (prog1 *testsuite-test-count* (incf *testsuite-test-count*))) 
+      (length (testsuite-methods testsuite))))
+
+(defmethod find-testsuite ((suite symbol) &key (errorp nil))
+  (or (testsuite-p suite)
+      (find-testsuite (symbol-name suite) :errorp errorp)))
+
+(defmethod find-testsuite ((suite-name string) &key (errorp nil))
+  (let* ((temp nil)
+	 (possibilities (remove-duplicates 
+			 (loop for p in (list-all-packages) 
+			    when (and (setf temp (find-symbol suite-name p))
+				      (find-class temp nil)
+				      (subtypep temp 'test-mixin)) collect
+			    temp))))
+    (cond ((null possibilities) 
+	   (when errorp
+	     (error 'testsuite-not-defined :testsuite-name suite-name)))
+	  ((= (length possibilities) 1)
+	   (first possibilities))
+	  (t 
+	   (if errorp
+	     (error 'testsuite-ambiguous
+		    :testsuite-name suite-name 
+		    :possible-matches possibilities))
+	   possibilities))))
+			     
+(defun test-case-p (suite-class name)
+  (find-method #'lift-test nil `(,suite-class (eql ,name)) nil)) 
+
+#+(or)
+(test-case-p 
+ (find-class (find-testsuite 'test-cluster-indexing-locally) nil)
+ 'db.agraph.tests::index-them)
+
+#+(or)
+(find-test-case (find-class (find-testsuite 'test-cluster-indexing-locally))
+		'index-themxx)
+
+(defmethod find-test-case ((suite symbol) name &key (errorp nil))
+  (find-test-case (find-class (find-testsuite suite)) name :errorp errorp)) 
+
+(defmethod find-test-case ((suite null) name &key (errorp nil))
+  (find-test-cases name :errorp errorp)) 
+
+(defmethod find-test-case ((suite test-mixin) name &key (errorp nil))
+  (find-test-case (class-of suite) name :errorp errorp))
+
+(defmethod find-test-case ((suite-class standard-class) (name symbol)
+			    &key (errorp nil))
+  (or (and (test-case-p suite-class name) name)
+      (find-test-case suite-class (symbol-name name) :errorp errorp)))
+
+(defmethod find-test-case ((suite test-mixin) (name string)
+			   &key (errorp nil))
+  (find-test-case (class-of suite) name :errorp errorp))
+
+(defmethod find-test-case ((suite-class standard-class) (name string)
+			    &key (errorp nil))
+  (let* ((temp nil)
+	 (possibilities (remove-duplicates 
+			 (loop for p in (list-all-packages) 
+			    when (and (setf temp (find-symbol name p))
+				      (test-case-p suite-class temp)) collect
+			    temp))))
+    (cond ((null possibilities) 
+	   (when errorp
+	     (error 'test-case-not-defined 
+		    :testsuite-name suite-class :test-case-name name)))
+	  ((= (length possibilities) 1)
+	   (first possibilities))
+	  (t 
+	   (when errorp
+	     (error 'test-case-ambiguous
+		    :testsuite-name suite-class
+		    :test-case-name name
+		    :possible-matches possibilities))))))
+			     
+(defmethod find-test-cases ((name symbol) &key (errorp nil))
+  (find-test-cases (symbol-name name) :errorp errorp))
+
+(defmethod find-test-cases ((name string) &key (errorp nil))
+  (let ((result nil))
+    (dolist (testsuite (testsuites))
+      (let* ((suitename (class-name testsuite))
+	     (testname (find-symbol name (symbol-package suitename))))
+	(when (and testname 
+		   (test-case-p testsuite testname))
+	  (push (cons suitename testname) result))))
+    (unless result
+      (when errorp
+	(error "not test-cases found")))
+    result))
+
+(defun last-test-status ()
+  (cond ((typep *test-result* 'test-result)
+	 (cond ((and (null (errors *test-result*))
+		     (null (failures *test-result*)))
+		:success)
+	       ((and (errors *test-result*)
+		     (failures *test-result*))
+		:errors-and-failures)
+	       ((errors *test-result*)
+		:errors)
+	       ((failures *test-result*)
+		:failures)))
+	(t
+	 nil)))
+
+(defun suite-tested-p (suite &key (result *test-result*))
+  (and result
+       (typep *test-result* 'test-result)
+       (slot-exists-p result 'suites-run)
+       (slot-boundp result 'suites-run)
+       (consp (suites-run result))
+       (find suite (suites-run result))))