Commit | Line | Data |
---|---|---|
7ed9159a JY |
1 | ;;;; testcover.el -- Visual code-coverage tool |
2 | ||
3 | ;; Copyright (C) 2002 Free Software Foundation, Inc. | |
4 | ||
5 | ;; Author: Jonathan Yavner <jyavner@engineer.com> | |
6 | ;; Maintainer: Jonathan Yavner <jyavner@engineer.com> | |
7 | ;; Keywords: lisp utility | |
8 | ||
9 | ;; This file is part of GNU Emacs. | |
10 | ||
11 | ;; GNU Emacs is free software; you can redistribute it and/or modify | |
12 | ;; it under the terms of the GNU General Public License as published by | |
13 | ;; the Free Software Foundation; either version 2, or (at your option) | |
14 | ;; any later version. | |
15 | ||
16 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
19 | ;; GNU General Public License for more details. | |
20 | ||
21 | ;; You should have received a copy of the GNU General Public License | |
22 | ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
23 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
24 | ;; Boston, MA 02111-1307, USA. | |
25 | ||
26 | ||
27 | ;;; Commentary: | |
28 | ||
29 | ;; * Use `testcover-start' to instrument a Lisp file for coverage testing. | |
30 | ;; * Use `testcover-mark-all' to add overlay "splotches" to the Lisp file's | |
31 | ;; buffer to show where coverage is lacking. Normally, a red splotch | |
32 | ;; indicates the form was never evaluated; a brown splotch means it always | |
33 | ;; evaluted to the same value. | |
34 | ;; * Use `testcover-next-mark' (bind it to a key!) to jump to the next spot | |
35 | ;; that has a splotch. | |
36 | ||
37 | ;; * Basic algorithm: use `edebug' to mark up the function text with | |
38 | ;; instrumentation callbacks, then replace edebug's callbacks with ours. | |
39 | ;; * To show good coverage, we want to see two values for every form, except | |
40 | ;; functions that always return the same value and `defconst' variables | |
41 | ;; need show only value for good coverage. To avoid the brown splotch, the | |
42 | ;; definitions for constants and 1-valued functions must precede the | |
43 | ;; references. | |
44 | ;; * Use the macro `1value' in your Lisp code to mark spots where the local | |
45 | ;; code environment causes a function or variable to always have the same | |
46 | ;; value, but the function or variable is not intrinsically 1-valued. | |
47 | ;; * Use the macro `noreturn' in your Lisp code to mark function calls that | |
48 | ;; never return, because of the local code environment, even though the | |
49 | ;; function being called is capable of returning in other cases. | |
50 | ||
51 | ;; Problems: | |
52 | ;; * To detect different values, we store the form's result in a vector and | |
53 | ;; compare the next result using `equal'. We don't copy the form's | |
54 | ;; result, so if caller alters it (`setcar', etc.) we'll think the next | |
55 | ;; call has the same value! Also, equal thinks two strings are the same | |
56 | ;; if they differ only in properties. | |
57 | ;; * Because we have only a "1value" class and no "always nil" class, we have | |
58 | ;; to treat as 1-valued any `and' whose last term is 1-valued, in case the | |
59 | ;; last term is always nil. Example: | |
60 | ;; (and (< (point) 1000) (forward-char 10)) | |
61 | ;; This form always returns nil. Similarly, `if' and `cond' are | |
62 | ;; treated as 1-valued if all clauses are, in case those values are | |
63 | ;; always nil. | |
64 | ||
65 | (require 'edebug) | |
66 | (provide 'testcover) | |
67 | ||
68 | ||
69 | ;;;========================================================================== | |
70 | ;;; User options | |
71 | ;;;========================================================================== | |
72 | ||
73 | (defgroup testcover nil | |
74 | "Code-coverage tester" | |
75 | :group 'lisp | |
76 | :prefix "testcover-" | |
77 | :version "21.1") | |
78 | ||
79 | (defcustom testcover-constants | |
80 | '(nil t emacs-build-time emacs-version emacs-major-version | |
81 | emacs-minor-version) | |
82 | "Variables whose values never change. No brown splotch is shown for | |
83 | these. This list is quite incomplete!" | |
84 | :group 'testcover | |
85 | :type '(repeat variable)) | |
86 | ||
87 | (defcustom testcover-1value-functions | |
88 | '(backward-char barf-if-buffer-read-only beginning-of-line | |
89 | buffer-disable-undo buffer-enable-undo current-global-map deactivate-mark | |
7119cefe JY |
90 | delete-char delete-region ding error forward-char function* insert |
91 | insert-and-inherit kill-all-local-variables lambda mapc narrow-to-region | |
92 | noreturn push-mark put-text-property run-hooks set-text-properties signal | |
7ed9159a JY |
93 | substitute-key-definition suppress-keymap throw undo use-local-map while |
94 | widen yank) | |
95 | "Functions that always return the same value. No brown splotch is shown | |
96 | for these. This list is quite incomplete! Notes: Nobody ever changes the | |
97 | current global map. The macro `lambda' is self-evaluating, hence always | |
98 | returns the same value (the function it defines may return varying values | |
99 | when called)." | |
100 | :group 'testcover | |
101 | :type 'hook) | |
102 | ||
103 | (defcustom testcover-noreturn-functions | |
104 | '(error noreturn throw signal) | |
105 | "Subset of `testcover-1value-functions' -- these never return. We mark | |
106 | them as having returned nil just before calling them." | |
107 | :group 'testcover | |
108 | :type 'hook) | |
109 | ||
110 | (defcustom testcover-compose-functions | |
111 | '(+ - * / length list make-keymap make-sparse-keymap message propertize | |
112 | replace-regexp-in-string run-with-idle-timer | |
113 | set-buffer-modified-p) | |
114 | "Functions that are 1-valued if all their args are either constants or | |
115 | calls to one of the `testcover-1value-functions', so if that's true then no | |
116 | brown splotch is shown for these. This list is quite incomplete! Most | |
117 | side-effect-free functions should be here." | |
118 | :group 'testcover | |
119 | :type 'hook) | |
120 | ||
121 | (defcustom testcover-progn-functions | |
122 | '(define-key fset function goto-char or overlay-put progn save-current-buffer | |
123 | save-excursion save-match-data save-restriction save-selected-window | |
124 | save-window-excursion set set-default setq setq-default | |
125 | with-output-to-temp-buffer with-syntax-table with-temp-buffer | |
126 | with-temp-file with-temp-message with-timeout) | |
127 | "Functions whose return value is the same as their last argument. No | |
128 | brown splotch is shown for these if the last argument is a constant or a | |
129 | call to one of the `testcover-1value-functions'. This list is probably | |
130 | incomplete! Note: `or' is here in case the last argument is a function that | |
131 | always returns nil." | |
132 | :group 'testcover | |
133 | :type 'hook) | |
134 | ||
135 | (defcustom testcover-prog1-functions | |
136 | '(prog1 unwind-protect) | |
137 | "Functions whose return value is the same as their first argument. No | |
138 | brown splotch is shown for these if the first argument is a constant or a | |
139 | call to one of the `testcover-1value-functions'." | |
140 | :group 'testcover | |
141 | :type 'hook) | |
142 | ||
143 | (defface testcover-nohits-face | |
144 | '((t (:background "DeepPink2"))) | |
145 | "Face for forms that had no hits during coverage test" | |
146 | :group 'testcover) | |
147 | ||
148 | (defface testcover-1value-face | |
149 | '((t (:background "Wheat2"))) | |
150 | "Face for forms that always produced the same value during coverage test" | |
151 | :group 'testcover) | |
152 | ||
153 | ||
154 | ;;;========================================================================= | |
155 | ;;; Other variables | |
156 | ;;;========================================================================= | |
157 | ||
158 | (defvar testcover-module-constants nil | |
159 | "Symbols declared with defconst in the last file processed by | |
160 | `testcover-start'.") | |
161 | ||
162 | (defvar testcover-module-1value-functions nil | |
163 | "Symbols declared with defun in the last file processed by | |
164 | `testcover-start', whose functions always return the same value.") | |
165 | ||
166 | (defvar testcover-vector nil | |
167 | "Locally bound to coverage vector for function in progress.") | |
168 | ||
169 | ||
170 | ;;;========================================================================= | |
171 | ;;; Add instrumentation to your module | |
172 | ;;;========================================================================= | |
173 | ||
174 | ;;;###autoload | |
175 | (defun testcover-start (filename &optional byte-compile) | |
176 | "Uses edebug to instrument all macros and functions in FILENAME, then | |
177 | changes the instrumentation from edebug to testcover--much faster, no | |
178 | problems with type-ahead or post-command-hook, etc. If BYTE-COMPILE is | |
179 | non-nil, byte-compiles each function after instrumenting." | |
180 | (interactive "f") | |
181 | (let ((buf (find-file filename)) | |
182 | (load-read-function 'testcover-read) | |
183 | (edebug-all-defs t)) | |
184 | (setq edebug-form-data nil | |
185 | testcover-module-constants nil | |
186 | testcover-module-1value-functions nil) | |
187 | (eval-buffer buf)) | |
188 | (when byte-compile | |
189 | (dolist (x (reverse edebug-form-data)) | |
190 | (when (fboundp (car x)) | |
191 | (message "Compiling %s..." (car x)) | |
192 | (byte-compile (car x)))))) | |
193 | ||
194 | ;;;###autoload | |
195 | (defun testcover-this-defun () | |
196 | "Start coverage on function under point." | |
197 | (interactive) | |
198 | (let* ((edebug-all-defs t) | |
199 | (x (symbol-function (eval-defun nil)))) | |
200 | (testcover-reinstrument x) | |
201 | x)) | |
202 | ||
203 | (defun testcover-read (&optional stream) | |
204 | "Read a form using edebug, changing edebug callbacks to testcover callbacks." | |
205 | (let ((x (edebug-read stream))) | |
206 | (testcover-reinstrument x) | |
207 | x)) | |
208 | ||
209 | (defun testcover-reinstrument (form) | |
210 | "Reinstruments FORM to use testcover instead of edebug. This function | |
211 | modifies the list that FORM points to. Result is non-nil if FORM will | |
212 | always return the same value." | |
213 | (let ((fun (car-safe form))) | |
214 | (cond | |
215 | ((not fun) ;Atom | |
216 | (or (not (symbolp form)) | |
217 | (memq form testcover-constants) | |
218 | (memq form testcover-module-constants))) | |
219 | ((consp fun) ;Embedded list | |
220 | (testcover-reinstrument fun) | |
221 | (testcover-reinstrument-list (cdr form)) | |
222 | nil) | |
223 | ((or (memq fun testcover-1value-functions) | |
224 | (memq fun testcover-module-1value-functions)) | |
225 | ;;Always return same value | |
226 | (testcover-reinstrument-list (cdr form)) | |
227 | t) | |
228 | ((memq fun testcover-progn-functions) | |
229 | ;;1-valued if last argument is | |
230 | (testcover-reinstrument-list (cdr form))) | |
231 | ((memq fun testcover-prog1-functions) | |
232 | ;;1-valued if first argument is | |
233 | (testcover-reinstrument-list (cddr form)) | |
234 | (testcover-reinstrument (cadr form))) | |
235 | ((memq fun testcover-compose-functions) | |
236 | ;;1-valued if all arguments are | |
237 | (setq fun t) | |
238 | (mapc #'(lambda (x) (setq fun (or (testcover-reinstrument x) fun))) | |
239 | (cdr form)) | |
240 | fun) | |
241 | ((eq fun 'edebug-enter) | |
242 | ;;(edebug-enter 'SYM ARGS #'(lambda nil FORMS)) | |
243 | ;; => (testcover-enter 'SYM #'(lambda nil FORMS)) | |
244 | (setcar form 'testcover-enter) | |
245 | (setcdr (nthcdr 1 form) (nthcdr 3 form)) | |
246 | (let ((testcover-vector (get (cadr (cadr form)) 'edebug-coverage))) | |
247 | (testcover-reinstrument-list (nthcdr 2 (cadr (nth 2 form)))))) | |
248 | ((eq fun 'edebug-after) | |
249 | ;;(edebug-after (edebug-before XXX) YYY FORM) | |
250 | ;; => (testcover-after YYY FORM), mark XXX as ok-coverage | |
251 | (unless (eq (cadr form) 0) | |
252 | (aset testcover-vector (cadr (cadr form)) 'ok-coverage)) | |
253 | (setq fun (nth 2 form)) | |
254 | (setcdr form (nthcdr 2 form)) | |
255 | (if (not (memq (car-safe (nth 2 form)) testcover-noreturn-functions)) | |
256 | (setcar form 'testcover-after) | |
257 | ;;This function won't return, so set the value in advance | |
258 | ;;(edebug-after (edebug-before XXX) YYY FORM) | |
259 | ;; => (progn (edebug-after YYY nil) FORM) | |
260 | (setcar form 'progn) | |
261 | (setcar (cdr form) `(testcover-after ,fun nil))) | |
262 | (when (testcover-reinstrument (nth 2 form)) | |
263 | (aset testcover-vector fun '1value))) | |
264 | ((eq fun 'defun) | |
265 | (if (testcover-reinstrument-list (nthcdr 3 form)) | |
266 | (push (cadr form) testcover-module-1value-functions))) | |
267 | ((eq fun 'defconst) | |
268 | ;;Define this symbol as 1-valued | |
269 | (push (cadr form) testcover-module-constants) | |
270 | (testcover-reinstrument-list (cddr form))) | |
271 | ((memq fun '(dotimes dolist)) | |
272 | ;;Always returns third value from SPEC | |
273 | (testcover-reinstrument-list (cddr form)) | |
274 | (setq fun (testcover-reinstrument-list (cadr form))) | |
275 | (if (nth 2 (cadr form)) | |
276 | fun | |
277 | ;;No third value, always returns nil | |
278 | t)) | |
279 | ((memq fun '(let let*)) | |
280 | ;;Special parsing for second argument | |
281 | (mapc 'testcover-reinstrument-list (cadr form)) | |
282 | (testcover-reinstrument-list (cddr form))) | |
283 | ((eq fun 'if) | |
284 | ;;1-valued if both THEN and ELSE clauses are | |
285 | (testcover-reinstrument (cadr form)) | |
286 | (let ((then (testcover-reinstrument (nth 2 form))) | |
287 | (else (testcover-reinstrument-list (nthcdr 3 form)))) | |
288 | (and then else))) | |
289 | ((memq fun '(when unless and)) | |
290 | ;;1-valued if last clause of BODY is | |
291 | (testcover-reinstrument-list (cdr form))) | |
292 | ((eq fun 'cond) | |
293 | ;;1-valued if all clauses are | |
294 | (testcover-reinstrument-clauses (cdr form))) | |
295 | ((eq fun 'condition-case) | |
296 | ;;1-valued if BODYFORM is and all HANDLERS are | |
297 | (let ((body (testcover-reinstrument (nth 2 form))) | |
298 | (errs (testcover-reinstrument-clauses (mapcar #'cdr | |
299 | (nthcdr 3 form))))) | |
300 | (and body errs))) | |
301 | ((eq fun 'quote) | |
302 | ;;Don't reinstrument what's inside! | |
303 | ;;This doesn't apply within a backquote | |
304 | t) | |
305 | ((eq fun '\`) | |
306 | ;;Quotes are not special within backquotes | |
307 | (let ((testcover-1value-functions | |
308 | (cons 'quote testcover-1value-functions))) | |
309 | (testcover-reinstrument (cadr form)))) | |
310 | ((eq fun '\,) | |
311 | ;;In commas inside backquotes, quotes are special again | |
312 | (let ((testcover-1value-functions | |
313 | (remq 'quote testcover-1value-functions))) | |
314 | (testcover-reinstrument (cadr form)))) | |
315 | ((memq fun '(1value noreturn)) | |
316 | ;;Hack - pretend the arg is 1-valued here | |
317 | (if (symbolp (cadr form)) ;A pseudoconstant variable | |
318 | t | |
319 | (let ((testcover-1value-functions | |
320 | (cons (car (cadr form)) testcover-1value-functions))) | |
321 | (testcover-reinstrument (cadr form))))) | |
322 | (t ;Some other function or weird thing | |
323 | (testcover-reinstrument-list (cdr form)) | |
324 | nil)))) | |
325 | ||
326 | (defun testcover-reinstrument-list (list) | |
327 | "Reinstruments each form in LIST to use testcover instead of edebug. | |
328 | This function modifies the forms in LIST. Result is `testcover-reinstrument's | |
329 | value for the last form in LIST. If the LIST is empty, its evaluation will | |
330 | always be nil, so we return t for 1-valued." | |
331 | (let ((result t)) | |
332 | (while (consp list) | |
333 | (setq result (testcover-reinstrument (pop list)))) | |
334 | result)) | |
335 | ||
336 | (defun testcover-reinstrument-clauses (clauselist) | |
337 | "Reinstruments each list in CLAUSELIST. Result is t if every | |
338 | clause is 1-valued." | |
339 | (let ((result t)) | |
340 | (mapc #'(lambda (x) | |
341 | (setq result (and (testcover-reinstrument-list x) result))) | |
342 | clauselist) | |
343 | result)) | |
344 | ||
345 | (defun testcover-end (buffer) | |
346 | "Turn off instrumentation of all macros and functions in FILENAME." | |
347 | (interactive "b") | |
348 | (let ((buf (find-file-noselect buffer))) | |
349 | (eval-buffer buf t))) | |
350 | ||
351 | (defmacro 1value (form) | |
352 | "For code-coverage testing, indicate that FORM is expected to always have | |
353 | the same value." | |
354 | form) | |
355 | ||
356 | (defmacro noreturn (form) | |
357 | "For code-coverage testing, indicate that FORM will always signal an error." | |
358 | form) | |
359 | ||
360 | ||
361 | ;;;========================================================================= | |
362 | ;;; Accumulate coverage data | |
363 | ;;;========================================================================= | |
364 | ||
365 | (defun testcover-enter (testcover-sym testcover-fun) | |
366 | "Internal function for coverage testing. Invokes TESTCOVER-FUN while | |
367 | binding `testcover-vector' to the code-coverage vector for TESTCOVER-SYM | |
368 | \(the name of the current function)." | |
369 | (let ((testcover-vector (get testcover-sym 'edebug-coverage))) | |
370 | (funcall testcover-fun))) | |
371 | ||
372 | (defun testcover-after (idx val) | |
373 | "Internal function for coverage testing. Returns VAL after installing it in | |
374 | `testcover-vector' at offset IDX." | |
375 | (cond | |
376 | ((eq (aref testcover-vector idx) 'unknown) | |
377 | (aset testcover-vector idx val)) | |
378 | ((not (equal (aref testcover-vector idx) val)) | |
379 | (aset testcover-vector idx 'ok-coverage))) | |
380 | val) | |
381 | ||
382 | ||
383 | ;;;========================================================================= | |
384 | ;;; Display the coverage data as color splotches on your code. | |
385 | ;;;========================================================================= | |
386 | ||
387 | (defun testcover-mark (def) | |
388 | "Marks one DEF (a function or macro symbol) to highlight its contained forms | |
389 | that did not get completely tested during coverage tests. | |
390 | A marking of testcover-nohits-face (default = red) indicates that the | |
391 | form was never evaluated. A marking of testcover-1value-face | |
392 | \(default = tan) indicates that the form always evaluated to the same value. | |
393 | The forms throw, error, and signal are not marked. They do not return and | |
394 | would always get a red mark. Some forms that always return the same | |
395 | value (e.g., setq of a constant), always get a tan mark that can't be | |
396 | eliminated by adding more test cases." | |
397 | (let* ((data (get def 'edebug)) | |
398 | (def-mark (car data)) | |
399 | (points (nth 2 data)) | |
400 | (len (length points)) | |
401 | (changed (buffer-modified-p)) | |
402 | (coverage (get def 'edebug-coverage)) | |
403 | ov j item) | |
404 | (or (and def-mark points coverage) | |
405 | (error "Missing edebug data for function %s" def)) | |
7119cefe JY |
406 | (when len |
407 | (set-buffer (marker-buffer def-mark)) | |
408 | (mapc 'delete-overlay | |
409 | (overlays-in def-mark (+ def-mark (aref points (1- len)) 1))) | |
410 | (while (> len 0) | |
411 | (setq len (1- len) | |
412 | data (aref coverage len)) | |
413 | (when (and (not (eq data 'ok-coverage)) | |
414 | (setq j (+ def-mark (aref points len)))) | |
7ed9159a JY |
415 | (setq ov (make-overlay (1- j) j)) |
416 | (overlay-put ov 'face | |
417 | (if (memq data '(unknown 1value)) | |
418 | 'testcover-nohits-face | |
419 | 'testcover-1value-face)))) | |
7119cefe | 420 | (set-buffer-modified-p changed)))) |
7ed9159a JY |
421 | |
422 | (defun testcover-mark-all (&optional buffer) | |
423 | "Mark all forms in BUFFER that did not get completley tested during | |
7119cefe | 424 | coverage tests. This function creates many overlays." |
7ed9159a JY |
425 | (interactive "b") |
426 | (if buffer | |
427 | (switch-to-buffer buffer)) | |
428 | (goto-char 1) | |
429 | (dolist (x edebug-form-data) | |
7119cefe | 430 | (if (get (car x) 'edebug) |
7ed9159a JY |
431 | (testcover-mark (car x))))) |
432 | ||
433 | (defun testcover-unmark-all (buffer) | |
434 | "Remove all overlays from FILENAME." | |
435 | (interactive "b") | |
436 | (condition-case nil | |
437 | (progn | |
438 | (set-buffer buffer) | |
439 | (mapc 'delete-overlay (overlays-in 1 (buffer-size)))) | |
440 | (error nil))) ;Ignore "No such buffer" errors | |
441 | ||
442 | (defun testcover-next-mark () | |
443 | "Moves point to next line in current buffer that has a splotch." | |
444 | (interactive) | |
445 | (goto-char (next-overlay-change (point))) | |
446 | (end-of-line)) | |
447 | ||
448 | ;; testcover.el ends here. |