1.0.19.8: SB-COVER:REPORT signals an error for non-directory pathnames

 * Based on patch by Pierre Mai.

diff --git a/NEWS b/NEWS
index 2c1291e..2a4bd38 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -16,6 +16,8 @@ changes in sbcl-1.0.20 relative to 1.0.19:
   * bug fix: restart computation during the execution of a restart
     test function no longer causes infinite recursion. (reported by
     Michael Weber)
+  * bug fix: calling SB-COVER:REPORT with a non-directory pathname now
+    signals an error. (thanks to Pierre Mai)
 
 changes in sbcl-1.0.19 relative to 1.0.18:
   * new feature: user-customizable variable SB-EXT:*MUFFLED-WARNINGS*;

diff --git a/contrib/sb-cover/cover.lisp b/contrib/sb-cover/cover.lisp
index c273b86..28ead42 100644 (file)
--- a/contrib/sb-cover/cover.lisp
+++ b/contrib/sb-cover/cover.lisp
@@ -79,6 +79,19 @@ result to RESTORE-COVERAGE."
         (restore-coverage (read stream))))
     (values)))
 
+(defun pathname-as-directory (pathname &optional (errorp t))
+  (let ((pathname (merge-pathnames pathname)))
+    (if (and (member (pathname-name pathname) '(nil :unspecific))
+             (member (pathname-type pathname) '(nil :unspecific)))
+        pathname
+        (if errorp
+            (error "~S does not designate a directory" pathname)
+            (make-pathname :directory (append (or (pathname-directory pathname)
+                                                  (list :relative))
+                                              (list (file-namestring pathname)))
+                           :name nil :type nil
+                           :defaults pathname)))))
+
 (defun report (directory &key ((:form-mode *source-path-mode*) :whole)
                (external-format :default))
   "Print a code coverage report of all instrumented files into DIRECTORY.
@@ -92,7 +105,7 @@ it has the value :WHOLE the whole form will be annotated (the default).
 The former mode shows explicitly which forms were instrumented, while the
 latter mode is generally easier to read."
   (let ((paths)
-        (*default-pathname-defaults* (merge-pathnames (pathname directory))))
+        (*default-pathname-defaults* (pathname-as-directory directory)))
     (ensure-directories-exist *default-pathname-defaults*)
     (maphash (lambda (k v)
                (declare (ignore v))

diff --git a/contrib/sb-cover/tests.lisp b/contrib/sb-cover/tests.lisp
index d7aa134..ea54b75 100644 (file)
--- a/contrib/sb-cover/tests.lisp
+++ b/contrib/sb-cover/tests.lisp
@@ -28,11 +28,18 @@
 (load (compile-file (merge-pathnames #p"test-data-1.lisp" *path*)))
 (report-expect-failure)
 
-;;; Instrument the file, try again
+;;; Instrument the file, try again -- first with a non-directory pathname
 
 (proclaim '(optimize sb-cover:store-coverage-data))
 (load (compile-file (merge-pathnames #p"test-data-1.lisp" *path*)))
 
+(catch 'ok
+  (handler-case
+      (sb-cover:report #p"/tmp/foo")
+    (error ()
+      (throw 'ok nil)))
+  (error "REPORT with a non-pathname directory did not signal an error."))
+
 (report)
 
 (assert (probe-file (make-pathname :name "cover-index" :type "html"

diff --git a/version.lisp-expr b/version.lisp-expr
index 2d779d4..de035f9 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.19.7"
+"1.0.19.8"