1 ;;; regress.el --- Regression test harness for Emacs Lisp code
3 ;; Copyright (C) 1997, 2004 by Wayne Mesard
5 ;; Author: Wayne Mesard <wmesard@sgi.com>
6 ;; Tom Breton <tob@world.std.com>
7 ;; Last modified: 1999-07-10
9 ;; Keywords: lisp, tools, maint
11 ;; This program 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)
16 ;; This program 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.
21 ;; A copy of the GNU General Public License can be obtained from the
22 ;; Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
24 ;;$$ Move the documentation into its own file.
28 ;; This module provides support for writing and executing regression tests
29 ;; for Emacs Lisp code. When people bother to write regression tests at all,
30 ;; they're typically included as off-hand comments:
33 ;; ;; (add1 -9) ==> -8
37 ;; There are a couple of problems with this:
38 ;; o these tests are often treated as a supplement a textual comment,
39 ;; so they may not be very rigorous or thorough.
40 ;; o these tests won't get run very often; so if something breaks, it
41 ;; may not get detected until days or weeks later.
42 ;; o the motivation for a test case itself may be unclear, so when
43 ;; it returns a surprising value down the road, the programmer may
44 ;; not remember what the test was for in the first place.
46 ;; This module makes it easy for Emacs lisp programmers to write
47 ;; complete, well-documented regression tests and to run them often
48 ;; during the developement and enhancement processes.
51 ;; 1. The programmer puts one or more test suites directly in the lisp
52 ;; file, wrapped inside an "eval-when-compile" special form. This
53 ;; causes the test suites to be available when .el file is loaded
54 ;; (or when the buffer is evaluated), but not when the .elc file is
57 ;; 2. The programmer runs the tests in one of two ways:
58 ;; a. Interactively, with the M-x regress command.
59 ;; b. Automatically, every time the file is evaluated, by putting
60 ;; a small bit of code at the end of the file.
62 ;; 3. If there are any regressions, a report is produced detailing the
65 ;; Here's the interface:
66 ;; M-x regress-insert-suite
67 ;; Insert a template for a new suite of tests. Presumably, a
68 ;; suite appears immediately above the function or functions
69 ;; that are being tested; but it can appear anywhere--even in a
71 ;; M-x regress-insert-call
72 ;; Insert code which will cause regression tests to be run when
73 ;; the .el file is loaded if and only if the "regress" module
74 ;; has also been loaded. Presumably, this will appear once at
75 ;; the end of the .el file; but it can appear anywhere, as many
76 ;; times as needed, or not at all if the tests will be run in
78 ;; Run one or more test suites. Report any failures.
80 ;; This doesn't actually delete the test suites, but it does
81 ;; cause M-x regress to forget that they are test suites so that
82 ;; they won't appear in the list of suites that can be run.
83 ;; This can be useful when the programmer has finished work on
84 ;; one module and is moving on to another. (The test suites
85 ;; will get ``remembered'' if the .el file is evaluated again.)
87 ;; Here's the data structures:
89 ;; test-suite := ([description] [test...])
90 ;; test := ([description] probe [':test'] grader)
91 ;; description := <a string>
92 ;; probe := a Lisp expression to perform the actual test.
93 ;; grader := a Lisp expression to evaluate whether or not the
94 ;; probe was successful.
96 ;; If <grader> is preceded by the keyword :test,
97 ;; <grader> itself is evaluated, and the test
98 ;; passes if the result of non-nil. For
99 ;; convenience, during the evaluation of <grader>,
100 ;; a special variable, RESULT, will be bound to the
101 ;; result of <probe>.
103 ;; Otherwise the test will pass if the result of
104 ;; <probe> is equal to <grader>, according to the
105 ;; elisp function 'equal'.
107 ;; Failure indications, new in version 1.5.0.
109 ;; You can use regress without knowing about failure indications, and
110 ;; it's probably best to ignore them when you first use regress. But
111 ;; as your tests become more complicated, you may wish for an easy
112 ;; way to know exactly what part of your tests failed. One way to do
113 ;; it is to assign to the special variable FAILURE-INDICATION. If a
114 ;; regression test fails and FAILURE-INDICATION is non-nil, it will
115 ;; be printed along with the results.
118 ;; Here are some contrived, simple examples. Much of regress.el
119 ;; itself contains regression tests. Search for "eval-when-compile",
124 ;; This code will not appear in the compiled (.elc) file
125 (put 'demo1 'regression-suite t)
126 (put 'demo2 'regression-suite t)
127 (put 'demo3 'regression-suite t)
128 (put 'demo4 'regression-suite t)
129 (put 'demo6 'regression-suite t)
132 '("three ways of writing the same test"
138 (;; the description string is optional
143 ("Implicit test with a calculated comparand"
154 ;; This test contains a deliberate error, so you can see what an error
155 ;; report looks like.
156 ("Deliberate error to demonstrate report format"
162 ;; each test is run inside of a "save-excursion", so set-buffer et al
166 '("test uses a temp buffer; grader looks at the buffer to see how we did"
167 ((progn (set-buffer (get-buffer-create "regress-demo"))
171 ;; If our string appears right before point, then the insert succeeded
172 ;; Note that the result of the probe is not important; we're looking
173 ;; at what the probe did to the current buffer
177 (and (re-search-backward "abc" nil t)
186 '("tests of setenv/getenv"
188 (setenv "regress" "foo")
190 (equal "foo" (getenv "regress"))
193 (setenv "regress" nil)
195 (null (getenv "regress"))
200 (equal RESULT user-login-name)
205 '("Demonstrations of error recognition"
207 ( "Expect an error of some kind, using regress-got-error"
208 (+ "Not a number" "Not one either")
210 (regress-got-error RESULT))
212 ( "Expect a specific error."
213 (+ "Not a number" "Not one either")
215 (equal (car RESULT) 'wrong-type-argument))
217 ("DELIBERATE FAILURE: Demonstrate that an error thrown by the
218 grader expression itself will not masquerade as a successful test"
222 (error "Not a real error, but an incredible simulation")
229 '("Demonstrations of failure indication."
230 ("DELIBERATE FAILURE: demonstrate FAILURE-INDICATION"
233 (setq FAILURE-INDICATION
234 "Show this object if the test fails")
240 (setq FAILURE-INDICATION
241 "FAILURE-INDICATION is not seen if the test succeeds.")
256 (defvar regress-expert nil
257 "*If nil, \\[regress-insert-suite] will insert some helpful comments.
258 If not nil and not t, it will insert a one-line helpful comment.")
260 (defvar regress-default-variable-name t
261 "*If non-nil, \\[regress-insert-suite] will attempt to supply a default name
262 for the new test suite.")
266 (defvar regress-error-buffer "*Regression Error*")
270 ;;Moved into interaction
271 (defun regress-insert-suite (name docstring update-call-site)
272 "Insert a template for a new test suite.
273 Prompts for the NAME of the variable to use, and for a short DOCSTRING
274 describing the purpose of the test suite.
275 If regress-expert (which see) is non-nil, some helpful comments are also
278 (let* ((var (read-from-minibuffer
279 "Variable name for this regression suite: "
280 (regress-default-variable-name)
282 (vname (symbol-name var))
284 (concat "Documentation: (default \"" vname "\"): ")))
287 (prin1-to-string (if (zerop (length doc)) vname doc))
288 (let ((loc (regress-call-site)))
290 (or current-prefix-arg
291 (y-or-n-p "Add to the regress call site below? ")))
296 (if (eq t update-call-site)
297 ;; for non-interactive calls (otherwise the caller would have to call
298 ;; regress-call-site itself).
299 (setq update-call-site (regress-call-site)))
302 "\n(eval\-when-compile"
303 "\n ;; This code will not appear in the compiled (.elc) file"
304 "\n (put '" name " 'regression-suite t)"
309 ((eq t regress-expert))
312 (insert "\n ;; ([description] probe grader)"))
316 "\n ;; Each test in the suite is of the form:"
317 "\n ;; ([description] probe grader)"
318 "\n ;; DESCRIPTION - string"
319 "\n ;; PROBE - a sexp which runs the actual test"
320 "\n ;; GRADER - the desired result or a sexp which determines"
334 (goto-char update-call-site)
339 (defun regress-call-site ()
341 (let ((regexp "(if (featurep 'regress)[\n\t ]*(regress"))
342 (and (re-search-forward regexp nil t)
343 (not (re-search-forward regexp nil t))
348 (defun regress-default-variable-name ()
349 (if regress-default-variable-name
350 (let ((str (if (looking-at "[\n\t ]*(defun[\t ]+\\([^\t ]+\\)")
351 (buffer-substring-no-properties
352 (match-beginning 1) (match-end 1))
354 (file-name-nondirectory
355 (file-name-sans-extension buffer-file-name)))
358 (cons (concat str "-regress") 0)))
362 (defun regress-insert-call (&rest suites)
363 "Inserts code to run one or more test SUITES.
364 The idea is that the programmer would put this at the end of the .el file."
365 (interactive (regress-prompt-for-suites "Insert" ))
366 (insert "\n;; Run diagnostics when this module is evaluated or compiled"
367 "\n;; if and only if the \"regress\" package is already loaded."
368 "\n;; This code will not appear in the compiled (.elc) file"
369 "\n(eval\-when-compile"
370 "\n (autoload 'regress \"regress\" \"run regression test suites\" t)
372 "\n (if (featurep 'regress)"
374 (mapconcat (function symbol-name) suites " ")
379 (defun regress-forget (&rest suites)
380 "Forget that a variable contains a test suite.
381 This can be handy if you're done working on one module that has regression
382 tests and want to move on to another."
383 (interactive (regress-prompt-for-suites "Forget"))
387 (put x 'regression-suite nil)))
392 ;;; Running a regression test
396 (defun regress-do-test (item description)
399 Return a list of failure-data if the test failed, otherwise return nil."
404 (FAILURE-INDICATION nil)
410 ;;Eval the probe expression.
413 ;;If probe made an error, take its value to be that error.
414 ;;The grader may be interested in exactly what the error is,
415 ;;and not trapping the error would stop the entire suite.
421 (if (regress-test-is-explicit-p item)
423 ;;An explicit grader succeeds if it returns non-nil
424 (let ((RESULT obtained))
427 ;;An implicit grader succeeds if it gives the same value
430 (eval (nth 2 item)))))
434 (list description item obtained FAILURE-INDICATION)
437 ;;If the grader had an error, catch it and return a special
440 (list description item obtained err))
445 (defun regress (&rest suites)
447 (mapcar (function symbol-value)
448 (regress-prompt-for-suites "Run" )))
449 (let ((description nil)
458 (setq suite (car suites)
460 (if (and (car suite) (not (stringp (car suite))))
461 (setq description "Untitled test suite")
462 (setq description (car suite)
465 (setq item (car suite))
466 ;; Untitled test (and no nil placeholder, so add the placeholder
467 (if (and (car item) (not (stringp (car item))))
468 (setq item (cons nil item)))
472 (regress-do-test item description))
477 failures (cons new-failure failures)
478 fail-count (1+ fail-count)
479 ;; only report the suite name the first time.
482 (setq suite (cdr suite)
483 test-count (1+ test-count)))
486 ;; there were no failures, simply record the suite title
487 (setq failures (cons description failures))))
489 (if (zerop fail-count)
490 (message (if (= 1 test-count)
491 "The single regression test ran successfully"
493 "Both regression tests ran successfully"
494 "All %d regression tests ran successfully"))
497 (message "%d failure%s detected"
499 (if (= 1 fail-count) "" "s"))
500 (regress-report test-count (reverse failures))
509 (defun regress-report (num-tests failures)
511 (with-output-to-temp-buffer regress-error-buffer
513 (if (stringp (car failures))
514 ;; this is not a failure, but the docstring from a suite
516 (regress-report-one-success (car failures))
517 (regress-report-one-failure (setq num-fails (1+ num-fails))
519 (setq failures (cdr failures)))
521 ;; Now do some post-processing to make it more readable
522 (set-buffer regress-error-buffer)
524 ;; Insert a header and center it
525 (goto-char (point-min))
526 (insert "*** Emacs Lisp Regression Test Report ***\nGenerated by: "
528 "\n" (current-time-string) "\nTests: "
529 (number-to-string num-tests)
531 (number-to-string num-fails)
534 (truncate (/ (float (* 100 (- num-tests num-fails)))
537 (center-region (point-min) (point))
540 (indent-rigidly (point) (point-max) 2)
542 ;; Unindent and bold the "count" lines
543 (goto-char (point-min))
544 (while (search-forward "\n __regressFAILURE: " nil t)
545 (replace-match "\nFailure #" nil t)
546 (beginning-of-line 2)
547 (put-text-property (1+ (match-beginning 0)) (1- (point)) 'face 'bold))
548 ;; Find the suite titles, remove the tag, bold and center the text
549 (goto-char (point-min))
550 (while (search-forward " __regressSUITE:" nil t)
551 (replace-match "" nil t)
552 (beginning-of-line 2)
553 (put-text-property (match-beginning 0) (1- (point)) 'face 'bold)
554 (center-region (match-beginning 0) (point)))
555 (goto-char (point-min))
556 ;; We don't want this indented.
557 (while (search-forward "\n __regressSUCCESS" nil t)
558 (replace-match "\nAll tests passed." nil t)
560 (goto-char (point-min))
563 (defun regress-report-one-success (docstring)
564 (princ "\n__regressSUITE: ")
568 (princ "__regressSUCCESS\n\n")
571 (defun regress-report-one-failure (count failure)
572 ;; failure is: (suite-docstring item ideal))
573 (let ((item (nth 1 failure)))
575 ;; This is the first failure in the set, so print the docstring
577 (princ "\n__regressSUITE: ")
578 (princ (car failure))
580 (princ "\n__regressFAILURE: ")
583 ;; This test has a docstring, so print it
584 (progn (princ "\n\nDescription:\n-----------\n")
587 (princ "\n\nTest:\n----\n")
589 (if (regress-test-is-explicit-p item)
591 (princ "\nRequirement:\n-----------\n")
594 (princ "\nExpected value:\n--------------\n")
598 (not (regress-test-is-explicit-p item))
599 (regress-sexp-contains 'RESULT (nth 3 item)))
600 ;; The test used the return value, so print it
602 (princ "\n\nActual Value:\n------------\n")
606 ;;Report a failure indication if there is one.
608 (>= (length failure) 4)
610 (princ "\n\nFailure indication:\n------------\n")
624 (defun regress-test-is-explicit-p (item)
625 "Non-nil if the grader in item is an explicit test."
626 (eq (nth 2 item) ':test))
630 ;; Used by the interactive functions to prompt for a list of suites
632 (defun regress-prompt-for-suites (verb)
640 (concat verb " test suite "
646 (function (lambda (x) (get x 'regression-suite)))
648 (setq lis (cons (intern nam) lis)))
653 (if (get x 'regression-suite)
654 (setq lis (cons x lis)))
661 ;; This code will not appear in the compiled (.elc) file
662 (put 'regress-sexp-contains-tests 'regression-suite t)
663 (defvar regress-sexp-contains-tests
664 '("regress-sexp-contains tests"
665 ((regress-sexp-contains 'foo '(foo man chu))
667 ((regress-sexp-contains 'foo '(find a (((buried foo)) man) chu))
669 ((regress-sexp-contains 'bar '(foo man chu))
671 ("Not good enough, the items are equal, but not eq"
672 (regress-sexp-contains '(man) '(foo (man) chu))
674 ("Not good enough, the strings are equal, but not eq"
675 (regress-sexp-contains "foo" '("foo" "man" "chu"))
677 ("The items are eq, so return t"
678 (let ((it '(this is a test)))
679 (regress-sexp-contains it (list 'abc it 'xyz)))
685 ;; Return t if ITEM appears in SEXP at any depth, nil if not.
687 (defun regress-sexp-contains (item sexp)
689 (and (not (atom sexp))
690 (or (regress-sexp-contains item (car sexp))
691 (regress-sexp-contains item (cdr sexp))))
695 ;;; Functions to help users easily grade expressions.
697 (defun regress-got-error (result)
698 "t if RESULT is any sort of error, otherwise nil.
700 Result is the result of a probe expression."
704 (symbolp (car result))
705 (get (car result) 'error-conditions)))
709 (defun regress-answer-parm (exp)
710 "Define a single test parameter within a grader function.
711 Helper for regress-define-grader-function."
713 `(,(car exp) nil ,(intern (concat "ask-" (symbol-name (car exp))))))
716 (defun regress-answer-test (name comparand &optional comparer)
717 "Define a single test within a grader function.
718 Helper for regress-define-grader-function.
720 If COMPARER is passed, it is used to compare NAME and COMPARAND,
721 otherwise equal is used."
725 ((ask-name-sym (intern-soft (concat "ask-" (symbol-name name))))
726 (comparer-sym (or comparer 'equal)))
730 (,comparer-sym ,comparand ,name)
734 (defmacro regress-define-grader-function
735 (function-name decomposition-list answerlist)
736 "Build a grader function named FUNCTION-NAME.
738 Requires the cl package.
740 The result of the probe, which must be a list, will be decomposed
741 according to DECOMPOSITION-LIST. Eg, if DECOMPOSITION-LIST is \(foo
742 bar\) and the result of the probe is \(1 2 3\), there will be an
743 object named foo with the value 1, and bar with the value 2.
745 ANSWERLIST is a list whose elements are of the form \(NAME TEST
746 &optional COMPARER\). NAME is the name of a parameter to
747 FUNCTION-NAME, which can be passed as \( ... :NAME value ... \). TEST
748 is arbitrary elisp code that will be tested against the parameter NAME
749 with 'equal. If COMPARER is given, it is used to compare NAME and
750 COMPARAND, otherwise equal is used
752 Except for the required parm RESULT, all parms to FUNCTION-NAME are
757 (result-sym (gensym))
768 ;;(regress-answer-test (car x) (cadr x))
769 (apply 'regress-answer-test x)
776 for X in decomposition-list
778 collect `(,X (nth ,I ,result-sym)))));;ch
782 `(defun* ,function-name
783 (,result-sym &optional &key;;ch
794 ;;; Regression testing on regress.el itself
798 ;; This code will not appear in the compiled (.elc) file
799 (autoload 'regress "regress" "run regression test suites" t)
800 (put 'regress-call-site-tests 'regression-suite t)
801 (defvar regress-call-site-tests
802 '("regress-call-site tests"
804 "Create the call site"
806 (set-buffer (get-buffer-create " regress-test-scratch"))
808 (regress-insert-call 'foobar 'biz)
809 (goto-char (point-min))
813 (string-match "(if (featurep 'regress)[\n\t ]*(regress foobar biz))"
816 ("Insert a new suite and get it added to the call site."
818 (set-buffer (get-buffer-create " regress-test-scratch"))
819 (regress-insert-suite "testme" "testmedoc" t))
822 "(if (featurep 'regress)[\n\t ]*(regress testme foobar biz))"
829 ;; This code will not appear in the compiled (.elc) file
830 (autoload 'regress "regress" "run regression test suites" t)
831 (put 'regress-call-site-all-in-1-test 'regression-suite t)
832 (defvar regress-call-site-all-in-1-test
833 '("regress-call-site tests all in 1 big ugly test"
836 ;; each test is run in a save-excursion, so set-buffer is safe
837 (set-buffer (get-buffer-create " regress-test-scratch"))
839 (regress-insert-call 'foobar 'biz)
840 (goto-char (point-min))
841 (regress-insert-suite "testme" "testmedoc" t)
845 "(if (featurep 'regress)[\n\t ]*(regress testme foobar biz))"
854 ;;demo5 can only be made if cl is available
859 ;;Define a grader function. This sort of grader function is
860 ;;useful for when you have to grade different parts of a complex
861 ;;result in different tests.
862 (regress-define-grader-function
864 ;;It will be named regress-demo5-grader
867 ;;This section says to decompose the result of probe, which
868 ;;must be a list, into 2 elements, my-first and my-second,
869 ;;which can be referenced in the next section.
872 ;;This says that the element my-first must be equal to the
873 ;;parameter the-first IF that parameter is passed otherwise we
874 ;;don't care. Similarly, my-second / the-second.
875 ( (the-first my-first)
876 (the-second my-second)))
880 "How to use a function defined by regress-define-grader-function."
882 ;;For simplicity, these examples use a literal as the probe.
883 ( "Test only the first element."
886 (regress-demo5-grader RESULT :the-first 5))
889 ( "Test only the second element."
892 (regress-demo5-grader RESULT :the-second 6))
898 (regress-demo5-grader RESULT :the-second 6)
899 (regress-demo5-grader RESULT :the-first 5)))
901 ( "Deliberate failure."
904 (regress-demo5-grader RESULT :the-first 1000))
907 (put 'demo5 'regression-suite t)
912 ;;; It's not a bug, it's a *feature*
918 ;;change-log-default-name: "regress.changelog"
921 ;;; regress.el ends here