Deliver each contrib as a single FASL. Don't implicitly require ASDF or source code...

[sbcl.git] / contrib / sb-cover / cover.lisp

diff --git a/contrib/sb-cover/cover.lisp b/contrib/sb-cover/cover.lisp
index d697492..957954b 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)))
 
         (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 :version 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.
 (defun report (directory &key ((:form-mode *source-path-mode*) :whole)
                (external-format :default))
   "Print a code coverage report of all instrumented files into DIRECTORY.

@@ -91,14 +104,20 @@ the coverage report will be placed on the CARs of any cons-forms, while if
 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."
 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))))
+  (let* ((paths)
+         (directory (pathname-as-directory directory))
+         (*default-pathname-defaults* (translate-logical-pathname directory)))

     (ensure-directories-exist *default-pathname-defaults*)
     (maphash (lambda (k v)
                (declare (ignore v))
     (ensure-directories-exist *default-pathname-defaults*)
     (maphash (lambda (k v)
                (declare (ignore v))

-               (let* ((n (substitute #\_ #\. (substitute #\_ #\/ k)))
-                      (path (make-pathname :name n :type "html")))
+               (let* ((pk (translate-logical-pathname k))
+                      (n (format nil "~(~{~2,'0X~}~)"
+                                (coerce (sb-md5:md5sum-string
+                                         (sb-ext:native-namestring pk))
+                                        'list)))
+                      (path (make-pathname :name n :type "html" :defaults directory)))

                  (when (probe-file k)
                  (when (probe-file k)

+                   (ensure-directories-exist pk)

                    (with-open-file (stream path
                                            :direction :output
                                            :if-exists :supersede
                    (with-open-file (stream path
                                            :direction :output
                                            :if-exists :supersede

@@ -106,7 +125,7 @@ latter mode is generally easier to read."
                      (push (list* k n (report-file k stream external-format))
                            paths)))))
              *code-coverage-info*)
                      (push (list* k n (report-file k stream external-format))
                            paths)))))
              *code-coverage-info*)

-    (let ((report-file (make-pathname :name "cover-index" :type "html")))
+    (let ((report-file (make-pathname :name "cover-index" :type "html" :defaults directory)))

       (with-open-file (stream report-file
                               :direction :output :if-exists :supersede
                               :if-does-not-exist :create)
       (with-open-file (stream report-file
                               :direction :output :if-exists :supersede
                               :if-does-not-exist :create)