(:use #:cl #:sb-c)
(:export #:report
#:reset-coverage #:clear-coverage
+ #:restore-coverage #:restore-coverage-from-file
+ #:save-coverage #:save-coverage-in-file
#:store-coverage-data))
(in-package #:sb-cover)
+(declaim (type (member :whole :car) *source-path-mode*))
+(defvar *source-path-mode* :whole)
+
(defclass sample-count ()
((mode :accessor mode-of :initarg :mode)
(all :accessor all-of :initform 0)
"Reset all coverage data back to the `Not executed` state."
(sb-c::reset-code-coverage))
-(defun report (directory &key (external-format :default))
+(defun save-coverage ()
+ "Returns an opaque representation of the current code coverage state.
+The only operation that may be done on the state is passing it to
+RESTORE-COVERAGE. The representation is guaranteed to be readably printable.
+A representation that has been printed and read back will work identically
+in RESTORE-COVERAGE."
+ (loop for file being the hash-keys of sb-c::*code-coverage-info*
+ using (hash-value states)
+ collect (cons file states)))
+
+(defun restore-coverage (coverage-state)
+ "Restore the code coverage data back to an earlier state produced by
+SAVE-COVERAGE."
+ (loop for (file . states) in coverage-state
+ do (let ((image-states (gethash file sb-c::*code-coverage-info*))
+ (table (make-hash-table :test 'equal)))
+ (when image-states
+ (loop for cons in image-states
+ do (setf (gethash (car cons) table) cons))
+ (loop for (key . value) in states
+ do (let ((state (gethash key table)))
+ (when state
+ (setf (cdr state) value))))))))
+
+(defun save-coverage-in-file (pathname)
+ "Call SAVE-COVERAGE and write the results of that operation into the
+file designated by PATHNAME."
+ (with-open-file (stream pathname
+ :direction :output
+ :if-exists :supersede
+ :if-does-not-exist :create)
+ (with-standard-io-syntax
+ (let ((*package* (find-package :sb-cover)))
+ (write (save-coverage) :stream stream)))
+ (values)))
+
+(defun restore-coverage-from-file (pathname)
+ "READ the contents of the file designated by PATHNAME and pass the
+result to RESTORE-COVERAGE."
+ (with-open-file (stream pathname :direction :input)
+ (with-standard-io-syntax
+ (let ((*package* (find-package :sb-cover)))
+ (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.
If DIRECTORY does not exist, it will be created. The main report will be
printed to the file cover-index.html. The external format of the source
-files can be specified with the EXTERNAL-FORMAT parameter."
- (let ((paths)
- (*default-pathname-defaults* (merge-pathnames (pathname directory))))
+files can be specified with the EXTERNAL-FORMAT parameter.
+
+If the keyword argument FORM-MODE has the value :CAR, the annotations in
+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."
+ (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))
- (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)
+ (ensure-directories-exist pk)
(with-open-file (stream path
:direction :output
:if-exists :supersede
(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)
(warn "Error finding source location for source path ~A in file ~A~%" source-path file)))
(warn "Unable to find a source map for toplevel form ~A in file ~A~%" tlf file)))))
;; Now process the locations, from the shortest range to the longest
- ;; one.
- (dolist (location (sort locations #'<
- :key (lambda (location)
- (- (second location)
- (first location)))))
+ ;; one. If two locations have the same range, the one with the higher
+ ;; state takes precedence. The latter condition ensures that if
+ ;; there are both normal- and a branch-states for the same form,
+ ;; the branch-state will be used.
+ (setf locations (sort locations #'> :key #'fourth))
+ (dolist (location (stable-sort locations #'<
+ :key (lambda (location)
+ (- (second location)
+ (first location)))))
(destructuring-bind (start end source state) location
(fill-with-state source states state start end))))
(print-report html-stream file counts states source)
unless (member (caar record) '(:then :else))
collect (list mode
(car record)
- (ecase (cdr record)
- ((t) 1)
- ((nil) 2)))))
+ (if (sb-c::code-coverage-record-marked record)
+ 1
+ 2))))
(:branch
(let ((hash (make-hash-table :test 'equal)))
(dolist (record records)
(when (member (car path) '(:then :else))
(setf (gethash (cdr path) hash)
(logior (gethash (cdr path) hash 0)
- (ash (if (cdr record)
+ (ash (if (sb-c::code-coverage-record-marked record)
1
2)
(if (eql (car path) :then)
(cond ((sb-impl::token-delimiterp nextchar)
(cond ((eq listtail thelist)
(unless *read-suppress*
- (sb-impl::%reader-error
+ (sb-int:simple-reader-error
stream
"Nothing appears before . in list.")))
((sb-impl::whitespace[2]p nextchar)
;; allows the possibility that a comment was read
(when listobj
(unless (consp (car listobj))
- (setf (car listobj) (gensym))
+ (setf (car listobj) (gensym))
(push (list start end *read-suppress*)
(gethash (car listobj) source-map)))
(rplacd listtail listobj)
of the deepest (i.e. smallest) possible form is returned."
;; compute all subforms along path
(let ((forms (loop for n in path
- for m on path
- for dummy = (when (eql n :progn)
- (return forms))
for f = form then (nth n f)
- unless (null (cdr m))
collect f into forms
finally (return forms))))
;; select the first subform present in source-map
- (loop for form in (reverse forms)
+ (loop for real-form in (reverse forms)
+ for form = (if (or (eql *source-path-mode* :whole)
+ (not (consp real-form)))
+ real-form
+ (car real-form))
for positions = (gethash form source-map)
until (and positions (null (cdr positions)))
finally (destructuring-bind ((start end suppress)) positions
projects / sbcl.git / blobdiff