source: branches/gz-working/library/cover.lisp @ 8505

Last change on this file since 8505 was 8505, checked in by gz, 13 years ago

checkpoint work in progress, mainly some final cleanup, reorg, don't try to track atoms, keep track of source through transforms; reporting implementation in library;cover.lisp

File size: 16.0 KB
Line 
1;;; Code coverage reporting facility, based on the SBCL's
2;;; sb-cover written by Juho Snellman, and placed under public domain.
3;;; Port to ccl by gz@clozure.com
4
5(in-package :ccl)
6
7(export '(*compile-code-coverage*
8          report-coverage
9          reset-coverage
10          clear-coverage
11          save-coverage-in-file
12          restore-coverage-from-file))
13
14(defconstant $not-executed-style 2)
15(defconstant $totally-covered-style 5)
16(defconstant $partially-covered-style 6)
17
18(defun show-notes (note)
19  (when (functionp note)
20    (setq note (function-source-note note)))
21  (labels ((show (note indent label)
22             (dotimes (i indent) (write-char #\space))
23             (format t "~a ~a~%" label note)
24             (loop with subindent = (+ indent 3)
25               for sub in (code-note-subform-notes note) as i upfrom 1
26               do (show sub subindent (format nil "~a~d." label i)))))
27    (show note 0 "")))
28
29(defun covered-functions-for-file (path)
30  (let* ((true-path (probe-file path))
31         (data (find-if #'(lambda (data)
32                           (and (consp data)
33                                (equalp (probe-file (car data)) true-path)))
34                       *code-covered-functions*)))
35    (cdr data)))
36
37(defun map-covered-functions (fn)
38  (loop for data in *code-covered-functions*
39    do (typecase data
40         (cons ;; (source-file . functions)
41          (map nil fn (cdr data)))
42         (function
43          (funcall fn data)))))
44
45(defun map-coverage-records (fn)
46  (map-covered-functions #'(lambda (function)
47                             (labels ((rec (note)
48                                        (when note
49                                          (map nil #'rec (code-note-subform-notes note))
50                                          (funcall fn note))))
51                               (rec (function-source-note function))))))
52
53(defun clear-coverage ()
54  "Clear all files from the coverage database. The files will be re-entered
55into the database when the FASL files (produced by compiling with
56CCL:*COMPILE-CODE-COVERAGE* set to true) are loaded again into the
57image."
58  (setq *code-covered-functions* nil))
59
60(defun reset-coverage ()
61  "Reset all coverage data back to the `Not executed` state."
62  (map-coverage-records #'(lambda (note)
63                            (setf (code-note-code-coverage note) nil))))
64
65(defun save-coverage ()
66  "Returns an opaque representation of the current code coverage state.
67The only operation that may be done on the state is passing it to
68RESTORE-COVERAGE. The representation is guaranteed to be readably printable.
69A representation that has been printed and read back will work identically
70in RESTORE-COVERAGE."
71  #+sbcl(loop for file being the hash-keys of sb-c::*code-coverage-info*
72           using (hash-value states)
73           collect (cons file states))
74  (error "Not implemented yet"))
75
76(defun restore-coverage (coverage-state)
77  "Restore the code coverage data back to an earlier state produced by
78SAVE-COVERAGE."
79  #+sbcl
80  (loop for (file . states) in coverage-state
81        do (let ((image-states (gethash file sb-c::*code-coverage-info*))
82                 (table (make-hash-table :test 'equal)))
83             (when image-states
84               (loop for cons in image-states
85                     do (setf (gethash (car cons) table) cons))
86               (loop for (key . value) in states
87                     do (let ((state (gethash key table)))
88                          (when state
89                            (setf (cdr state) value)))))))
90  coverage-state
91  (error "Not implemented yet"))
92
93(defun save-coverage-in-file (pathname)
94  "Call SAVE-COVERAGE and write the results of that operation into the
95file designated by PATHNAME."
96  (with-open-file (stream pathname
97                          :direction :output
98                          :if-exists :supersede
99                          :if-does-not-exist :create)
100    (with-standard-io-syntax
101      (let ((*package* (find-package :sb-cover)))
102        (write (save-coverage) :stream stream)))
103    (values)))
104
105(defun restore-coverage-from-file (pathname)
106  "READ the contents of the file designated by PATHNAME and pass the
107result to RESTORE-COVERAGE."
108  (with-open-file (stream pathname :direction :input)
109    (with-standard-io-syntax
110      (let ((*package* (find-package :sb-cover)))
111        (restore-coverage (read stream))))
112    (values)))
113
114(defun common-coverage-directory ()
115  (let* ((host :unknown)
116         (rev-dir ()))
117    (loop for data in *code-covered-functions*
118       when (consp data)
119       do (let ((file (probe-file (car data))))
120            (when file
121              (cond ((eq host :unknown)
122                     (setq host (pathname-host file)
123                           rev-dir (reverse (pathname-directory file))))
124                    ((not (equalp host (pathname-host file)))
125                     (return-from common-coverage-directory nil))
126                    (t
127                     (let* ((path (pathname-directory file))
128                            (dir-len (length rev-dir))
129                            (len (length path)))
130                       (if (< len dir-len)
131                         (setq rev-dir (nthcdr (- dir-len len) rev-dir))
132                         (setq path (subseq path 0 dir-len)))
133                       (loop for pp on (reverse path) until (equalp pp rev-dir)
134                          do (pop rev-dir))))))))
135    (unless (eq host :unknown)
136      (make-pathname :host host :directory (reverse rev-dir)))))
137
138
139(defun report-coverage (output-file &key (external-format :default))
140  "Print a code coverage report of all instrumented files into DIRECTORY.
141If DIRECTORY does not exist, it will be created. The main report will be
142printed to the file cover-index.html. The external format of the source
143files can be specified with the EXTERNAL-FORMAT parameter.
144"
145  (let* ((paths)
146         (directory (make-pathname :name nil :type nil :defaults output-file))
147         (coverage-dir (common-coverage-directory)))
148    (ensure-directories-exist directory)
149    (loop for data in *code-covered-functions*
150      as file = (and (consp data)
151                     (or (probe-file (car data))
152                         (progn (warn "Cannot find ~s" (car data)) nil)))
153      do (when file
154           (let* ((src-name (enough-namestring file coverage-dir))
155                  (html-name (substitute #\_ #\: (substitute #\_ #\. (substitute #\_ #\/ src-name)))))
156             (with-open-file (stream (make-pathname :name html-name :type "html" :defaults directory)
157                                     :direction :output
158                                     :if-exists :supersede
159                                     :if-does-not-exist :create)
160               (report-file-coverage file (cdr data) stream external-format))
161             (push (list* src-name html-name (cdr data)) paths))))
162    (setq paths (sort paths #'string< :key #'car))
163    (when (null paths)
164      (error "No code coverage data available"))
165    (let ((index-file (merge-pathnames output-file "index.html")))
166      (with-open-file (stream index-file
167                              :direction :output
168                              :if-exists :supersede
169                              :if-does-not-exist :create)
170        (write-coverage-styles stream)
171        (unless paths
172          (warn "No coverage data found for any file, producing an empty report. Maybe you forgot to (SETQ CCL::*COMPILE-CODE-COVERAGE* T) before compiling?")
173          (format stream "<h3>No code coverage data found.</h3>")
174          (return-from report-coverage))
175        (format stream "<table class='summary'>")
176        (coverage-stats-head-html stream)
177        (loop for prev = nil then source-file
178          for (source-file report-name . functions) in paths
179          for even = nil then (not even)
180          do (when (or (null prev)
181                       (not (equal (pathname-directory (pathname source-file))
182                                   (pathname-directory (pathname prev)))))
183               (format stream "<tr class='subheading'><td colspan='11'>~A</td></tr>~%"
184                       (namestring (make-pathname :name nil :type nil :defaults source-file))))
185          do (coverage-stats-data-html stream source-file functions even report-name))
186        (format stream "</table>"))
187      index-file)))
188
189(defun colorize-function (function styles)
190  (let ((note (function-source-note function)))
191    ;; Change coverage flag to 'full if all subforms are covered.
192    (labels ((rec (note)
193               (when note
194                 (if (code-note-code-coverage note)
195                   (let ((subnotes (code-note-subform-notes note)))
196                     (map nil #'rec subnotes)
197                     (unless (find 'full subnotes :test #'neq
198                                   :key #'code-note-code-coverage)
199                       (setf (code-note-code-coverage note) 'full)))
200                   #+gz
201                   (let ((subnotes (code-note-subform-notes note)))
202                     (unless  (every #'(lambda (subnote)
203                                         (null (code-note-code-coverage subnote)))
204                                     subnotes)
205                       (warn "~s: Covered internal subnote in ~s" function note)
206                       #+no (map nil #'show-notes subnotes))
207                     (map nil #'rec subnotes))))))
208      (rec note))
209    ;; Now actually change text styles, from outside in.
210    (labels ((rec (note)
211               (let* ((style (case (code-note-code-coverage note)
212                              ((full) $totally-covered-style)
213                              ((nil) $not-executed-style)
214                              (t $partially-covered-style))))
215                 (when (source-note-p note)
216                   (fill styles style
217                         :start (source-note-start-pos note)
218                         :end (source-note-end-pos note)))
219                 (when (or (eq style $partially-covered-style)
220                           ;; If not a source note, descend in case have some subnotes
221                           ;; that can be showna
222                           (not (source-note-p note)))
223                   (map nil #'rec (code-note-subform-notes note))))))
224      (rec note))))
225
226(defun colorize-functions (functions styles)
227  (map nil #'(lambda (function) (colorize-function function styles)) functions))
228
229(defun report-file-coverage (file functions html-stream external-format)
230  "Print a code coverage report of FILE into the stream HTML-STREAM."
231  (format html-stream "<html><head>")
232  (write-coverage-styles html-stream)
233  (format html-stream "</head><body>")
234  (let* ((source (with-open-file (s file :external-format external-format)
235                   (let ((string (make-string (file-length s))))
236                     (read-sequence string s)
237                     string)))
238         (styles (make-array (length source)
239                             :initial-element 0
240                             :element-type '(unsigned-byte 2))))
241    (colorize-functions functions styles)
242    (print-coverage-report html-stream file styles source functions)
243    (format html-stream "</body></html>")))
244
245(defun print-coverage-report (html-stream file styles source functions)
246  (let ((*print-case* :downcase))
247    (format html-stream "<h3>Coverage report: ~a <br />~%</h3>~%" file)
248
249    (format html-stream "<table class='summary'>")
250    (coverage-stats-head-html html-stream)
251    (coverage-stats-data-html html-stream file functions)
252    (format html-stream "</table>")
253
254    (format html-stream "<div class='key'><b>Key</b><br />~%")
255    (format html-stream "<div class='state-~a'>Fully covered - every single instruction executed</div>" $totally-covered-style)
256    (format html-stream "<div class='state-~a'>Partly covered - entered but some subforms not executed</div>" $partially-covered-style)
257    (format html-stream "<div class='state-~a'>Never entered - not a single instruction executed</div>" $not-executed-style)
258    (format html-stream "<p></p><div><code>~%")
259
260    (flet ((line (line)
261             (unless (eql line 0)
262               (format html-stream "</span>"))
263             (incf line)
264             (format html-stream "</code></div></nobr>~%<nobr><div class='source'><div class='line-number'><code>~A</code></div><code>&#160;" line)
265             line))
266      (loop with line = (line 0) with col = 0
267        for last-style = nil then style
268        for char across source
269        for style across styles
270        do (unless (eq style last-style)
271             (when last-style
272               (format html-stream "</span>"))
273             (format html-stream "<span class='state-~a'>" style))
274        do (case char
275             ((#\Newline)
276              (setq style nil)
277              (setq col 0)
278              (setq line (line line)))
279             ((#\Space)
280              (incf col)
281              (write-string "&#160;" html-stream))
282             ((#\Tab)
283              (dotimes (i (- 8 (mod col 8)))
284                (incf col)
285                (write-string "&#160;" html-stream)))
286             (t
287              (incf col)
288              (if (alphanumericp char)
289                (write-char char html-stream)
290                (format html-stream "&#~D;" (char-code char))))))
291      (format html-stream "</code></div>"))))
292
293
294(defun coverage-stats-head-html (html-stream)
295  (format html-stream "<tr class='head-row'><td></td><td class='main-head' colspan='3'>Expressions</td><td class='main-head' colspan='7'>Functions</td></tr>")
296  (format html-stream "<tr class='head-row'>~{<td width='60px'>~A</td>~}</tr>"
297          (list "Source file"
298                "Total" "Covered" "% covered"
299                "Total" "Fully covered" "% fully covered" "Partly covered" "% partly covered" "Not entered" "% not entered")))
300
301(defun coverage-stats-data-html (html-stream source-file functions &optional evenp report-name)
302  (format html-stream "<tr class='~:[odd~;even~]'>" evenp)
303  (if report-name
304    (format html-stream "<td class='text-cell'><a href='~a.html'>~a</a></td>" report-name source-file)
305    (format html-stream "<td class='text-cell'>~a</td>" source-file))
306  (format html-stream "~{<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td>~}"
307          (count-covered-expressions functions))
308  (destructuring-bind (total . counts) (count-covered-functions functions)
309    (format html-stream "<td>~:[-~;~:*~a~]</td>~{<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td>~}</tr>"
310            total counts)))
311
312(defun count-covered-functions (functions)
313  (let ((fully 0) (partly 0) (never 0) (total 0))
314    (map nil #'(lambda (function)
315                 (let ((note (function-source-note function)))
316                   (when note
317                     (incf total)
318                     (case (code-note-code-coverage note)
319                       ((full) (incf fully))
320                       ((nil) (incf never))
321                       (t (incf partly))))))
322         functions)
323    (list total
324          fully (* 100.0 (/ fully total))
325          partly (* 100.0 (/ partly total))
326          never (* 100.0 (/ never total)))))
327
328(defun count-covered-expressions (functions)
329  (let ((covered 0) (total 0))
330    (map nil #'(lambda (function)
331                 (labels ((rec (note)
332                            (when note
333                              (incf total)
334                              (when (code-note-code-coverage note)
335                                (incf covered))
336                              (map nil #'rec (code-note-subform-notes note)))))
337                   (rec (function-source-note function))))
338         functions)
339    (list total covered  (* 100.0d0 (/ covered total)))))
340
341
342(defun write-coverage-styles (html-stream)
343  (format html-stream "<style type='text/css'>
344*.state-~a { background-color: #ffaaaa }
345*.state-~a { background-color: #aaffaa }
346*.state-~a { background-color: #44dd44 }
347div.key { margin: 20px; width: 88ex }
348div.source { width: 98ex; background-color: #eeeeee; padding-left: 5px;
349             /* border-style: solid none none none; border-width: 1px;
350             border-color: #dddddd */ }
351
352*.line-number { color: #666666; float: left; width: 6ex; text-align: right; margin-right: 1ex; }
353
354table.summary tr.head-row { background-color: #aaaaff }
355table.summary tr td.text-cell { text-align: left }
356table.summary tr td.main-head { text-align: center }
357table.summary tr td { text-align: right }
358table.summary tr.even { background-color: #eeeeff }
359table.summary tr.subheading { background-color: #aaaaff}
360table.summary tr.subheading td { text-align: left; font-weight: bold; padding-left: 5ex; }
361</style>"
362          $not-executed-style
363          $partially-covered-style
364          $totally-covered-style
365          ))
Note: See TracBrowser for help on using the repository browser.