Source file recording

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))))
 

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))
 

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)
+  ())

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))

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)))

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

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)))))