diff --git a/fiveam.asd b/fiveam.asd index e364e2f..80cca15 100644 --- a/fiveam.asd +++ b/fiveam.asd @@ -11,14 +11,15 @@ :depends-on (:alexandria :net.didierverna.asdf-flv :trivial-backtrace) :pathname "src/" :components ((:file "package") + (:file "record-source-file" :depends-on ("package")) (:file "utils" :depends-on ("package")) (:file "check" :depends-on ("package" "utils")) - (:file "fixture" :depends-on ("package")) + (:file "fixture" :depends-on ("package" "record-source-file")) (:file "classes" :depends-on ("package")) (:file "random" :depends-on ("package" "check")) - (:file "test" :depends-on ("package" "fixture" "classes")) + (:file "test" :depends-on ("package" "fixture" "classes" "record-source-file")) (:file "explain" :depends-on ("package" "utils" "check" "classes" "random")) - (:file "suite" :depends-on ("package" "test" "classes")) + (:file "suite" :depends-on ("package" "test" "classes" "record-source-file")) (:file "run" :depends-on ("package" "check" "classes" "test" "explain" "suite"))) :in-order-to ((test-op (test-op :fiveam/test)))) diff --git a/src/fixture.lisp b/src/fixture.lisp index ac864f8..983f095 100644 --- a/src/fixture.lisp +++ b/src/fixture.lisp @@ -36,6 +36,7 @@ with DEF-FIXTURE is a macro which can use the special macrolet See Also: WITH-FIXTURE " `(eval-when (:compile-toplevel :load-toplevel :execute) + (record-source-file ,name :fiveam-fixture) (setf (get-fixture ',name) (cons ',args ',body)) ',name)) diff --git a/src/record-source-file.lisp b/src/record-source-file.lisp new file mode 100644 index 0000000..aebd46f --- /dev/null +++ b/src/record-source-file.lisp @@ -0,0 +1,15 @@ +;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Package: FIVEAM; Base: 10; -*- + +(in-package :it.bese.fiveam) + +#+ccl +(eval-when (:compile-toplevel :load-toplevel :execute) + (ccl:define-definition-type :fiveam-test nil) + (ccl:define-definition-type :fiveam-suite nil) + (ccl:define-definition-type :fiveam-fixture nil)) + +(defmacro record-source-file (name type) + #+allegro `(excl:record-source-file ',name :type ',type) + #+ccl `(ccl:record-source-file ',name ',type) + #-(or allegro ccl) + ()) diff --git a/src/run.lisp b/src/run.lisp index 30ae199..6ee254e 100644 --- a/src/run.lisp +++ b/src/run.lisp @@ -38,6 +38,12 @@ (declaim (type on-problem-action *on-error* *on-failure*)) +(defvar *on-warning* nil + "The action to perform on warning: +- :DEBUG if we should drop into the debugger +- :BACKTRACE to print a backtrace +- NIL to simply continue") + (defvar *on-error* nil "The action to perform on error: - :DEBUG if we should drop into the debugger @@ -190,6 +196,17 @@ run.")) *test-dribble*)) (invoke-restart (find-restart 'ignore-failure)))))) + (warning (lambda (c) + (ecase *on-warning* + (:debug (invoke-debugger c)) + (:backtrace + (format t "~&WARNING: ~a~%" c) + (trivial-backtrace:print-backtrace-to-stream + *test-dribble*) + (continue c)) + ((nil) + (format t "~&WARNING: ~a~%" c) + (continue c))))) (error (lambda (e) (unless (or (eql *on-error* :debug) (typep e 'check-failure)) diff --git a/src/suite.lisp b/src/suite.lisp index a18bee0..996c990 100644 --- a/src/suite.lisp +++ b/src/suite.lisp @@ -41,6 +41,7 @@ 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) + (record-source-file ,name :fiveam-suite) (make-suite ',name ,@(when description `(:description ,description)) ,@(when in `(:in ',in))) diff --git a/src/test.lisp b/src/test.lisp index 32103d5..26a74f8 100644 --- a/src/test.lisp +++ b/src/test.lisp @@ -105,10 +105,11 @@ If PROFILE is T profiling information will be collected as well." `((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)))) + (record-source-file ,name :fiveam-test) + (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 diff --git a/t/tests.lisp b/t/tests.lisp index c8b1c95..8df970d 100644 --- a/t/tests.lisp +++ b/t/tests.lisp @@ -288,3 +288,23 @@ (def-suite* :one-test-suite) (def-suite* :two-test-suite) (is (= 2 (length *toplevel-suites*))))) + +(defparameter *this-file* (asdf:system-relative-pathname "fiveam" "t/tests.lisp")) + +#+allegro +(def-test check-source-recording () + (is (equalp *this-file* (excl:source-file 'dont-discard-suite :fiveam-test))) + (is (equalp *this-file* (excl:source-file 'test-suite :fiveam-suite))) + (is (equalp *this-file* (excl:source-file 'null-fixture :fiveam-fixture)))) + +#+ccl +(def-test check-source-recording () + (flet ((source-file (obj type) + (translate-logical-pathname + (ccl::source-note-filename + (second + (first + (ccl:find-definition-sources obj type))))))) + (is (equalp *this-file* (source-file 'dont-discard-suite :fiveam-test))) + (is (equalp *this-file* (source-file 'test-suite :fiveam-suite))) + (is (equalp *this-file* (source-file 'null-fixture :fiveam-fixture)))))