From 2b030567c502db66fce76789c4e7cc49d4962bf4 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 31 Jul 2008 06:50:54 +0000 Subject: [PATCH] 1.0.19.8: SB-COVER:REPORT signals an error for non-directory pathnames * Based on patch by Pierre Mai. --- NEWS | 2 ++ contrib/sb-cover/cover.lisp | 15 ++++++++++++++- contrib/sb-cover/tests.lisp | 9 ++++++++- version.lisp-expr | 2 +- 4 files changed, 25 insertions(+), 3 deletions(-) diff --git a/NEWS b/NEWS index 2c1291e18..2a4bd3837 100644 --- 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 c273b8609..28ead428e 100644 --- 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 d7aa13437..ea54b7537 100644 --- 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 2d779d406..de035f986 100644 --- 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" -- 2.11.4.GIT