Mercurial > emacs
changeset 112324:2b598aa5d397
Merge from mainline.
| author | Paul Eggert <eggert@cs.ucla.edu> |
|---|---|
| date | Thu, 13 Jan 2011 09:17:33 -0800 |
| parents | f3056cf0073a (current diff) cf323f3bfe7f (diff) |
| children | 36329d05ddec |
| files | ChangeLog Makefile.in configure configure.in lisp/dired.el src/image.c |
| diffstat | 34 files changed, 5375 insertions(+), 221 deletions(-) [+] |
line wrap: on
line diff
--- a/ChangeLog Tue Jan 11 22:13:06 2011 -0800 +++ b/ChangeLog Thu Jan 13 09:17:33 2011 -0800 @@ -1,4 +1,4 @@ -2011-01-11 Paul Eggert <eggert@cs.ucla.edu> +2011-01-13 Paul Eggert <eggert@cs.ucla.edu> * Makefile.in (GNULIB_MODULES): Change ftoastr to dtoastr. This avoids building ftoastr and ldtoastr, which aren't needed. See @@ -106,6 +106,15 @@ * make-dist: Also put into the distribution aclocal.m4, compile, depcomp, missing, and the files under lib/. +2011-01-13 Christian Ohler <ohler@gnu.org> + + * Makefile.in (INFO_FILES): Add ERT. + + * Makefile.in (check): Run tests in test/automated. + + * Makefile.in: + * configure.in: Add test/automated/Makefile. + 2011-01-07 Paul Eggert <eggert@cs.ucla.edu> * install-sh, mkinstalldirs, move-if-change: Update from master
--- a/Makefile.in Tue Jan 11 22:13:06 2011 -0800 +++ b/Makefile.in Thu Jan 13 09:17:33 2011 -0800 @@ -134,7 +134,7 @@ infodir=@infodir@ INFO_FILES=ada-mode auth autotype calc ccmode cl dbus dired-x ebrowse \ ede ediff edt eieio efaq eintr elisp emacs emacs-mime epa erc \ - eshell eudc flymake forms gnus idlwave info mairix-el \ + ert eshell eudc flymake forms gnus idlwave info mairix-el \ message mh-e newsticker nxml-mode org pcl-cvs pgg rcirc \ reftex remember sasl sc semantic ses sieve smtpmail speedbar \ tramp url vip viper widget woman @@ -267,7 +267,7 @@ SUBDIR = lib lib-src src lisp # The subdir makefiles created by config.status. -SUBDIR_MAKEFILES = lib/Makefile lib-src/Makefile doc/emacs/Makefile doc/misc/Makefile doc/lispref/Makefile doc/lispintro/Makefile src/Makefile oldXMenu/Makefile lwlib/Makefile leim/Makefile lisp/Makefile +SUBDIR_MAKEFILES = lib/Makefile lib-src/Makefile doc/emacs/Makefile doc/misc/Makefile doc/lispref/Makefile doc/lispintro/Makefile src/Makefile oldXMenu/Makefile lwlib/Makefile leim/Makefile lisp/Makefile test/automated/Makefile # Subdirectories to install, and where they'll go. # lib-src's makefile knows how to install it, so we don't do that here. @@ -395,7 +395,8 @@ $(srcdir)/oldXMenu/Makefile.in \ $(srcdir)/lwlib/Makefile.in \ $(srcdir)/leim/Makefile.in \ - $(srcdir)/lisp/Makefile.in + $(srcdir)/lisp/Makefile.in \ + $(srcdir)/test/automated/Makefile.in ./config.status config.status: ${srcdir}/configure ${srcdir}/lisp/version.el @@ -855,7 +856,7 @@ cd src; $(MAKE) tags check: - @echo "We don't have any tests for GNU Emacs yet." + cd test/automated; $(MAKE) check dist: cd ${srcdir}; ./make-dist
--- a/configure Tue Jan 11 22:13:06 2011 -0800 +++ b/configure Thu Jan 13 09:17:33 2011 -0800 @@ -17389,7 +17389,7 @@ test "${exec_prefix}" != NONE && exec_prefix=`echo "${exec_prefix}" | sed 's,\([^/]\)/*$,\1,'` -ac_config_files="$ac_config_files Makefile lib/Makefile lib-src/Makefile oldXMenu/Makefile doc/emacs/Makefile doc/misc/Makefile doc/lispintro/Makefile doc/lispref/Makefile src/Makefile lwlib/Makefile lisp/Makefile leim/Makefile" +ac_config_files="$ac_config_files Makefile lib/Makefile lib-src/Makefile oldXMenu/Makefile doc/emacs/Makefile doc/misc/Makefile doc/lispintro/Makefile doc/lispref/Makefile src/Makefile lwlib/Makefile lisp/Makefile leim/Makefile test/automated/Makefile" ac_config_commands="$ac_config_commands default" @@ -18174,6 +18174,7 @@ "lwlib/Makefile") CONFIG_FILES="$CONFIG_FILES lwlib/Makefile" ;; "lisp/Makefile") CONFIG_FILES="$CONFIG_FILES lisp/Makefile" ;; "leim/Makefile") CONFIG_FILES="$CONFIG_FILES leim/Makefile" ;; + "test/automated/Makefile") CONFIG_FILES="$CONFIG_FILES test/automated/Makefile" ;; "default") CONFIG_COMMANDS="$CONFIG_COMMANDS default" ;; *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;;
--- a/configure.in Tue Jan 11 22:13:06 2011 -0800 +++ b/configure.in Thu Jan 13 09:17:33 2011 -0800 @@ -3718,7 +3718,7 @@ AC_OUTPUT(Makefile lib/Makefile lib-src/Makefile oldXMenu/Makefile \ doc/emacs/Makefile doc/misc/Makefile doc/lispintro/Makefile \ doc/lispref/Makefile src/Makefile \ - lwlib/Makefile lisp/Makefile leim/Makefile, [ + lwlib/Makefile lisp/Makefile leim/Makefile test/automated/Makefile, [ ### Make the necessary directories, if they don't exist. for dir in etc lisp ; do
--- a/doc/misc/ChangeLog Tue Jan 11 22:13:06 2011 -0800 +++ b/doc/misc/ChangeLog Thu Jan 13 09:17:33 2011 -0800 @@ -1,3 +1,10 @@ +2011-01-13 Christian Ohler <ohler@gnu.org> + + * ert.texi: New file. + + * Makefile.in: + * makefile.w32-in: Add ert.texi. + 2011-01-10 Jan Moringen <jan.moringen@uni-bielefeld.de> * dbus.texi (Receiving Method Calls): New function
--- a/doc/misc/Makefile.in Tue Jan 11 22:13:06 2011 -0800 +++ b/doc/misc/Makefile.in Thu Jan 13 09:17:33 2011 -0800 @@ -62,6 +62,7 @@ $(infodir)/emacs-mime \ $(infodir)/epa \ $(infodir)/erc \ + $(infodir)/ert \ $(infodir)/eshell \ $(infodir)/eudc \ $(infodir)/efaq \ @@ -112,6 +113,7 @@ emacs-mime.dvi \ epa.dvi \ erc.dvi \ + ert.dvi \ eshell.dvi \ eudc.dvi \ faq.dvi \ @@ -162,6 +164,7 @@ emacs-mime.pdf \ epa.pdf \ erc.pdf \ + ert.pdf \ eshell.pdf \ eudc.pdf \ faq.pdf \ @@ -360,6 +363,14 @@ erc.pdf: ${srcdir}/erc.texi $(ENVADD) $(TEXI2PDF) $< +ert : $(infodir)/ert +$(infodir)/ert: ert.texi $(infodir) + cd $(srcdir); $(MAKEINFO) ert.texi +ert.dvi: ert.texi + $(ENVADD) $(TEXI2DVI) ${srcdir}/ert.texi +ert.pdf: ert.texi + $(ENVADD) $(TEXI2PDF) ${srcdir}/ert.texi + eshell : $(infodir)/eshell $(infodir)/eshell: eshell.texi $(mkinfodir)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/doc/misc/ert.texi Thu Jan 13 09:17:33 2011 -0800 @@ -0,0 +1,830 @@ +\input texinfo +@c %**start of header +@setfilename ../../info/ert +@settitle Emacs Lisp Regression Testing +@c %**end of header + +@dircategory Emacs +@direntry +* ERT: (ert). Emacs Lisp Regression Testing. +@end direntry + +@copying +Copyright @copyright{} 2008, 2010, 2011 Free Software Foundation, Inc. + +@quotation +Permission is granted to copy, distribute and/or modify this document +under the terms of the GNU Free Documentation License, Version 1.2 or +any later version published by the Free Software Foundation; with no +Invariant Sections, with no Front-Cover Texts, and with no Back-Cover +Texts. +@end quotation +@end copying + +@node Top, Introduction, (dir), (dir) +@top ERT: Emacs Lisp Regression Testing + +ERT is a tool for automated testing in Emacs Lisp. Its main features +are facilities for defining tests, running them and reporting the +results, and for debugging test failures interactively. + +ERT is similar to tools for other environments such as JUnit, but has +unique features that take advantage of the dynamic and interactive +nature of Emacs. Despite its name, it works well both for test-driven +development (see +@url{http://en.wikipedia.org/wiki/Test-driven_development}) and for +traditional software development methods. + +@menu +* Introduction:: A simple example of an ERT test. +* How to Run Tests:: Run tests in your Emacs or from the command line. +* How to Write Tests:: How to add tests to your Emacs Lisp code. +* How to Debug Tests:: What to do if a test fails. +* Extending ERT:: ERT is extensible in several ways. +* Other Testing Concepts:: Features not in ERT. + +@detailmenu + --- The Detailed Node Listing --- + +How to Run Tests + +* Running Tests Interactively:: Run tests in your current Emacs. +* Running Tests in Batch Mode:: Run tests in emacs -Q. +* Test Selectors:: Choose which tests to run. + +How to Write Tests + +* The @code{should} Macro:: A powerful way to express assertions. +* Expected Failures:: Tests for known bugs. +* Tests and Their Environment:: Don't depend on customizations; no side effects. +* Useful Techniques:: Some examples. + +How to Debug Tests + +* Understanding Explanations:: How ERT gives details on why an assertion failed. +* Interactive Debugging:: Tools available in the ERT results buffer. + +Extending ERT + +* Defining Explanation Functions:: Teach ERT about more predicates. +* Low-Level Functions for Working with Tests:: Use ERT's data for your purposes. + +Other Testing Concepts + +* Mocks and Stubs:: Stubbing out code that is irrelevant to the test. +* Fixtures and Test Suites:: How ERT differs from tools for other languages. + +@end detailmenu +@end menu + +@node Introduction, How to Run Tests, Top, Top +@chapter Introduction + +ERT allows you to define @emph{tests} in addition to functions, +macros, variables, and the other usual Lisp constructs. Tests are +simply Lisp code --- code that invokes other code and checks whether +it behaves as expected. + +ERT keeps track of the tests that are defined and provides convenient +commands to run them to verify whether the definitions that are +currently loaded in Emacs pass the tests. + +Some Lisp files have comments like the following (adapted from the +package @code{pp.el}): + +@lisp +;; (pp-to-string '(quote quote)) ; expected: "'quote" +;; (pp-to-string '((quote a) (quote b))) ; expected: "('a 'b)\n" +;; (pp-to-string '('a 'b)) ; same as above +@end lisp + +The code contained in these comments can be evaluated from time to +time to compare the output with the expected output. ERT formalizes +this and introduces a common convention, which simplifies Emacs +development, since programmers no longer have to manually find and +evaluate such comments. + +An ERT test definition equivalent to the above comments is this: + +@lisp +(ert-deftest pp-test-quote () + "Tests the rendering of `quote' symbols in `pp-to-string'." + (should (equal (pp-to-string '(quote quote)) "'quote")) + (should (equal (pp-to-string '((quote a) (quote b))) "('a 'b)\n")) + (should (equal (pp-to-string '('a 'b)) "('a 'b)\n"))) +@end lisp + +If you know @code{defun}, the syntax of @code{ert-deftest} should look +familiar: This example defines a test named @code{pp-test-quote} that +will pass if the three calls to @code{equal} all return true +(non-nil). + +@code{should} is a macro with the same meaning as @code{assert} but +better error reporting. @xref{The @code{should} Macro}. + +Each test should have a name that describes what functionality the +test tests. Test names can be chosen arbitrarily --- they are in a +namespace separate from functions and variables --- but should follow +the usual Emacs Lisp convention of having a prefix that indicates +which package they belong to. Test names are displayed by ERT when +reporting failures and can be used when selecting which tests to run. + +The empty parentheses @code{()} in the first line don't currently have +any meaning and are reserved for future extension. They also make +@code{ert-deftest}'s syntax more similar to @code{defun}. + +The docstring describes what feature this test tests. When running +tests interactively, the first line of the docstring is displayed for +tests that fail, so it is good if the first line makes sense on its +own. + +The body of a test can be arbitrary Lisp code. It should have as few +side effects as possible; each test should be written to clean up +after itself, leaving Emacs in the same state as it was before the +test. Tests should clean up even if they fail. @xref{Tests and Their +Environment}. + + +@node How to Run Tests, How to Write Tests, Introduction, Top +@chapter How to Run Tests + +You can run tests either in the Emacs you are working in, or on the +command line in a separate Emacs process in batch mode (i.e., with no +user interface). The former mode is convenient during interactive +development, the latter is useful to make sure that tests pass +independently of your customizations, allows tests to be invoked from +makefiles and scripts to be written that run tests in several +different Emacs versions. + +@menu +* Running Tests Interactively:: Run tests in your current Emacs. +* Running Tests in Batch Mode:: Run tests in emacs -Q. +* Test Selectors:: Choose which tests to run. +@end menu + + +@node Running Tests Interactively, Running Tests in Batch Mode, How to Run Tests, How to Run Tests +@section Running Tests Interactively + +You can run the tests that are currently defined in your Emacs with +the command @kbd{@kbd{M-x} ert @kbd{RET} t @kbd{RET}}. ERT will pop +up a new buffer, the ERT results buffer, showing the results of the +tests run. It looks like this: + +@example +Selector: t +Passed: 31 +Failed: 2 (2 unexpected) +Total: 33/33 + +Started at: 2008-09-11 08:39:25-0700 +Finished. +Finished at: 2008-09-11 08:39:27-0700 + +FF............................... + +F addition-test + (ert-test-failed + ((should + (= + (+ 1 2) + 4)) + :form + (= 3 4) + :value nil)) + +F list-test + (ert-test-failed + ((should + (equal + (list 'a 'b 'c) + '(a b d))) + :form + (equal + (a b c) + (a b d)) + :value nil :explanation + (list-elt 2 + (different-atoms c d)))) +@end example + +At the top, there is a summary of the results: We ran all tests in the +current Emacs (@code{Selector: t}), 31 of them passed, and 2 failed +unexpectedly. @xref{Expected Failures}, for an explanation of the +term @emph{unexpected} in this context. + +The line of dots and @code{F}s is a progress bar where each character +represents one test; it fills while the tests are running. A dot +means that the test passed, an @code{F} means that it failed. Below +the progress bar, ERT shows details about each test that had an +unexpected result. In the example above, there are two failures, both +due to failed @code{should} forms. @xref{Understanding Explanations}, +for more details. + +In the ERT results buffer, @kbd{TAB} and @kbd{S-TAB} cycle between +buttons. Each name of a function or macro in this buffer is a button; +moving point to it and typing @kbd{RET} jumps to its definition. + +Pressing @kbd{r} re-runs the test near point on its own. Pressing +@kbd{d} re-runs it with the debugger enabled. @kbd{.} jumps to the +definition of the test near point (@kbd{RET} has the same effect if +point is on the name of the test). On a failed test, @kbd{b} shows +the backtrace of the failure. + +@kbd{l} shows the list of @code{should} forms executed in the test. +If any messages were generated (with the Lisp function @code{message}) +in a test or any of the code that it invoked, @kbd{m} will show them. + +By default, long expressions in the failure details are abbreviated +using @code{print-length} and @code{print-level}. Pressing @kbd{L} +while point is on a test failure will increase the limits to show more +of the expression. + + +@node Running Tests in Batch Mode, Test Selectors, Running Tests Interactively, How to Run Tests +@section Running Tests in Batch Mode + +ERT supports automated invocations from the command line or from +scripts or makefiles. There are two functions for this purpose, +@code{ert-run-tests-batch} and @code{ert-run-tests-batch-and-exit}. +They can be used like this: + +@example +emacs -batch -L /path/to/ert -l ert.el -l my-tests.el -f ert-run-tests-batch-and-exit +@end example + +This command will start up Emacs in batch mode, load ERT, load +@code{my-tests.el}, and run all tests defined in it. It will exit +with a zero exit status if all tests passed, or nonzero if any tests +failed or if anything else went wrong. It will also print progress +messages and error diagnostics to standard output. + +You may need additional @code{-L} flags to ensure that +@code{my-tests.el} and all the files that it requires are on your +@code{load-path}. + + +@node Test Selectors, , Running Tests in Batch Mode, How to Run Tests +@section Test Selectors + +Functions like @code{ert} accept a @emph{test selector}, a Lisp +expression specifying a set of tests. Test selector syntax is similar +to Common Lisp's type specifier syntax: + +@itemize +@item @code{nil} selects no tests. +@item @code{t} selects all tests. +@item @code{:new} selects all tests that have not been run yet. +@item @code{:failed} and @code{:passed} select tests according to their most recent result. +@item @code{:expected}, @code{:unexpected} select tests according to their most recent result. +@item A string selects all tests that have a name that matches the string, a regexp. +@item A test selects that test. +@item A symbol selects the test that the symbol names. +@item @code{(member TESTS...)} selects TESTS, a list of tests or symbols naming tests. +@item @code{(eql TEST)} selects TEST, a test or a symbol naming a test. +@item @code{(and SELECTORS...)} selects the tests that match all SELECTORS. +@item @code{(or SELECTORS...)} selects the tests that match any SELECTOR. +@item @code{(not SELECTOR)} selects all tests that do not match SELECTOR. +@item @code{(tag TAG)} selects all tests that have TAG on their tags list. +@item @code{(satisfies PREDICATE)} Selects all tests that satisfy PREDICATE. +@end itemize + +Selectors that are frequently useful when selecting tests to run +include @code{t} to run all tests that are currently defined in Emacs, +@code{"^foo-"} to run all tests in package @code{foo} --- this assumes +that package @code{foo} uses the prefix @code{foo-} for its test names +---, result-based selectors such as @code{(or :new :unexpected)} to +run all tests that have either not run yet or that had an unexpected +result in the last run, and tag-based selectors such as @code{(not +(tag :causes-redisplay))} to run all tests that are not tagged +@code{:causes-redisplay}. + + +@node How to Write Tests, How to Debug Tests, How to Run Tests, Top +@chapter How to Write Tests + +ERT lets you define tests in the same way you define functions. You +can type @code{ert-deftest} forms in a buffer and evaluate them there +with @code{eval-defun} or @code{compile-defun}, or you can save the +file and load it, optionally byte-compiling it first. + +Just like @code{find-function} is only able to find where a function +was defined if the function was loaded from a file, ERT is only able +to find where a test was defined if the test was loaded from a file. + + +@menu +* The @code{should} Macro:: A powerful way to express assertions. +* Expected Failures:: Tests for known bugs. +* Tests and Their Environment:: Don't depend on customizations; no side effects. +* Useful Techniques:: Some examples. +@end menu + +@node The @code{should} Macro, Expected Failures, How to Write Tests, How to Write Tests +@section The @code{should} Macro + +Test bodies can include arbitrary code; but to be useful, they need to +have checks whether the code being tested (or @emph{code under test}) +does what it is supposed to do. The macro @code{should} is similar to +@code{assert} from the cl package, but analyzes its argument form and +records information that ERT can display to help debugging. + +This test definition + +@lisp +(ert-deftest addition-test () + (should (= (+ 1 2) 4))) +@end lisp + +will produce this output when run via @kbd{M-x ert}: + +@example +F addition-test + (ert-test-failed + ((should + (= + (+ 1 2) + 4)) + :form + (= 3 4) + :value nil)) +@end example + +In this example, @code{should} recorded the fact that (= (+ 1 2) 4) +reduced to (= 3 4) before it reduced to nil. When debugging why the +test failed, it helps to know that the function @code{+} returned 3 +here. ERT records the return value for any predicate called directly +within @code{should}. + +In addition to @code{should}, ERT provides @code{should-not}, which +checks that the predicate returns nil, and @code{should-error}, which +checks that the form called within it signals an error. An example +use of @code{should-error}: + +@lisp +(ert-deftest test-divide-by-zero () + (should-error (/ 1 0) + :type 'arith-error)) +@end lisp + +This checks that dividing one by zero signals an error of type +@code{arith-error}. The @code{:type} argument to @code{should-error} +is optional; if absent, any type of error is accepted. +@code{should-error} returns an error description of the error that was +signalled, to allow additional checks to be made. The error +description has the format @code{(ERROR-SYMBOL . DATA)}. + +There is no @code{should-not-error} macro since tests that signal an +error fail anyway, so @code{should-not-error} is effectively the +default. + +@xref{Understanding Explanations}, for more details on what +@code{should} reports. + + +@node Expected Failures, Tests and Their Environment, The @code{should} Macro, How to Write Tests +@section Expected Failures + +Some bugs are complicated to fix or not very important and are left as +@emph{known bugs}. If there is a test case that triggers the bug and +fails, ERT will alert you of this failure every time you run all +tests. For known bugs, this alert is a distraction. The way to +suppress it is to add @code{:expected-result :failed} to the test +definition: + +@lisp +(ert-deftest future-bug () + "Test `time-forward' with negative arguments. +Since this functionality isn't implemented yet, the test is known to fail." + :expected-result :failed + (time-forward -1)) +@end lisp + +ERT will still display a small @code{f} in the progress bar as a +reminder that there is a known bug, and will count the test as failed, +but it will be quiet about it otherwise. + +An alternative to marking the test as a known failure this way is to +delete the test. This is a good idea if there is no intent to fix it, +i.e., if the behavior that was formerly considered a bug has become an +accepted feature. + +In general, however, it can be useful to keep tests that are known to +fail. If someone wants to fix the bug, they will have a very good +starting point: an automated test case that reproduces the bug. This +makes it much easier to fix the bug, demonstrate that it is fixed, and +prevent future regressions. + +ERT displays the same kind of alerts for tests that pass unexpectedly +that it displays for unexpected failures. This way, if you make code +changes that happen to fix a bug that you weren't aware of, you will +know to remove the @code{:expected-result} clause of that test and +close the corresponding bug report, if any. + +Since @code{:expected-result} evaluates its argument when the test is +loaded, tests can be marked as known failures only on certain Emacs +versions, specific architectures, etc.: + +@lisp +(ert-deftest foo () + "A test that is expected to fail on Emacs 23 but succeed elsewhere." + :expected-result (if (string-match "GNU Emacs 23[.]" (emacs-version)) + :failed + :passed) + ...) +@end lisp + + +@node Tests and Their Environment, Useful Techniques, Expected Failures, How to Write Tests +@section Tests and Their Environment + +The outcome of running a test should not depend on the current state +of the environment, and each test should leave its environment in the +same state it found it in. In particular, a test should not depend on +any Emacs customization variables or hooks, and if it has to make any +changes to Emacs' state or state external to Emacs such as the file +system, it should undo these changes before it returns, regardless of +whether it passed or failed. + +Tests should not depend on the environment because any such +dependencies can make the test brittle or lead to failures that occur +only under certain circumstances and are hard to reproduce. Of +course, the code under test may have settings that affect its +behavior. In that case, it is best to make the test @code{let}-bind +all such settings variables to set up a specific configuration for the +duration of the test. The test can also set up a number of different +configurations and run the code under test with each. + +Tests that have side effects on their environment should restore it to +its original state because any side effects that persist after the +test can disrupt the workflow of the programmer running the tests. If +the code under test has side effects on Emacs' current state, such as +on the current buffer or window configuration, the test should create +a temporary buffer for the code to manipulate (using +@code{with-temp-buffer}), or save and restore the window configuration +(using @code{save-window-excursion}), respectively. For aspects of +the state that can not be preserved with such macros, cleanup should +be performed with @code{unwind-protect}, to ensure that the cleanup +occurs even if the test fails. + +An exception to this are messages that the code under test prints with +@code{message} and similar logging; tests should not bother restoring +the @code{*Message*} buffer to its original state. + +The above guidelines imply that tests should avoid calling highly +customizable commands such as @code{find-file}, except, of course, if +such commands are what they want to test. The exact behavior of +@code{find-file} depends on many settings such as +@code{find-file-wildcards}, @code{enable-local-variables}, and +@code{auto-mode-alist}. It is difficult to write a meaningful test if +its behavior can be affected by so many external factors. Also, +@code{find-file} has side effects that are hard to predict and thus +hard to undo: It may create a new buffer or may reuse an existing +buffer if one is already visiting the requested file; and it runs +@code{find-file-hook}, which can have arbitrary side effects. + +Instead, it is better to use lower-level mechanisms with simple and +predictable semantics like @code{with-temp-buffer}, @code{insert} or +@code{insert-file-contents-literally}, and activating the desired mode +by calling the corresponding function directly --- after binding the +hook variables to nil. This avoids the above problems. + + +@node Useful Techniques, , Tests and Their Environment, How to Write Tests +@section Useful Techniques when Writing Tests + +Testing simple functions that have no side effects and no dependencies +on their environment is easy. Such tests often look like this: + +@lisp +(ert-deftest ert-test-mismatch () + (should (eql (ert--mismatch "" "") nil)) + (should (eql (ert--mismatch "" "a") 0)) + (should (eql (ert--mismatch "a" "a") nil)) + (should (eql (ert--mismatch "ab" "a") 1)) + (should (eql (ert--mismatch "Aa" "aA") 0)) + (should (eql (ert--mismatch '(a b c) '(a b d)) 2))) +@end lisp + +This test calls the function @code{ert--mismatch} several times with +various combinations of arguments and compares the return value to the +expected return value. (Some programmers prefer @code{(should (eql +EXPECTED ACTUAL))} over the @code{(should (eql ACTUAL EXPECTED))} +shown here. ERT works either way.) + +Here's a more complicated test: + +@lisp +(ert-deftest ert-test-record-backtrace () + (let ((test (make-ert-test :body (lambda () (ert-fail "foo"))))) + (let ((result (ert-run-test test))) + (should (ert-test-failed-p result)) + (with-temp-buffer + (ert--print-backtrace (ert-test-failed-backtrace result)) + (goto-char (point-min)) + (end-of-line) + (let ((first-line (buffer-substring-no-properties (point-min) (point)))) + (should (equal first-line " signal(ert-test-failed (\"foo\"))"))))))) +@end lisp + +This test creates a test object using @code{make-ert-test} whose body +will immediately signal failure. It then runs that test and asserts +that it fails. Then, it creates a temporary buffer and invokes +@code{ert--print-backtrace} to print the backtrace of the failed test +to the current buffer. Finally, it extracts the first line from the +buffer and asserts that it matches what we expect. It uses +@code{buffer-substring-no-properties} and @code{equal} to ignore text +properties; for a test that takes properties into account, +@code{buffer-substring} and @code{ert-equal-including-properties} +could be used instead. + +The reason why this test only checks the first line of the backtrace +is that the remainder of the backtrace is dependent on ERT's internals +as well as whether the code is running interpreted or compiled. By +looking only at the first line, the test checks a useful property +--- that the backtrace correctly captures the call to @code{signal} that +results from the call to @code{ert-fail} --- without being brittle. + +This example also shows that writing tests is much easier if the code +under test was structured with testing in mind. + +For example, if @code{ert-run-test} accepted only symbols that name +tests rather than test objects, the test would need a name for the +failing test, which would have to be a temporary symbol generated with +@code{make-symbol}, to avoid side effects on Emacs' state. Choosing +the right interface for @code{ert-run-tests} allows the test to be +simpler. + +Similarly, if @code{ert--print-backtrace} printed the backtrace to a +buffer with a fixed name rather than the current buffer, it would be +much harder for the test to undo the side effect. Of course, some +code somewhere needs to pick the buffer name. But that logic is +independent of the logic that prints backtraces, and keeping them in +separate functions allows us to test them independently. + +A lot of code that you will encounter in Emacs was not written with +testing in mind. Sometimes, the easiest way to write tests for such +code is to restructure the code slightly to provide better interfaces +for testing. Usually, this makes the interfaces easier to use as +well. + + +@node How to Debug Tests, Extending ERT, How to Write Tests, Top +@chapter How to Debug Tests + +This section describes how to use ERT's features to understand why +a test failed. + + +@menu +* Understanding Explanations:: How ERT gives details on why an assertion failed. +* Interactive Debugging:: Tools available in the ERT results buffer. +@end menu + + +@node Understanding Explanations, Interactive Debugging, How to Debug Tests, How to Debug Tests +@section Understanding Explanations + +Failed @code{should} forms are reported like this: + +@example +F addition-test + (ert-test-failed + ((should + (= + (+ 1 2) + 4)) + :form + (= 3 4) + :value nil)) +@end example + +ERT shows what the @code{should} expression looked like and what +values its subexpressions had: The source code of the assertion was +@code{(should (= (+ 1 2) 4))}, which applied the function @code{=} to +the arguments @code{3} and @code{4}, resulting in the value +@code{nil}. In this case, the test is wrong; it should expect 3 +rather than 4. + +If a predicate like @code{equal} is used with @code{should}, ERT +provides a so-called @emph{explanation}: + +@example +F list-test + (ert-test-failed + ((should + (equal + (list 'a 'b 'c) + '(a b d))) + :form + (equal + (a b c) + (a b d)) + :value nil :explanation + (list-elt 2 + (different-atoms c d)))) +@end example + +In this case, the function @code{equal} was applied to the arguments +@code{(a b c)} and @code{(a b d)}. ERT's explanation shows that +the item at index 2 differs between the two lists; in one list, it is +the atom c, in the other, it is the atom d. + +In simple examples like the above, the explanation is unnecessary. +But in cases where the difference is not immediately apparent, it can +save time: + +@example +F test1 + (ert-test-failed + ((should + (equal x y)) + :form + (equal a a) + :value nil :explanation + (different-symbols-with-the-same-name a a))) +@end example + +ERT only provides explanations for predicates that have an explanation +function registered. @xref{Defining Explanation Functions}. + + +@node Interactive Debugging, , Understanding Explanations, How to Debug Tests +@section Interactive Debugging + +Debugging failed tests works essentially the same way as debugging any +other problems with Lisp code. Here are a few tricks specific to +tests: + +@itemize +@item Re-run the failed test a few times to see if it fails in the same way +each time. It's good to find out whether the behavior is +deterministic before spending any time looking for a cause. In the +ERT results buffer, @kbd{r} re-runs the selected test. + +@item Use @kbd{.} to jump to the source code of the test to find out what +exactly it does. Perhaps the test is broken rather than the code +under test. + +@item If the test contains a series of @code{should} forms and you can't +tell which one failed, use @kbd{l}, which shows you the list of all +@code{should} forms executed during the test before it failed. + +@item Use @kbd{b} to view the backtrace. You can also use @kbd{d} to re-run +the test with debugging enabled, this will enter the debugger and show +the backtrace as well; but the top few frames shown there will not be +relevant to you since they are ERT's own debugger hook. @kbd{b} +strips them out, so it is more convenient. + +@item If the test or the code under testing prints messages using +@code{message}, use @kbd{m} to see what messages it printed before it +failed. This can be useful to figure out how far it got. + +@item You can instrument tests for debugging the same way you instrument +@code{defun}s for debugging --- go to the source code of the test and +type @kbd{@kbd{C-u} @kbd{C-M-x}}. Then, go back to the ERT buffer and +re-run the test with @kbd{r} or @kbd{d}. + +@item If you have been editing and rearranging tests, it is possible that +ERT remembers an old test that you have since renamed or removed --- +renamings or removals of definitions in the source code leave around a +stray definition under the old name in the running process, this is a +common problem in Lisp. In such a situation, hit @kbd{D} to let ERT +forget about the obsolete test. +@end itemize + + +@node Extending ERT, Other Testing Concepts, How to Debug Tests, Top +@chapter Extending ERT + +There are several ways to add functionality to ERT. + +@menu +* Defining Explanation Functions:: Teach ERT about more predicates. +* Low-Level Functions for Working with Tests:: Use ERT's data for your purposes. +@end menu + + +@node Defining Explanation Functions, Low-Level Functions for Working with Tests, Extending ERT, Extending ERT +@section Defining Explanation Functions + +The explanation function for a predicate is a function that takes the +same arguments as the predicate and returns an @emph{explanation}. +The explanation should explain why the predicate, when invoked with +the arguments given to the explanation function, returns the value +that it returns. The explanation can be any object but should have a +comprehensible printed representation. If the return value of the +predicate needs no explanation for a given list of arguments, the +explanation function should return nil. + +To associate an explanation function with a predicate, add the +property @code{ert-explainer} to the symbol that names the predicate. +The value of the property should be the symbol that names the +explanation function. + + +@node Low-Level Functions for Working with Tests, , Defining Explanation Functions, Extending ERT +@section Low-Level Functions for Working with Tests + +Both @code{ert-run-tests-interactively} and @code{ert-run-tests-batch} +are implemented on top of the lower-level test handling code in the +sections named ``Facilities for running a single test'', ``Test +selectors'', and ``Facilities for running a whole set of tests''. + +If you want to write code that works with ERT tests, you should take a +look at this lower-level code. Symbols that start with @code{ert--} +are internal to ERT, those that start with @code{ert-} but not +@code{ert--} are meant to be usable by other code. But there is no +mature API yet. + +Contributions to ERT are welcome. + + +@node Other Testing Concepts, , Extending ERT, Top +@chapter Other Testing Concepts + +For information on mocks, stubs, fixtures, or test suites, see below. + + +@menu +* Mocks and Stubs:: Stubbing out code that is irrelevant to the test. +* Fixtures and Test Suites:: How ERT differs from tools for other languages. +@end menu + +@node Mocks and Stubs, Fixtures and Test Suites, Other Testing Concepts, Other Testing Concepts +@section Other Tools for Emacs Lisp + +Stubbing out functions or using so-called @emph{mocks} can make it +easier to write tests. See +@url{http://en.wikipedia.org/wiki/Mock_object} for an explanation of +the corresponding concepts in object-oriented languages. + +ERT does not have built-in support for mocks or stubs. The package +@code{el-mock} (see @url{http://www.emacswiki.org/emacs/el-mock.el}) +offers mocks for Emacs Lisp and can be used in conjunction with ERT. + + +@node Fixtures and Test Suites, , Mocks and Stubs, Other Testing Concepts +@section Fixtures and Test Suites + +In many ways, ERT is similar to frameworks for other languages like +SUnit or JUnit. However, two features commonly found in such +frameworks are notably absent from ERT: fixtures and test suites. + +Fixtures, as used e.g. in SUnit or JUnit, are mainly used to provide +an environment for a set of tests, and consist of set-up and tear-down +functions. + +While fixtures are a useful syntactic simplification in other +languages, this does not apply to Lisp, where higher-order functions +and `unwind-protect' are available. One way to implement and use a +fixture in ERT is + +@lisp +(defun my-fixture (body) + (unwind-protect + (progn [set up] + (funcall body)) + [tear down])) + +(ert-deftest my-test () + (my-fixture + (lambda () + [test code]))) +@end lisp + +(Another way would be a @code{with-my-fixture} macro.) This solves +the set-up and tear-down part, and additionally allows any test +to use any combination of fixtures, so it is more flexible than what +other tools typically allow. + +If the test needs access to the environment the fixture sets up, the +fixture can be modified to pass arguments to the body. + +These are well-known Lisp techniques. Special syntax for them could +be added but would provide only a minor simplification. + +(If you are interested in such syntax, note that splitting set-up and +tear-down into separate functions, like *Unit tools usually do, makes +it impossible to establish dynamic `let' bindings as part of the +fixture. So, blindly imitating the way fixtures are implemented in +other languages would be counter-productive in Lisp.) + +The purpose of test suites is to group related tests together. + +The most common use of this is to run just the tests for one +particular module. Since symbol prefixes are the usual way of +separating module namespaces in Emacs Lisp, test selectors already +solve this by allowing regexp matching on test names; e.g., the +selector "^ert-" selects ERT's self-tests. + +Other uses include grouping tests by their expected execution time to +run quick tests during interactive development and slow tests less +frequently. This can be achieved with the @code{:tag} argument to +@code{ert-deftest} and @code{tag} test selectors. + +@bye + +@c LocalWords: ERT Hagelberg Ohler JUnit namespace docstring ERT's +@c LocalWords: backtrace makefiles workflow backtraces API SUnit +@c LocalWords: subexpressions
--- a/doc/misc/makefile.w32-in Tue Jan 11 22:13:06 2011 -0800 +++ b/doc/misc/makefile.w32-in Thu Jan 13 09:17:33 2011 -0800 @@ -47,7 +47,8 @@ $(infodir)/org $(infodir)/url $(infodir)/speedbar \ $(infodir)/tramp $(infodir)/ses $(infodir)/smtpmail \ $(infodir)/flymake $(infodir)/newsticker $(infodir)/rcirc \ - $(infodir)/erc $(infodir)/remember $(infodir)/nxml-mode \ + $(infodir)/erc $(infodir)/ert \ + $(infodir)/remember $(infodir)/nxml-mode \ $(infodir)/epa $(infodir)/mairix-el $(infodir)/sasl \ $(infodir)/auth $(infodir)/eieio $(infodir)/ede \ $(infodir)/semantic $(infodir)/edt @@ -58,7 +59,8 @@ ada-mode.dvi autotype.dvi idlwave.dvi eudc.dvi ebrowse.dvi \ pcl-cvs.dvi woman.dvi eshell.dvi org.dvi url.dvi \ speedbar.dvi tramp.dvi ses.dvi smtpmail.dvi flymake.dvi \ - newsticker.dvi rcirc.dvi erc.dvi remember.dvi nxml-mode.dvi \ + newsticker.dvi rcirc.dvi erc.dvi ert.dvi \ + remember.dvi nxml-mode.dvi \ epa.dvi mairix-el.dvi sasl.dvi auth.dvi eieio.dvi ede.dvi \ semantic.dvi edt.dvi INFOSOURCES = info.texi @@ -305,6 +307,11 @@ erc.dvi: erc.texi $(ENVADD) $(TEXI2DVI) $(srcdir)/erc.texi +$(infodir)/ert: ert.texi + $(MAKEINFO) ert.texi +ert.dvi: ert.texi + $(ENVADD) $(TEXI2DVI) $(srcdir)/ert.texi + $(infodir)/epa: epa.texi $(MAKEINFO) epa.texi epa.dvi: epa.texi @@ -362,7 +369,7 @@ $(infodir)/url* $(infodir)/org* \ $(infodir)/flymake* $(infodir)/newsticker* \ $(infodir)/sieve* $(infodir)/pgg* \ - $(infodir)/erc* $(infodir)/rcirc* \ + $(infodir)/erc* $(infodir)/ert* $(infodir)/rcirc* \ $(infodir)/remember* $(infodir)/nxml-mode* \ $(infodir)/epa* $(infodir)/sasl* \ $(infodir)/mairix-el* $(infodir)/auth* \
--- a/etc/ChangeLog Tue Jan 11 22:13:06 2011 -0800 +++ b/etc/ChangeLog Thu Jan 13 09:17:33 2011 -0800 @@ -1,3 +1,7 @@ +2011-01-13 Christian Ohler <ohler@gnu.org> + + * NEWS: Mention ERT. + 2011-01-10 Jan Moringen <jan.moringen@uni-bielefeld.de> * NEWS: Add new function dbus-register-service.
--- a/etc/NEWS Tue Jan 11 22:13:06 2011 -0800 +++ b/etc/NEWS Thu Jan 13 09:17:33 2011 -0800 @@ -210,6 +210,10 @@ `package-enable-at-startup' to nil. To change which packages are loaded, customize `package-load-list'. +** An Emacs Lisp testing tool is now included. +Emacs Lisp developers can use this tool to write automated tests for +their code. See the ERT info manual for details. + ** Custom Themes *** `M-x customize-themes' lists Custom themes which can be enabled. @@ -621,6 +625,11 @@ * Incompatible Lisp Changes in Emacs 24.1 +** `compose-mail' now accepts an optional 8th arg, RETURN-ACTION, and +passes it to the mail user agent function. This argument specifies an +action for returning to the caller after finishing with the mail. +This is currently used by Rmail to delete a mail window. + ** For mouse click input events in the text area, the Y pixel coordinate in the POSITION list now counts from the top of the text area, excluding any header line. Previously, it counted from the top
--- a/etc/themes/tsdh-dark-theme.el Tue Jan 11 22:13:06 2011 -0800 +++ b/etc/themes/tsdh-dark-theme.el Thu Jan 13 09:17:33 2011 -0800 @@ -25,12 +25,12 @@ (custom-theme-set-faces 'tsdh-dark '(default ((t (:background "gray20" :foreground "white smoke")))) - '(diff-added ((t (:inherit diff-changed :background "light green")))) - '(diff-changed ((t (:background "light steel blue")))) + '(diff-added ((t (:inherit diff-changed :background "dark green")))) + '(diff-changed ((t (:background "midnight blue")))) '(diff-indicator-added ((t (:inherit diff-indicator-changed)))) '(diff-indicator-changed ((t (:weight bold)))) '(diff-indicator-removed ((t (:inherit diff-indicator-changed)))) - '(diff-removed ((t (:inherit diff-changed :background "sandy brown")))) + '(diff-removed ((t (:inherit diff-changed :background "dark red")))) '(dired-directory ((t (:inherit font-lock-function-name-face :weight bold)))) '(hl-line ((t (:background "grey28")))) '(message-header-subject ((t (:foreground "SkyBlue"))))
--- a/lisp/ChangeLog Tue Jan 11 22:13:06 2011 -0800 +++ b/lisp/ChangeLog Thu Jan 13 09:17:33 2011 -0800 @@ -1,3 +1,48 @@ +2011-01-13 Kim F. Storm <storm@cua.dk> + + * ido.el (ido-may-cache-directory): Move "too-big" check later. + (ido-next-match, ido-prev-match): Fix stray reordering of matching + items when cycling through the matches. + +2011-01-13 Tassilo Horn <tassilo@member.fsf.org> + + * dired-x.el (dired-omit-verbose): New defcustom that allows + disabling the omit messages. + (dired-omit-expunge): Use it. + +2011-01-13 Christian Ohler <ohler@gnu.org> + + * emacs-lisp/ert.el, emacs-lisp/ert-x.el: New files. + +2011-01-13 Chong Yidong <cyd@stupidchicken.com> + + * font-lock.el (font-lock-verbose): Default to nil. + +2011-01-13 Chong Yidong <cyd@stupidchicken.com> + + * simple.el (sendmail-user-agent-compose): Move to sendmail.el. + (compose-mail): New arg RETURN-ACTION. + (compose-mail-other-window, compose-mail-other-frame): Likewise. + + * mail/sendmail.el (mail-return-action): New var. + (mail-mode): Make it buffer-local. + (mail-bury): Obey it. Move special Rmail window handling to + rmail-mail-return. + (mail, mail-setup): New arg RETURN-ACTION. + (sendmail-user-agent-compose): Move from simple.el. + + * mail/rmail.el (rmail-mail-return): New function. + (rmail-start-mail): Pass it to compose-mail. + +2011-01-12 Chong Yidong <cyd@stupidchicken.com> + + * menu-bar.el (menu-bar-custom-menu): Tweak Mule and Customize + menus. Add menu item for customize-themes. + + * cus-theme.el (customize-themes): + * emacs-lisp/package.el (package--list-packages): Use + switch-to-buffer. + 2011-01-11 Johan Bockgård <bojohan@gnu.org> * emacs-lisp/unsafep.el (unsafep): Handle backquoted forms.
--- a/lisp/cus-theme.el Tue Jan 11 22:13:06 2011 -0800 +++ b/lisp/cus-theme.el Thu Jan 13 09:17:33 2011 -0800 @@ -541,7 +541,7 @@ When called from Lisp, BUFFER should be the buffer to use; if omitted, a buffer named *Custom Themes* is used." (interactive) - (pop-to-buffer (get-buffer-create (or buffer "*Custom Themes*"))) + (switch-to-buffer (get-buffer-create (or buffer "*Custom Themes*"))) (let ((inhibit-read-only t)) (erase-buffer)) (custom-theme-choose-mode)
--- a/lisp/dired-x.el Tue Jan 11 22:13:06 2011 -0800 +++ b/lisp/dired-x.el Thu Jan 13 09:17:33 2011 -0800 @@ -189,6 +189,12 @@ :type 'regexp :group 'dired-x) +(defcustom dired-omit-verbose t + "When non-nil, show messages when omitting files. +When nil, don't show messages." + :type 'boolean + :group 'dired-x) + (defcustom dired-find-subdir nil ; t is pretty near to DWIM... "If non-nil, Dired always finds a directory in a buffer of its own. If nil, Dired finds the directory as a subdirectory in some other buffer @@ -613,8 +619,9 @@ (not dired-omit-size-limit) (< (buffer-size) dired-omit-size-limit) (progn - (message "Not omitting: directory larger than %d characters." - dired-omit-size-limit) + (when dired-omit-verbose + (message "Not omitting: directory larger than %d characters." + dired-omit-size-limit)) (setq dired-omit-mode nil) nil))) (let ((omit-re (or regexp (dired-omit-regexp))) @@ -622,12 +629,14 @@ count) (or (string= omit-re "") (let ((dired-marker-char dired-omit-marker-char)) - (message "Omitting...") + (when dired-omit-verbose (message "Omitting...")) (if (dired-mark-unmarked-files omit-re nil nil dired-omit-localp) (progn - (setq count (dired-do-kill-lines nil "Omitted %d line%s.")) + (setq count (dired-do-kill-lines + nil + (if dired-omit-verbose "Omitted %d line%s." ""))) (force-mode-line-update)) - (message "(Nothing to omit)")))) + (when dired-omit-verbose (message "(Nothing to omit)"))))) ;; Try to preserve modified state of buffer. So `%*' doesn't appear ;; in mode-line of omitted buffers. (set-buffer-modified-p (and old-modified-p
--- a/lisp/dired.el Tue Jan 11 22:13:06 2011 -0800 +++ b/lisp/dired.el Thu Jan 13 09:17:33 2011 -0800 @@ -4021,7 +4021,7 @@ ;;;*** ;;;### (autoloads (dired-do-relsymlink dired-jump) "dired-x" "dired-x.el" -;;;;;; "27c312d6d5d40d8cb4ef8d62e30d5f4a") +;;;;;; "6181a5bcc2b61255676a7a41549b9f40") ;;; Generated autoloads from dired-x.el (autoload 'dired-jump "dired-x" "\
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emacs-lisp/ert-x.el Thu Jan 13 09:17:33 2011 -0800 @@ -0,0 +1,290 @@ +;;; ert-x.el --- Staging area for experimental extensions to ERT + +;; Copyright (C) 2008, 2010, 2011 Free Software Foundation, Inc. + +;; Author: Lennart Borgman (lennart O borgman A gmail O com) +;; Author: Christian Ohler <ohler@gnu.org> + +;; This file is part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `http://www.gnu.org/licenses/'. + +;;; Commentary: + +;; This file includes some extra helper functions to use while writing +;; automated tests with ERT. These have been proposed as extensions +;; to ERT but are not mature yet and likely to change. + +;;; Code: + +(eval-when-compile + (require 'cl)) +(require 'ert) + + +;;; Test buffers. + +(defun ert--text-button (string &rest properties) + "Return a string containing STRING as a text button with PROPERTIES. + +See `make-text-button'." + (with-temp-buffer + (insert string) + (apply #'make-text-button (point-min) (point-max) properties) + (buffer-string))) + +(defun ert--format-test-buffer-name (base-name) + "Compute a test buffer name based on BASE-NAME. + +Helper function for `ert--test-buffers'." + (format "*Test buffer (%s)%s*" + (or (and (ert-running-test) + (ert-test-name (ert-running-test))) + "<anonymous test>") + (if base-name + (format ": %s" base-name) + ""))) + +(defvar ert--test-buffers (make-hash-table :weakness t) + "Table of all test buffers. Keys are the buffer objects, values are t. + +The main use of this table is for `ert-kill-all-test-buffers'. +Not all buffers in this table are necessarily live, but all live +test buffers are in this table.") + +(define-button-type 'ert--test-buffer-button + 'action #'ert--test-buffer-button-action + 'help-echo "mouse-2, RET: Pop to test buffer") + +(defun ert--test-buffer-button-action (button) + "Pop to the test buffer that BUTTON is associated with." + (pop-to-buffer (button-get button 'ert--test-buffer))) + +(defun ert--call-with-test-buffer (ert--base-name ert--thunk) + "Helper function for `ert-with-test-buffer'. + +Create a test buffer with a name based on ERT--BASE-NAME and run +ERT--THUNK with that buffer as current." + (let* ((ert--buffer (generate-new-buffer + (ert--format-test-buffer-name ert--base-name))) + (ert--button (ert--text-button (buffer-name ert--buffer) + :type 'ert--test-buffer-button + 'ert--test-buffer ert--buffer))) + (puthash ert--buffer 't ert--test-buffers) + ;; We don't use `unwind-protect' here since we want to kill the + ;; buffer only on success. + (prog1 (with-current-buffer ert--buffer + (ert-info (ert--button :prefix "Buffer: ") + (funcall ert--thunk))) + (kill-buffer ert--buffer) + (remhash ert--buffer ert--test-buffers)))) + +(defmacro* ert-with-test-buffer ((&key ((:name name-form))) + &body body) + "Create a test buffer and run BODY in that buffer. + +To be used in ERT tests. If BODY finishes successfully, the test +buffer is killed; if there is an error, the test buffer is kept +around on error for further inspection. Its name is derived from +the name of the test and the result of NAME-FORM." + (declare (debug ((form) body)) + (indent 1)) + `(ert--call-with-test-buffer ,name-form (lambda () ,@body))) + +;; We use these `put' forms in addition to the (declare (indent)) in +;; the defmacro form since the `declare' alone does not lead to +;; correct indentation before the .el/.elc file is loaded. +;; Autoloading these `put' forms solves this. +;;;###autoload +(progn + ;; TODO(ohler): Figure out what these mean and make sure they are correct. + (put 'ert-with-test-buffer 'lisp-indent-function 1)) + +;;;###autoload +(defun ert-kill-all-test-buffers () + "Kill all test buffers that are still live." + (interactive) + (let ((count 0)) + (maphash (lambda (buffer dummy) + (when (or (not (buffer-live-p buffer)) + (kill-buffer buffer)) + (incf count))) + ert--test-buffers) + (message "%s out of %s test buffers killed" + count (hash-table-count ert--test-buffers))) + ;; It could be that some test buffers were actually kept alive + ;; (e.g., due to `kill-buffer-query-functions'). I'm not sure what + ;; to do about this. For now, let's just forget them. + (clrhash ert--test-buffers) + nil) + + +;;; Simulate commands. + +(defun ert-simulate-command (command) + ;; FIXME: add unread-events + "Simulate calling COMMAND the way the Emacs command loop would call it. + +This effectively executes + + \(apply (car COMMAND) (cdr COMMAND)\) + +and returns the same value, but additionally runs hooks like +`pre-command-hook' and `post-command-hook', and sets variables +like `this-command' and `last-command'. + +COMMAND should be a list where the car is the command symbol and +the rest are arguments to the command. + +NOTE: Since the command is not called by `call-interactively' +test for `called-interactively' in the command will fail." + (assert (listp command) t) + (assert (commandp (car command)) t) + (assert (not unread-command-events) t) + (let (return-value) + ;; For the order of things here see command_loop_1 in keyboard.c. + ;; + ;; The command loop will reset the command-related variables so + ;; there is no reason to let-bind them. They are set here, + ;; however, to be able to test several commands in a row and how + ;; they affect each other. + (setq deactivate-mark nil + this-original-command (car command) + ;; remap through active keymaps + this-command (or (command-remapping this-original-command) + this-original-command)) + (run-hooks 'pre-command-hook) + (setq return-value (apply (car command) (cdr command))) + (run-hooks 'post-command-hook) + (when deferred-action-list + (run-hooks 'deferred-action-function)) + (setq real-last-command (car command) + last-command this-command) + (when (boundp 'last-repeatable-command) + (setq last-repeatable-command real-last-command)) + (when (and deactivate-mark transient-mark-mode) (deactivate-mark)) + (assert (not unread-command-events) t) + return-value)) + +(defun ert-run-idle-timers () + "Run all idle timers (from `timer-idle-list')." + (dolist (timer (copy-sequence timer-idle-list)) + (timer-event-handler timer))) + + +;;; Miscellaneous utilities. + +(defun ert-filter-string (s &rest regexps) + "Return a copy of S with all matches of REGEXPS removed. + +Elements of REGEXPS may also be two-element lists \(REGEXP +SUBEXP\), where SUBEXP is the number of a subexpression in +REGEXP. In that case, only that subexpression will be removed +rather than the entire match." + ;; Use a temporary buffer since replace-match copies strings, which + ;; would lead to N^2 runtime. + (with-temp-buffer + (insert s) + (dolist (x regexps) + (destructuring-bind (regexp subexp) (if (listp x) x `(,x nil)) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (replace-match "" t t nil subexp)))) + (buffer-string))) + + +(defun ert-propertized-string (&rest args) + "Return a string with properties as specified by ARGS. + +ARGS is a list of strings and plists. The strings in ARGS are +concatenated to produce an output string. In the output string, +each string from ARGS will be have the preceding plist as its +property list, or no properties if there is no plist before it. + +As a simple example, + +\(ert-propertized-string \"foo \" '(face italic) \"bar\" \" baz\" nil \ +\" quux\"\) + +would return the string \"foo bar baz quux\" where the substring +\"bar baz\" has a `face' property with the value `italic'. + +None of the ARGS are modified, but the return value may share +structure with the plists in ARGS." + (with-temp-buffer + (loop with current-plist = nil + for x in args do + (etypecase x + (string (let ((begin (point))) + (insert x) + (set-text-properties begin (point) current-plist))) + (list (unless (zerop (mod (length x) 2)) + (error "Odd number of args in plist: %S" x)) + (setq current-plist x)))) + (buffer-string))) + + +(defun ert-call-with-buffer-renamed (buffer-name thunk) + "Protect the buffer named BUFFER-NAME from side-effects and run THUNK. + +Renames the buffer BUFFER-NAME to a new temporary name, creates a +new buffer named BUFFER-NAME, executes THUNK, kills the new +buffer, and renames the original buffer back to BUFFER-NAME. + +This is useful if THUNK has undesirable side-effects on an Emacs +buffer with a fixed name such as *Messages*." + (lexical-let ((new-buffer-name (generate-new-buffer-name + (format "%s orig buffer" buffer-name)))) + (with-current-buffer (get-buffer-create buffer-name) + (rename-buffer new-buffer-name)) + (unwind-protect + (progn + (get-buffer-create buffer-name) + (funcall thunk)) + (when (get-buffer buffer-name) + (kill-buffer buffer-name)) + (with-current-buffer new-buffer-name + (rename-buffer buffer-name))))) + +(defmacro* ert-with-buffer-renamed ((buffer-name-form) &body body) + "Protect the buffer named BUFFER-NAME from side-effects and run BODY. + +See `ert-call-with-buffer-renamed' for details." + (declare (indent 1)) + `(ert-call-with-buffer-renamed ,buffer-name-form (lambda () ,@body))) + + +(defun ert-buffer-string-reindented (&optional buffer) + "Return the contents of BUFFER after reindentation. + +BUFFER defaults to current buffer. Does not modify BUFFER." + (with-current-buffer (or buffer (current-buffer)) + (let ((clone nil)) + (unwind-protect + (progn + ;; `clone-buffer' doesn't work if `buffer-file-name' is non-nil. + (let ((buffer-file-name nil)) + (setq clone (clone-buffer))) + (with-current-buffer clone + (let ((inhibit-read-only t)) + (indent-region (point-min) (point-max))) + (buffer-string))) + (when clone + (let ((kill-buffer-query-functions nil)) + (kill-buffer clone))))))) + + +(provide 'ert-x) + +;;; ert-x.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emacs-lisp/ert.el Thu Jan 13 09:17:33 2011 -0800 @@ -0,0 +1,2544 @@ +;;; ert.el --- Emacs Lisp Regression Testing + +;; Copyright (C) 2007, 2008, 2010, 2011 Free Software Foundation, Inc. + +;; Author: Christian Ohler <ohler@gnu.org> +;; Keywords: lisp, tools + +;; This file is part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `http://www.gnu.org/licenses/'. + +;;; Commentary: + +;; ERT is a tool for automated testing in Emacs Lisp. Its main +;; features are facilities for defining and running test cases and +;; reporting the results as well as for debugging test failures +;; interactively. +;; +;; The main entry points are `ert-deftest', which is similar to +;; `defun' but defines a test, and `ert-run-tests-interactively', +;; which runs tests and offers an interactive interface for inspecting +;; results and debugging. There is also +;; `ert-run-tests-batch-and-exit' for non-interactive use. +;; +;; The body of `ert-deftest' forms resembles a function body, but the +;; additional operators `should', `should-not' and `should-error' are +;; available. `should' is similar to cl's `assert', but signals a +;; different error when its condition is violated that is caught and +;; processed by ERT. In addition, it analyzes its argument form and +;; records information that helps debugging (`assert' tries to do +;; something similar when its second argument SHOW-ARGS is true, but +;; `should' is more sophisticated). For information on `should-not' +;; and `should-error', see their docstrings. +;; +;; See ERT's info manual as well as the docstrings for more details. +;; To compile the manual, run `makeinfo ert.texinfo' in the ERT +;; directory, then C-u M-x info ert.info in Emacs to view it. +;; +;; To see some examples of tests written in ERT, see its self-tests in +;; ert-tests.el. Some of these are tricky due to the bootstrapping +;; problem of writing tests for a testing tool, others test simple +;; functions and are straightforward. + +;;; Code: + +(eval-when-compile + (require 'cl)) +(require 'button) +(require 'debug) +(require 'easymenu) +(require 'ewoc) +(require 'find-func) +(require 'help) + + +;;; UI customization options. + +(defgroup ert () + "ERT, the Emacs Lisp regression testing tool." + :prefix "ert-" + :group 'lisp) + +(defface ert-test-result-expected '((((class color) (background light)) + :background "green1") + (((class color) (background dark)) + :background "green3")) + "Face used for expected results in the ERT results buffer." + :group 'ert) + +(defface ert-test-result-unexpected '((((class color) (background light)) + :background "red1") + (((class color) (background dark)) + :background "red3")) + "Face used for unexpected results in the ERT results buffer." + :group 'ert) + + +;;; Copies/reimplementations of cl functions. + +(defun ert--cl-do-remf (plist tag) + "Copy of `cl-do-remf'. Modify PLIST by removing TAG." + (let ((p (cdr plist))) + (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p)))) + (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t)))) + +(defun ert--remprop (sym tag) + "Copy of `cl-remprop'. Modify SYM's plist by removing TAG." + (let ((plist (symbol-plist sym))) + (if (and plist (eq tag (car plist))) + (progn (setplist sym (cdr (cdr plist))) t) + (ert--cl-do-remf plist tag)))) + +(defun ert--remove-if-not (ert-pred ert-list) + "A reimplementation of `remove-if-not'. + +ERT-PRED is a predicate, ERT-LIST is the input list." + (loop for ert-x in ert-list + if (funcall ert-pred ert-x) + collect ert-x)) + +(defun ert--intersection (a b) + "A reimplementation of `intersection'. Intersect the sets A and B. + +Elements are compared using `eql'." + (loop for x in a + if (memql x b) + collect x)) + +(defun ert--set-difference (a b) + "A reimplementation of `set-difference'. Subtract the set B from the set A. + +Elements are compared using `eql'." + (loop for x in a + unless (memql x b) + collect x)) + +(defun ert--set-difference-eq (a b) + "A reimplementation of `set-difference'. Subtract the set B from the set A. + +Elements are compared using `eq'." + (loop for x in a + unless (memq x b) + collect x)) + +(defun ert--union (a b) + "A reimplementation of `union'. Compute the union of the sets A and B. + +Elements are compared using `eql'." + (append a (ert--set-difference b a))) + +(eval-and-compile + (defvar ert--gensym-counter 0)) + +(eval-and-compile + (defun ert--gensym (&optional prefix) + "Only allows string PREFIX, not compatible with CL." + (unless prefix (setq prefix "G")) + (make-symbol (format "%s%s" + prefix + (prog1 ert--gensym-counter + (incf ert--gensym-counter)))))) + +(defun ert--coerce-to-vector (x) + "Coerce X to a vector." + (when (char-table-p x) (error "Not supported")) + (if (vectorp x) + x + (vconcat x))) + +(defun* ert--remove* (x list &key key test) + "Does not support all the keywords of remove*." + (unless key (setq key #'identity)) + (unless test (setq test #'eql)) + (loop for y in list + unless (funcall test x (funcall key y)) + collect y)) + +(defun ert--string-position (c s) + "Return the position of the first occurrence of C in S, or nil if none." + (loop for i from 0 + for x across s + when (eql x c) return i)) + +(defun ert--mismatch (a b) + "Return index of first element that differs between A and B. + +Like `mismatch'. Uses `equal' for comparison." + (cond ((or (listp a) (listp b)) + (ert--mismatch (ert--coerce-to-vector a) + (ert--coerce-to-vector b))) + ((> (length a) (length b)) + (ert--mismatch b a)) + (t + (let ((la (length a)) + (lb (length b))) + (assert (arrayp a) t) + (assert (arrayp b) t) + (assert (<= la lb) t) + (loop for i below la + when (not (equal (aref a i) (aref b i))) return i + finally (return (if (/= la lb) + la + (assert (equal a b) t) + nil))))))) + +(defun ert--subseq (seq start &optional end) + "Return a subsequence of SEQ from START to END." + (when (char-table-p seq) (error "Not supported")) + (let ((vector (substring (ert--coerce-to-vector seq) start end))) + (etypecase seq + (vector vector) + (string (concat vector)) + (list (append vector nil)) + (bool-vector (loop with result = (make-bool-vector (length vector) nil) + for i below (length vector) do + (setf (aref result i) (aref vector i)) + finally (return result))) + (char-table (assert nil))))) + +(defun ert-equal-including-properties (a b) + "Return t if A and B have similar structure and contents. + +This is like `equal-including-properties' except that it compares +the property values of text properties structurally (by +recursing) rather than with `eq'. Perhaps this is what +`equal-including-properties' should do in the first place; see +Emacs bug 6581 at URL `http://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'." + ;; This implementation is inefficient. Rather than making it + ;; efficient, let's hope bug 6581 gets fixed so that we can delete + ;; it altogether. + (not (ert--explain-not-equal-including-properties a b))) + + +;;; Defining and locating tests. + +;; The data structure that represents a test case. +(defstruct ert-test + (name nil) + (documentation nil) + (body (assert nil)) + (most-recent-result nil) + (expected-result-type ':passed) + (tags '())) + +(defun ert-test-boundp (symbol) + "Return non-nil if SYMBOL names a test." + (and (get symbol 'ert--test) t)) + +(defun ert-get-test (symbol) + "If SYMBOL names a test, return that. Signal an error otherwise." + (unless (ert-test-boundp symbol) (error "No test named `%S'" symbol)) + (get symbol 'ert--test)) + +(defun ert-set-test (symbol definition) + "Make SYMBOL name the test DEFINITION, and return DEFINITION." + (when (eq symbol 'nil) + ;; We disallow nil since `ert-test-at-point' and related functions + ;; want to return a test name, but also need an out-of-band value + ;; on failure. Nil is the most natural out-of-band value; using 0 + ;; or "" or signalling an error would be too awkward. + ;; + ;; Note that nil is still a valid value for the `name' slot in + ;; ert-test objects. It designates an anonymous test. + (error "Attempt to define a test named nil")) + (put symbol 'ert--test definition) + definition) + +(defun ert-make-test-unbound (symbol) + "Make SYMBOL name no test. Return SYMBOL." + (ert--remprop symbol 'ert--test) + symbol) + +(defun ert--parse-keys-and-body (keys-and-body) + "Split KEYS-AND-BODY into keyword-and-value pairs and the remaining body. + +KEYS-AND-BODY should have the form of a property list, with the +exception that only keywords are permitted as keys and that the +tail -- the body -- is a list of forms that does not start with a +keyword. + +Returns a two-element list containing the keys-and-values plist +and the body." + (let ((extracted-key-accu '()) + (remaining keys-and-body)) + (while (and (consp remaining) (keywordp (first remaining))) + (let ((keyword (pop remaining))) + (unless (consp remaining) + (error "Value expected after keyword %S in %S" + keyword keys-and-body)) + (when (assoc keyword extracted-key-accu) + (warn "Keyword %S appears more than once in %S" keyword + keys-and-body)) + (push (cons keyword (pop remaining)) extracted-key-accu))) + (setq extracted-key-accu (nreverse extracted-key-accu)) + (list (loop for (key . value) in extracted-key-accu + collect key + collect value) + remaining))) + +;;;###autoload +(defmacro* ert-deftest (name () &body docstring-keys-and-body) + "Define NAME (a symbol) as a test. + +BODY is evaluated as a `progn' when the test is run. It should +signal a condition on failure or just return if the test passes. + +`should', `should-not' and `should-error' are useful for +assertions in BODY. + +Use `ert' to run tests interactively. + +Tests that are expected to fail can be marked as such +using :expected-result. See `ert-test-result-type-p' for a +description of valid values for RESULT-TYPE. + +\(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \ +\[:tags '(TAG...)] BODY...)" + (declare (debug (&define :name test + name sexp [&optional stringp] + [&rest keywordp sexp] def-body)) + (doc-string 3) + (indent 2)) + (let ((documentation nil) + (documentation-supplied-p nil)) + (when (stringp (first docstring-keys-and-body)) + (setq documentation (pop docstring-keys-and-body) + documentation-supplied-p t)) + (destructuring-bind ((&key (expected-result nil expected-result-supplied-p) + (tags nil tags-supplied-p)) + body) + (ert--parse-keys-and-body docstring-keys-and-body) + `(progn + (ert-set-test ',name + (make-ert-test + :name ',name + ,@(when documentation-supplied-p + `(:documentation ,documentation)) + ,@(when expected-result-supplied-p + `(:expected-result-type ,expected-result)) + ,@(when tags-supplied-p + `(:tags ,tags)) + :body (lambda () ,@body))) + ;; This hack allows `symbol-file' to associate `ert-deftest' + ;; forms with files, and therefore enables `find-function' to + ;; work with tests. However, it leads to warnings in + ;; `unload-feature', which doesn't know how to undefine tests + ;; and has no mechanism for extension. + (push '(ert-deftest . ,name) current-load-list) + ',name)))) + +;; We use these `put' forms in addition to the (declare (indent)) in +;; the defmacro form since the `declare' alone does not lead to +;; correct indentation before the .el/.elc file is loaded. +;; Autoloading these `put' forms solves this. +;;;###autoload +(progn + ;; TODO(ohler): Figure out what these mean and make sure they are correct. + (put 'ert-deftest 'lisp-indent-function 2) + (put 'ert-info 'lisp-indent-function 1)) + +(defvar ert--find-test-regexp + (concat "^\\s-*(ert-deftest" + find-function-space-re + "%s\\(\\s-\\|$\\)") + "The regexp the `find-function' mechanisms use for finding test definitions.") + + +(put 'ert-test-failed 'error-conditions '(error ert-test-failed)) +(put 'ert-test-failed 'error-message "Test failed") + +(defun ert-pass () + "Terminate the current test and mark it passed. Does not return." + (throw 'ert--pass nil)) + +(defun ert-fail (data) + "Terminate the current test and mark it failed. Does not return. +DATA is displayed to the user and should state the reason of the failure." + (signal 'ert-test-failed (list data))) + + +;;; The `should' macros. + +(defvar ert--should-execution-observer nil) + +(defun ert--signal-should-execution (form-description) + "Tell the current `should' form observer (if any) about FORM-DESCRIPTION." + (when ert--should-execution-observer + (funcall ert--should-execution-observer form-description))) + +(defun ert--special-operator-p (thing) + "Return non-nil if THING is a symbol naming a special operator." + (and (symbolp thing) + (let ((definition (indirect-function thing t))) + (and (subrp definition) + (eql (cdr (subr-arity definition)) 'unevalled))))) + +(defun ert--expand-should-1 (whole form inner-expander) + "Helper function for the `should' macro and its variants." + (let ((form + ;; If `cl-macroexpand' isn't bound, the code that we're + ;; compiling doesn't depend on cl and thus doesn't need an + ;; environment arg for `macroexpand'. + (if (fboundp 'cl-macroexpand) + ;; Suppress warning about run-time call to cl funtion: we + ;; only call it if it's fboundp. + (with-no-warnings + (cl-macroexpand form (and (boundp 'cl-macro-environment) + cl-macro-environment))) + (macroexpand form)))) + (cond + ((or (atom form) (ert--special-operator-p (car form))) + (let ((value (ert--gensym "value-"))) + `(let ((,value (ert--gensym "ert-form-evaluation-aborted-"))) + ,(funcall inner-expander + `(setq ,value ,form) + `(list ',whole :form ',form :value ,value) + value) + ,value))) + (t + (let ((fn-name (car form)) + (arg-forms (cdr form))) + (assert (or (symbolp fn-name) + (and (consp fn-name) + (eql (car fn-name) 'lambda) + (listp (cdr fn-name))))) + (let ((fn (ert--gensym "fn-")) + (args (ert--gensym "args-")) + (value (ert--gensym "value-")) + (default-value (ert--gensym "ert-form-evaluation-aborted-"))) + `(let ((,fn (function ,fn-name)) + (,args (list ,@arg-forms))) + (let ((,value ',default-value)) + ,(funcall inner-expander + `(setq ,value (apply ,fn ,args)) + `(nconc (list ',whole) + (list :form `(,,fn ,@,args)) + (unless (eql ,value ',default-value) + (list :value ,value)) + (let ((-explainer- + (and (symbolp ',fn-name) + (get ',fn-name 'ert-explainer)))) + (when -explainer- + (list :explanation + (apply -explainer- ,args))))) + value) + ,value)))))))) + +(defun ert--expand-should (whole form inner-expander) + "Helper function for the `should' macro and its variants. + +Analyzes FORM and returns an expression that has the same +semantics under evaluation but records additional debugging +information. + +INNER-EXPANDER should be a function and is called with two +arguments: INNER-FORM and FORM-DESCRIPTION-FORM, where INNER-FORM +is an expression equivalent to FORM, and FORM-DESCRIPTION-FORM is +an expression that returns a description of FORM. INNER-EXPANDER +should return code that calls INNER-FORM and performs the checks +and error signalling specific to the particular variant of +`should'. The code that INNER-EXPANDER returns must not call +FORM-DESCRIPTION-FORM before it has called INNER-FORM." + (lexical-let ((inner-expander inner-expander)) + (ert--expand-should-1 + whole form + (lambda (inner-form form-description-form value-var) + (let ((form-description (ert--gensym "form-description-"))) + `(let (,form-description) + ,(funcall inner-expander + `(unwind-protect + ,inner-form + (setq ,form-description ,form-description-form) + (ert--signal-should-execution ,form-description)) + `,form-description + value-var))))))) + +(defmacro* should (form) + "Evaluate FORM. If it returns nil, abort the current test as failed. + +Returns the value of FORM." + (ert--expand-should `(should ,form) form + (lambda (inner-form form-description-form value-var) + `(unless ,inner-form + (ert-fail ,form-description-form))))) + +(defmacro* should-not (form) + "Evaluate FORM. If it returns non-nil, abort the current test as failed. + +Returns nil." + (ert--expand-should `(should-not ,form) form + (lambda (inner-form form-description-form value-var) + `(unless (not ,inner-form) + (ert-fail ,form-description-form))))) + +(defun ert--should-error-handle-error (form-description-fn + condition type exclude-subtypes) + "Helper function for `should-error'. + +Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES, +and aborts the current test as failed if it doesn't." + (let ((signalled-conditions (get (car condition) 'error-conditions)) + (handled-conditions (etypecase type + (list type) + (symbol (list type))))) + (assert signalled-conditions) + (unless (ert--intersection signalled-conditions handled-conditions) + (ert-fail (append + (funcall form-description-fn) + (list + :condition condition + :fail-reason (concat "the error signalled did not" + " have the expected type"))))) + (when exclude-subtypes + (unless (member (car condition) handled-conditions) + (ert-fail (append + (funcall form-description-fn) + (list + :condition condition + :fail-reason (concat "the error signalled was a subtype" + " of the expected type")))))))) + +;; FIXME: The expansion will evaluate the keyword args (if any) in +;; nonstandard order. +(defmacro* should-error (form &rest keys &key type exclude-subtypes) + "Evaluate FORM and check that it signals an error. + +The error signalled needs to match TYPE. TYPE should be a list +of condition names. (It can also be a non-nil symbol, which is +equivalent to a singleton list containing that symbol.) If +EXCLUDE-SUBTYPES is nil, the error matches TYPE if one of its +condition names is an element of TYPE. If EXCLUDE-SUBTYPES is +non-nil, the error matches TYPE if it is an element of TYPE. + +If the error matches, returns (ERROR-SYMBOL . DATA) from the +error. If not, or if no error was signalled, abort the test as +failed." + (unless type (setq type ''error)) + (ert--expand-should + `(should-error ,form ,@keys) + form + (lambda (inner-form form-description-form value-var) + (let ((errorp (ert--gensym "errorp")) + (form-description-fn (ert--gensym "form-description-fn-"))) + `(let ((,errorp nil) + (,form-description-fn (lambda () ,form-description-form))) + (condition-case -condition- + ,inner-form + ;; We can't use ,type here because we want to evaluate it. + (error + (setq ,errorp t) + (ert--should-error-handle-error ,form-description-fn + -condition- + ,type ,exclude-subtypes) + (setq ,value-var -condition-))) + (unless ,errorp + (ert-fail (append + (funcall ,form-description-fn) + (list + :fail-reason "did not signal an error"))))))))) + + +;;; Explanation of `should' failures. + +;; TODO(ohler): Rework explanations so that they are displayed in a +;; similar way to `ert-info' messages; in particular, allow text +;; buttons in explanations that give more detail or open an ediff +;; buffer. Perhaps explanations should be reported through `ert-info' +;; rather than as part of the condition. + +(defun ert--proper-list-p (x) + "Return non-nil if X is a proper list, nil otherwise." + (loop + for firstp = t then nil + for fast = x then (cddr fast) + for slow = x then (cdr slow) do + (when (null fast) (return t)) + (when (not (consp fast)) (return nil)) + (when (null (cdr fast)) (return t)) + (when (not (consp (cdr fast))) (return nil)) + (when (and (not firstp) (eq fast slow)) (return nil)))) + +(defun ert--explain-format-atom (x) + "Format the atom X for `ert--explain-not-equal'." + (typecase x + (fixnum (list x (format "#x%x" x) (format "?%c" x))) + (t x))) + +(defun ert--explain-not-equal (a b) + "Explainer function for `equal'. + +Returns a programmer-readable explanation of why A and B are not +`equal', or nil if they are." + (if (not (equal (type-of a) (type-of b))) + `(different-types ,a ,b) + (etypecase a + (cons + (let ((a-proper-p (ert--proper-list-p a)) + (b-proper-p (ert--proper-list-p b))) + (if (not (eql (not a-proper-p) (not b-proper-p))) + `(one-list-proper-one-improper ,a ,b) + (if a-proper-p + (if (not (equal (length a) (length b))) + `(proper-lists-of-different-length ,(length a) ,(length b) + ,a ,b + first-mismatch-at + ,(ert--mismatch a b)) + (loop for i from 0 + for ai in a + for bi in b + for xi = (ert--explain-not-equal ai bi) + do (when xi (return `(list-elt ,i ,xi))) + finally (assert (equal a b) t))) + (let ((car-x (ert--explain-not-equal (car a) (car b)))) + (if car-x + `(car ,car-x) + (let ((cdr-x (ert--explain-not-equal (cdr a) (cdr b)))) + (if cdr-x + `(cdr ,cdr-x) + (assert (equal a b) t) + nil)))))))) + (array (if (not (equal (length a) (length b))) + `(arrays-of-different-length ,(length a) ,(length b) + ,a ,b + ,@(unless (char-table-p a) + `(first-mismatch-at + ,(ert--mismatch a b)))) + (loop for i from 0 + for ai across a + for bi across b + for xi = (ert--explain-not-equal ai bi) + do (when xi (return `(array-elt ,i ,xi))) + finally (assert (equal a b) t)))) + (atom (if (not (equal a b)) + (if (and (symbolp a) (symbolp b) (string= a b)) + `(different-symbols-with-the-same-name ,a ,b) + `(different-atoms ,(ert--explain-format-atom a) + ,(ert--explain-format-atom b))) + nil))))) +(put 'equal 'ert-explainer 'ert--explain-not-equal) + +(defun ert--significant-plist-keys (plist) + "Return the keys of PLIST that have non-null values, in order." + (assert (zerop (mod (length plist) 2)) t) + (loop for (key value . rest) on plist by #'cddr + unless (or (null value) (memq key accu)) collect key into accu + finally (return accu))) + +(defun ert--plist-difference-explanation (a b) + "Return a programmer-readable explanation of why A and B are different plists. + +Returns nil if they are equivalent, i.e., have the same value for +each key, where absent values are treated as nil. The order of +key/value pairs in each list does not matter." + (assert (zerop (mod (length a) 2)) t) + (assert (zerop (mod (length b) 2)) t) + ;; Normalizing the plists would be another way to do this but it + ;; requires a total ordering on all lisp objects (since any object + ;; is valid as a text property key). Perhaps defining such an + ;; ordering is useful in other contexts, too, but it's a lot of + ;; work, so let's punt on it for now. + (let* ((keys-a (ert--significant-plist-keys a)) + (keys-b (ert--significant-plist-keys b)) + (keys-in-a-not-in-b (ert--set-difference-eq keys-a keys-b)) + (keys-in-b-not-in-a (ert--set-difference-eq keys-b keys-a))) + (flet ((explain-with-key (key) + (let ((value-a (plist-get a key)) + (value-b (plist-get b key))) + (assert (not (equal value-a value-b)) t) + `(different-properties-for-key + ,key ,(ert--explain-not-equal-including-properties value-a + value-b))))) + (cond (keys-in-a-not-in-b + (explain-with-key (first keys-in-a-not-in-b))) + (keys-in-b-not-in-a + (explain-with-key (first keys-in-b-not-in-a))) + (t + (loop for key in keys-a + when (not (equal (plist-get a key) (plist-get b key))) + return (explain-with-key key))))))) + +(defun ert--abbreviate-string (s len suffixp) + "Shorten string S to at most LEN chars. + +If SUFFIXP is non-nil, returns a suffix of S, otherwise a prefix." + (let ((n (length s))) + (cond ((< n len) + s) + (suffixp + (substring s (- n len))) + (t + (substring s 0 len))))) + +(defun ert--explain-not-equal-including-properties (a b) + "Explainer function for `ert-equal-including-properties'. + +Returns a programmer-readable explanation of why A and B are not +`ert-equal-including-properties', or nil if they are." + (if (not (equal a b)) + (ert--explain-not-equal a b) + (assert (stringp a) t) + (assert (stringp b) t) + (assert (eql (length a) (length b)) t) + (loop for i from 0 to (length a) + for props-a = (text-properties-at i a) + for props-b = (text-properties-at i b) + for difference = (ert--plist-difference-explanation props-a props-b) + do (when difference + (return `(char ,i ,(substring-no-properties a i (1+ i)) + ,difference + context-before + ,(ert--abbreviate-string + (substring-no-properties a 0 i) + 10 t) + context-after + ,(ert--abbreviate-string + (substring-no-properties a (1+ i)) + 10 nil)))) + ;; TODO(ohler): Get `equal-including-properties' fixed in + ;; Emacs, delete `ert-equal-including-properties', and + ;; re-enable this assertion. + ;;finally (assert (equal-including-properties a b) t) + ))) +(put 'ert-equal-including-properties + 'ert-explainer + 'ert--explain-not-equal-including-properties) + + +;;; Implementation of `ert-info'. + +;; TODO(ohler): The name `info' clashes with +;; `ert--test-execution-info'. One or both should be renamed. +(defvar ert--infos '() + "The stack of `ert-info' infos that currently apply. + +Bound dynamically. This is a list of (PREFIX . MESSAGE) pairs.") + +(defmacro* ert-info ((message-form &key ((:prefix prefix-form) "Info: ")) + &body body) + "Evaluate MESSAGE-FORM and BODY, and report the message if BODY fails. + +To be used within ERT tests. MESSAGE-FORM should evaluate to a +string that will be displayed together with the test result if +the test fails. PREFIX-FORM should evaluate to a string as well +and is displayed in front of the value of MESSAGE-FORM." + (declare (debug ((form &rest [sexp form]) body)) + (indent 1)) + `(let ((ert--infos (cons (cons ,prefix-form ,message-form) ert--infos))) + ,@body)) + + + +;;; Facilities for running a single test. + +(defvar ert-debug-on-error nil + "Non-nil means enter debugger when a test fails or terminates with an error.") + +;; The data structures that represent the result of running a test. +(defstruct ert-test-result + (messages nil) + (should-forms nil) + ) +(defstruct (ert-test-passed (:include ert-test-result))) +(defstruct (ert-test-result-with-condition (:include ert-test-result)) + (condition (assert nil)) + (backtrace (assert nil)) + (infos (assert nil))) +(defstruct (ert-test-quit (:include ert-test-result-with-condition))) +(defstruct (ert-test-failed (:include ert-test-result-with-condition))) +(defstruct (ert-test-aborted-with-non-local-exit (:include ert-test-result))) + + +(defun ert--record-backtrace () + "Record the current backtrace (as a list) and return it." + ;; Since the backtrace is stored in the result object, result + ;; objects must only be printed with appropriate limits + ;; (`print-level' and `print-length') in place. For interactive + ;; use, the cost of ensuring this possibly outweighs the advantage + ;; of storing the backtrace for + ;; `ert-results-pop-to-backtrace-for-test-at-point' given that we + ;; already have `ert-results-rerun-test-debugging-errors-at-point'. + ;; For batch use, however, printing the backtrace may be useful. + (loop + ;; 6 is the number of frames our own debugger adds (when + ;; compiled; more when interpreted). FIXME: Need to describe a + ;; procedure for determining this constant. + for i from 6 + for frame = (backtrace-frame i) + while frame + collect frame)) + +(defun ert--print-backtrace (backtrace) + "Format the backtrace BACKTRACE to the current buffer." + ;; This is essentially a reimplementation of Fbacktrace + ;; (src/eval.c), but for a saved backtrace, not the current one. + (let ((print-escape-newlines t) + (print-level 8) + (print-length 50)) + (dolist (frame backtrace) + (ecase (first frame) + ((nil) + ;; Special operator. + (destructuring-bind (special-operator &rest arg-forms) + (cdr frame) + (insert + (format " %S\n" (list* special-operator arg-forms))))) + ((t) + ;; Function call. + (destructuring-bind (fn &rest args) (cdr frame) + (insert (format " %S(" fn)) + (loop for firstp = t then nil + for arg in args do + (unless firstp + (insert " ")) + (insert (format "%S" arg))) + (insert ")\n"))))))) + +;; A container for the state of the execution of a single test and +;; environment data needed during its execution. +(defstruct ert--test-execution-info + (test (assert nil)) + (result (assert nil)) + ;; A thunk that may be called when RESULT has been set to its final + ;; value and test execution should be terminated. Should not + ;; return. + (exit-continuation (assert nil)) + ;; The binding of `debugger' outside of the execution of the test. + next-debugger + ;; The binding of `ert-debug-on-error' that is in effect for the + ;; execution of the current test. We store it to avoid being + ;; affected by any new bindings the test itself may establish. (I + ;; don't remember whether this feature is important.) + ert-debug-on-error) + +(defun ert--run-test-debugger (info debugger-args) + "During a test run, `debugger' is bound to a closure that calls this function. + +This function records failures and errors and either terminates +the test silently or calls the interactive debugger, as +appropriate. + +INFO is the ert--test-execution-info corresponding to this test +run. DEBUGGER-ARGS are the arguments to `debugger'." + (destructuring-bind (first-debugger-arg &rest more-debugger-args) + debugger-args + (ecase first-debugger-arg + ((lambda debug t exit nil) + (apply (ert--test-execution-info-next-debugger info) debugger-args)) + (error + (let* ((condition (first more-debugger-args)) + (type (case (car condition) + ((quit) 'quit) + (otherwise 'failed))) + (backtrace (ert--record-backtrace)) + (infos (reverse ert--infos))) + (setf (ert--test-execution-info-result info) + (ecase type + (quit + (make-ert-test-quit :condition condition + :backtrace backtrace + :infos infos)) + (failed + (make-ert-test-failed :condition condition + :backtrace backtrace + :infos infos)))) + ;; Work around Emacs' heuristic (in eval.c) for detecting + ;; errors in the debugger. + (incf num-nonmacro-input-events) + ;; FIXME: We should probably implement more fine-grained + ;; control a la non-t `debug-on-error' here. + (cond + ((ert--test-execution-info-ert-debug-on-error info) + (apply (ert--test-execution-info-next-debugger info) debugger-args)) + (t)) + (funcall (ert--test-execution-info-exit-continuation info))))))) + +(defun ert--run-test-internal (ert-test-execution-info) + "Low-level function to run a test according to ERT-TEST-EXECUTION-INFO. + +This mainly sets up debugger-related bindings." + (lexical-let ((info ert-test-execution-info)) + (setf (ert--test-execution-info-next-debugger info) debugger + (ert--test-execution-info-ert-debug-on-error info) ert-debug-on-error) + (catch 'ert--pass + ;; For now, each test gets its own temp buffer and its own + ;; window excursion, just to be safe. If this turns out to be + ;; too expensive, we can remove it. + (with-temp-buffer + (save-window-excursion + (let ((debugger (lambda (&rest debugger-args) + (ert--run-test-debugger info debugger-args))) + (debug-on-error t) + (debug-on-quit t) + ;; FIXME: Do we need to store the old binding of this + ;; and consider it in `ert--run-test-debugger'? + (debug-ignored-errors nil) + (ert--infos '())) + (funcall (ert-test-body (ert--test-execution-info-test info)))))) + (ert-pass)) + (setf (ert--test-execution-info-result info) (make-ert-test-passed))) + nil) + +(defun ert--force-message-log-buffer-truncation () + "Immediately truncate *Messages* buffer according to `message-log-max'. + +This can be useful after reducing the value of `message-log-max'." + (with-current-buffer (get-buffer-create "*Messages*") + ;; This is a reimplementation of this part of message_dolog() in xdisp.c: + ;; if (NATNUMP (Vmessage_log_max)) + ;; { + ;; scan_newline (Z, Z_BYTE, BEG, BEG_BYTE, + ;; -XFASTINT (Vmessage_log_max) - 1, 0); + ;; del_range_both (BEG, BEG_BYTE, PT, PT_BYTE, 0); + ;; } + (when (and (integerp message-log-max) (>= message-log-max 0)) + (let ((begin (point-min)) + (end (save-excursion + (goto-char (point-max)) + (forward-line (- message-log-max)) + (point)))) + (delete-region begin end))))) + +(defvar ert--running-tests nil + "List of tests that are currently in execution. + +This list is empty while no test is running, has one element +while a test is running, two elements while a test run from +inside a test is running, etc. The list is in order of nesting, +innermost test first. + +The elements are of type `ert-test'.") + +(defun ert-run-test (ert-test) + "Run ERT-TEST. + +Returns the result and stores it in ERT-TEST's `most-recent-result' slot." + (setf (ert-test-most-recent-result ert-test) nil) + (block error + (lexical-let ((begin-marker + (with-current-buffer (get-buffer-create "*Messages*") + (set-marker (make-marker) (point-max))))) + (unwind-protect + (lexical-let ((info (make-ert--test-execution-info + :test ert-test + :result + (make-ert-test-aborted-with-non-local-exit) + :exit-continuation (lambda () + (return-from error nil)))) + (should-form-accu (list))) + (unwind-protect + (let ((ert--should-execution-observer + (lambda (form-description) + (push form-description should-form-accu))) + (message-log-max t) + (ert--running-tests (cons ert-test ert--running-tests))) + (ert--run-test-internal info)) + (let ((result (ert--test-execution-info-result info))) + (setf (ert-test-result-messages result) + (with-current-buffer (get-buffer-create "*Messages*") + (buffer-substring begin-marker (point-max)))) + (ert--force-message-log-buffer-truncation) + (setq should-form-accu (nreverse should-form-accu)) + (setf (ert-test-result-should-forms result) + should-form-accu) + (setf (ert-test-most-recent-result ert-test) result)))) + (set-marker begin-marker nil)))) + (ert-test-most-recent-result ert-test)) + +(defun ert-running-test () + "Return the top-level test currently executing." + (car (last ert--running-tests))) + + +;;; Test selectors. + +(defun ert-test-result-type-p (result result-type) + "Return non-nil if RESULT matches type RESULT-TYPE. + +Valid result types: + +nil -- Never matches. +t -- Always matches. +:failed, :passed -- Matches corresponding results. +\(and TYPES...\) -- Matches if all TYPES match. +\(or TYPES...\) -- Matches if some TYPES match. +\(not TYPE\) -- Matches if TYPE does not match. +\(satisfies PREDICATE\) -- Matches if PREDICATE returns true when called with + RESULT." + ;; It would be easy to add `member' and `eql' types etc., but I + ;; haven't bothered yet. + (etypecase result-type + ((member nil) nil) + ((member t) t) + ((member :failed) (ert-test-failed-p result)) + ((member :passed) (ert-test-passed-p result)) + (cons + (destructuring-bind (operator &rest operands) result-type + (ecase operator + (and + (case (length operands) + (0 t) + (t + (and (ert-test-result-type-p result (first operands)) + (ert-test-result-type-p result `(and ,@(rest operands))))))) + (or + (case (length operands) + (0 nil) + (t + (or (ert-test-result-type-p result (first operands)) + (ert-test-result-type-p result `(or ,@(rest operands))))))) + (not + (assert (eql (length operands) 1)) + (not (ert-test-result-type-p result (first operands)))) + (satisfies + (assert (eql (length operands) 1)) + (funcall (first operands) result))))))) + +(defun ert-test-result-expected-p (test result) + "Return non-nil if TEST's expected result type matches RESULT." + (ert-test-result-type-p result (ert-test-expected-result-type test))) + +(defun ert-select-tests (selector universe) + "Return the tests that match SELECTOR. + +UNIVERSE specifies the set of tests to select from; it should be +a list of tests, or t, which refers to all tests named by symbols +in `obarray'. + +Returns the set of tests as a list. + +Valid selectors: + +nil -- Selects the empty set. +t -- Selects UNIVERSE. +:new -- Selects all tests that have not been run yet. +:failed, :passed -- Select tests according to their most recent result. +:expected, :unexpected -- Select tests according to their most recent result. +a string -- Selects all tests that have a name that matches the string, + a regexp. +a test -- Selects that test. +a symbol -- Selects the test that the symbol names, errors if none. +\(member TESTS...\) -- Selects TESTS, a list of tests or symbols naming tests. +\(eql TEST\) -- Selects TEST, a test or a symbol naming a test. +\(and SELECTORS...\) -- Selects the tests that match all SELECTORS. +\(or SELECTORS...\) -- Selects the tests that match any SELECTOR. +\(not SELECTOR\) -- Selects all tests that do not match SELECTOR. +\(tag TAG) -- Selects all tests that have TAG on their tags list. +\(satisfies PREDICATE\) -- Selects all tests that satisfy PREDICATE. + +Only selectors that require a superset of tests, such +as (satisfies ...), strings, :new, etc. make use of UNIVERSE. +Selectors that do not, such as \(member ...\), just return the +set implied by them without checking whether it is really +contained in UNIVERSE." + ;; This code needs to match the etypecase in + ;; `ert-insert-human-readable-selector'. + (etypecase selector + ((member nil) nil) + ((member t) (etypecase universe + (list universe) + ((member t) (ert-select-tests "" universe)))) + ((member :new) (ert-select-tests + `(satisfies ,(lambda (test) + (null (ert-test-most-recent-result test)))) + universe)) + ((member :failed) (ert-select-tests + `(satisfies ,(lambda (test) + (ert-test-result-type-p + (ert-test-most-recent-result test) + ':failed))) + universe)) + ((member :passed) (ert-select-tests + `(satisfies ,(lambda (test) + (ert-test-result-type-p + (ert-test-most-recent-result test) + ':passed))) + universe)) + ((member :expected) (ert-select-tests + `(satisfies + ,(lambda (test) + (ert-test-result-expected-p + test + (ert-test-most-recent-result test)))) + universe)) + ((member :unexpected) (ert-select-tests `(not :expected) universe)) + (string + (etypecase universe + ((member t) (mapcar #'ert-get-test + (apropos-internal selector #'ert-test-boundp))) + (list (ert--remove-if-not (lambda (test) + (and (ert-test-name test) + (string-match selector + (ert-test-name test)))) + universe)))) + (ert-test (list selector)) + (symbol + (assert (ert-test-boundp selector)) + (list (ert-get-test selector))) + (cons + (destructuring-bind (operator &rest operands) selector + (ecase operator + (member + (mapcar (lambda (purported-test) + (etypecase purported-test + (symbol (assert (ert-test-boundp purported-test)) + (ert-get-test purported-test)) + (ert-test purported-test))) + operands)) + (eql + (assert (eql (length operands) 1)) + (ert-select-tests `(member ,@operands) universe)) + (and + ;; Do these definitions of AND, NOT and OR satisfy de + ;; Morgan's laws? Should they? + (case (length operands) + (0 (ert-select-tests 't universe)) + (t (ert-select-tests `(and ,@(rest operands)) + (ert-select-tests (first operands) + universe))))) + (not + (assert (eql (length operands) 1)) + (let ((all-tests (ert-select-tests 't universe))) + (ert--set-difference all-tests + (ert-select-tests (first operands) + all-tests)))) + (or + (case (length operands) + (0 (ert-select-tests 'nil universe)) + (t (ert--union (ert-select-tests (first operands) universe) + (ert-select-tests `(or ,@(rest operands)) + universe))))) + (tag + (assert (eql (length operands) 1)) + (let ((tag (first operands))) + (ert-select-tests `(satisfies + ,(lambda (test) + (member tag (ert-test-tags test)))) + universe))) + (satisfies + (assert (eql (length operands) 1)) + (ert--remove-if-not (first operands) + (ert-select-tests 't universe)))))))) + +(defun ert--insert-human-readable-selector (selector) + "Insert a human-readable presentation of SELECTOR into the current buffer." + ;; This is needed to avoid printing the (huge) contents of the + ;; `backtrace' slot of the result objects in the + ;; `most-recent-result' slots of test case objects in (eql ...) or + ;; (member ...) selectors. + (labels ((rec (selector) + ;; This code needs to match the etypecase in `ert-select-tests'. + (etypecase selector + ((or (member nil t + :new :failed :passed + :expected :unexpected) + string + symbol) + selector) + (ert-test + (if (ert-test-name selector) + (make-symbol (format "<%S>" (ert-test-name selector))) + (make-symbol "<unnamed test>"))) + (cons + (destructuring-bind (operator &rest operands) selector + (ecase operator + ((member eql and not or) + `(,operator ,@(mapcar #'rec operands))) + ((member tag satisfies) + selector))))))) + (insert (format "%S" (rec selector))))) + + +;;; Facilities for running a whole set of tests. + +;; The data structure that contains the set of tests being executed +;; during one particular test run, their results, the state of the +;; execution, and some statistics. +;; +;; The data about results and expected results of tests may seem +;; redundant here, since the test objects also carry such information. +;; However, the information in the test objects may be more recent, it +;; may correspond to a different test run. We need the information +;; that corresponds to this run in order to be able to update the +;; statistics correctly when a test is re-run interactively and has a +;; different result than before. +(defstruct ert--stats + (selector (assert nil)) + ;; The tests, in order. + (tests (assert nil) :type vector) + ;; A map of test names (or the test objects themselves for unnamed + ;; tests) to indices into the `tests' vector. + (test-map (assert nil) :type hash-table) + ;; The results of the tests during this run, in order. + (test-results (assert nil) :type vector) + ;; The start times of the tests, in order, as reported by + ;; `current-time'. + (test-start-times (assert nil) :type vector) + ;; The end times of the tests, in order, as reported by + ;; `current-time'. + (test-end-times (assert nil) :type vector) + (passed-expected 0) + (passed-unexpected 0) + (failed-expected 0) + (failed-unexpected 0) + (start-time nil) + (end-time nil) + (aborted-p nil) + (current-test nil) + ;; The time at or after which the next redisplay should occur, as a + ;; float. + (next-redisplay 0.0)) + +(defun ert-stats-completed-expected (stats) + "Return the number of tests in STATS that had expected results." + (+ (ert--stats-passed-expected stats) + (ert--stats-failed-expected stats))) + +(defun ert-stats-completed-unexpected (stats) + "Return the number of tests in STATS that had unexpected results." + (+ (ert--stats-passed-unexpected stats) + (ert--stats-failed-unexpected stats))) + +(defun ert-stats-completed (stats) + "Number of tests in STATS that have run so far." + (+ (ert-stats-completed-expected stats) + (ert-stats-completed-unexpected stats))) + +(defun ert-stats-total (stats) + "Number of tests in STATS, regardless of whether they have run yet." + (length (ert--stats-tests stats))) + +;; The stats object of the current run, dynamically bound. This is +;; used for the mode line progress indicator. +(defvar ert--current-run-stats nil) + +(defun ert--stats-test-key (test) + "Return the key used for TEST in the test map of ert--stats objects. + +Returns the name of TEST if it has one, or TEST itself otherwise." + (or (ert-test-name test) test)) + +(defun ert--stats-set-test-and-result (stats pos test result) + "Change STATS by replacing the test at position POS with TEST and RESULT. + +Also changes the counters in STATS to match." + (let* ((tests (ert--stats-tests stats)) + (results (ert--stats-test-results stats)) + (old-test (aref tests pos)) + (map (ert--stats-test-map stats))) + (flet ((update (d) + (if (ert-test-result-expected-p (aref tests pos) + (aref results pos)) + (etypecase (aref results pos) + (ert-test-passed (incf (ert--stats-passed-expected stats) d)) + (ert-test-failed (incf (ert--stats-failed-expected stats) d)) + (null) + (ert-test-aborted-with-non-local-exit)) + (etypecase (aref results pos) + (ert-test-passed (incf (ert--stats-passed-unexpected stats) d)) + (ert-test-failed (incf (ert--stats-failed-unexpected stats) d)) + (null) + (ert-test-aborted-with-non-local-exit))))) + ;; Adjust counters to remove the result that is currently in stats. + (update -1) + ;; Put new test and result into stats. + (setf (aref tests pos) test + (aref results pos) result) + (remhash (ert--stats-test-key old-test) map) + (setf (gethash (ert--stats-test-key test) map) pos) + ;; Adjust counters to match new result. + (update +1) + nil))) + +(defun ert--make-stats (tests selector) + "Create a new `ert--stats' object for running TESTS. + +SELECTOR is the selector that was used to select TESTS." + (setq tests (ert--coerce-to-vector tests)) + (let ((map (make-hash-table :size (length tests)))) + (loop for i from 0 + for test across tests + for key = (ert--stats-test-key test) do + (assert (not (gethash key map))) + (setf (gethash key map) i)) + (make-ert--stats :selector selector + :tests tests + :test-map map + :test-results (make-vector (length tests) nil) + :test-start-times (make-vector (length tests) nil) + :test-end-times (make-vector (length tests) nil)))) + +(defun ert-run-or-rerun-test (stats test listener) + ;; checkdoc-order: nil + "Run the single test TEST and record the result using STATS and LISTENER." + (let ((ert--current-run-stats stats) + (pos (ert--stats-test-pos stats test))) + (ert--stats-set-test-and-result stats pos test nil) + ;; Call listener after setting/before resetting + ;; (ert--stats-current-test stats); the listener might refresh the + ;; mode line display, and if the value is not set yet/any more + ;; during this refresh, the mode line will flicker unnecessarily. + (setf (ert--stats-current-test stats) test) + (funcall listener 'test-started stats test) + (setf (ert-test-most-recent-result test) nil) + (setf (aref (ert--stats-test-start-times stats) pos) (current-time)) + (unwind-protect + (ert-run-test test) + (setf (aref (ert--stats-test-end-times stats) pos) (current-time)) + (let ((result (ert-test-most-recent-result test))) + (ert--stats-set-test-and-result stats pos test result) + (funcall listener 'test-ended stats test result)) + (setf (ert--stats-current-test stats) nil)))) + +(defun ert-run-tests (selector listener) + "Run the tests specified by SELECTOR, sending progress updates to LISTENER." + (let* ((tests (ert-select-tests selector t)) + (stats (ert--make-stats tests selector))) + (setf (ert--stats-start-time stats) (current-time)) + (funcall listener 'run-started stats) + (let ((abortedp t)) + (unwind-protect + (let ((ert--current-run-stats stats)) + (force-mode-line-update) + (unwind-protect + (progn + (loop for test in tests do + (ert-run-or-rerun-test stats test listener)) + (setq abortedp nil)) + (setf (ert--stats-aborted-p stats) abortedp) + (setf (ert--stats-end-time stats) (current-time)) + (funcall listener 'run-ended stats abortedp))) + (force-mode-line-update)) + stats))) + +(defun ert--stats-test-pos (stats test) + ;; checkdoc-order: nil + "Return the position (index) of TEST in the run represented by STATS." + (gethash (ert--stats-test-key test) (ert--stats-test-map stats))) + + +;;; Formatting functions shared across UIs. + +(defun ert--format-time-iso8601 (time) + "Format TIME in the variant of ISO 8601 used for timestamps in ERT." + (format-time-string "%Y-%m-%d %T%z" time)) + +(defun ert-char-for-test-result (result expectedp) + "Return a character that represents the test result RESULT. + +EXPECTEDP specifies whether the result was expected." + (let ((s (etypecase result + (ert-test-passed ".P") + (ert-test-failed "fF") + (null "--") + (ert-test-aborted-with-non-local-exit "aA")))) + (elt s (if expectedp 0 1)))) + +(defun ert-string-for-test-result (result expectedp) + "Return a string that represents the test result RESULT. + +EXPECTEDP specifies whether the result was expected." + (let ((s (etypecase result + (ert-test-passed '("passed" "PASSED")) + (ert-test-failed '("failed" "FAILED")) + (null '("unknown" "UNKNOWN")) + (ert-test-aborted-with-non-local-exit '("aborted" "ABORTED"))))) + (elt s (if expectedp 0 1)))) + +(defun ert--pp-with-indentation-and-newline (object) + "Pretty-print OBJECT, indenting it to the current column of point. +Ensures a final newline is inserted." + (let ((begin (point))) + (pp object (current-buffer)) + (unless (bolp) (insert "\n")) + (save-excursion + (goto-char begin) + (indent-sexp)))) + +(defun ert--insert-infos (result) + "Insert `ert-info' infos from RESULT into current buffer. + +RESULT must be an `ert-test-result-with-condition'." + (check-type result ert-test-result-with-condition) + (dolist (info (ert-test-result-with-condition-infos result)) + (destructuring-bind (prefix . message) info + (let ((begin (point)) + (indentation (make-string (+ (length prefix) 4) ?\s)) + (end nil)) + (unwind-protect + (progn + (insert message "\n") + (setq end (copy-marker (point))) + (goto-char begin) + (insert " " prefix) + (forward-line 1) + (while (< (point) end) + (insert indentation) + (forward-line 1))) + (when end (set-marker end nil))))))) + + +;;; Running tests in batch mode. + +(defvar ert-batch-backtrace-right-margin 70 + "*The maximum line length for printing backtraces in `ert-run-tests-batch'.") + +;;;###autoload +(defun ert-run-tests-batch (&optional selector) + "Run the tests specified by SELECTOR, printing results to the terminal. + +SELECTOR works as described in `ert-select-tests', except if +SELECTOR is nil, in which case all tests rather than none will be +run; this makes the command line \"emacs -batch -l my-tests.el -f +ert-run-tests-batch-and-exit\" useful. + +Returns the stats object." + (unless selector (setq selector 't)) + (ert-run-tests + selector + (lambda (event-type &rest event-args) + (ecase event-type + (run-started + (destructuring-bind (stats) event-args + (message "Running %s tests (%s)" + (length (ert--stats-tests stats)) + (ert--format-time-iso8601 (ert--stats-start-time stats))))) + (run-ended + (destructuring-bind (stats abortedp) event-args + (let ((unexpected (ert-stats-completed-unexpected stats)) + (expected-failures (ert--stats-failed-expected stats))) + (message "\n%sRan %s tests, %s results as expected%s (%s)%s\n" + (if (not abortedp) + "" + "Aborted: ") + (ert-stats-total stats) + (ert-stats-completed-expected stats) + (if (zerop unexpected) + "" + (format ", %s unexpected" unexpected)) + (ert--format-time-iso8601 (ert--stats-end-time stats)) + (if (zerop expected-failures) + "" + (format "\n%s expected failures" expected-failures))) + (unless (zerop unexpected) + (message "%s unexpected results:" unexpected) + (loop for test across (ert--stats-tests stats) + for result = (ert-test-most-recent-result test) do + (when (not (ert-test-result-expected-p test result)) + (message "%9s %S" + (ert-string-for-test-result result nil) + (ert-test-name test)))) + (message "%s" ""))))) + (test-started + ) + (test-ended + (destructuring-bind (stats test result) event-args + (unless (ert-test-result-expected-p test result) + (etypecase result + (ert-test-passed + (message "Test %S passed unexpectedly" (ert-test-name test))) + (ert-test-result-with-condition + (message "Test %S backtrace:" (ert-test-name test)) + (with-temp-buffer + (ert--print-backtrace (ert-test-result-with-condition-backtrace + result)) + (goto-char (point-min)) + (while (not (eobp)) + (let ((start (point)) + (end (progn (end-of-line) (point)))) + (setq end (min end + (+ start ert-batch-backtrace-right-margin))) + (message "%s" (buffer-substring-no-properties + start end))) + (forward-line 1))) + (with-temp-buffer + (ert--insert-infos result) + (insert " ") + (let ((print-escape-newlines t) + (print-level 5) + (print-length 10)) + (let ((begin (point))) + (ert--pp-with-indentation-and-newline + (ert-test-result-with-condition-condition result)))) + (goto-char (1- (point-max))) + (assert (looking-at "\n")) + (delete-char 1) + (message "Test %S condition:" (ert-test-name test)) + (message "%s" (buffer-string)))) + (ert-test-aborted-with-non-local-exit + (message "Test %S aborted with non-local exit" + (ert-test-name test))))) + (let* ((max (prin1-to-string (length (ert--stats-tests stats)))) + (format-string (concat "%9s %" + (prin1-to-string (length max)) + "s/" max " %S"))) + (message format-string + (ert-string-for-test-result result + (ert-test-result-expected-p + test result)) + (1+ (ert--stats-test-pos stats test)) + (ert-test-name test))))))))) + +;;;###autoload +(defun ert-run-tests-batch-and-exit (&optional selector) + "Like `ert-run-tests-batch', but exits Emacs when done. + +The exit status will be 0 if all test results were as expected, 1 +on unexpected results, or 2 if the tool detected an error outside +of the tests (e.g. invalid SELECTOR or bug in the code that runs +the tests)." + (unwind-protect + (let ((stats (ert-run-tests-batch selector))) + (kill-emacs (if (zerop (ert-stats-completed-unexpected stats)) 0 1))) + (unwind-protect + (progn + (message "Error running tests") + (backtrace)) + (kill-emacs 2)))) + + +;;; Utility functions for load/unload actions. + +(defun ert--activate-font-lock-keywords () + "Activate font-lock keywords for some of ERT's symbols." + (font-lock-add-keywords + nil + '(("(\\(\\<ert-deftest\\)\\>\\s *\\(\\sw+\\)?" + (1 font-lock-keyword-face nil t) + (2 font-lock-function-name-face nil t))))) + +(defun* ert--remove-from-list (list-var element &key key test) + "Remove ELEMENT from the value of LIST-VAR if present. + +This can be used as an inverse of `add-to-list'." + (unless key (setq key #'identity)) + (unless test (setq test #'equal)) + (setf (symbol-value list-var) + (ert--remove* element + (symbol-value list-var) + :key key + :test test))) + + +;;; Some basic interactive functions. + +(defun ert-read-test-name (prompt &optional default history + add-default-to-prompt) + "Read the name of a test and return it as a symbol. + +Prompt with PROMPT. If DEFAULT is a valid test name, use it as a +default. HISTORY is the history to use; see `completing-read'. +If ADD-DEFAULT-TO-PROMPT is non-nil, PROMPT will be modified to +include the default, if any. + +Signals an error if no test name was read." + (etypecase default + (string (let ((symbol (intern-soft default))) + (unless (and symbol (ert-test-boundp symbol)) + (setq default nil)))) + (symbol (setq default + (if (ert-test-boundp default) + (symbol-name default) + nil))) + (ert-test (setq default (ert-test-name default)))) + (when add-default-to-prompt + (setq prompt (if (null default) + (format "%s: " prompt) + (format "%s (default %s): " prompt default)))) + (let ((input (completing-read prompt obarray #'ert-test-boundp + t nil history default nil))) + ;; completing-read returns an empty string if default was nil and + ;; the user just hit enter. + (let ((sym (intern-soft input))) + (if (ert-test-boundp sym) + sym + (error "Input does not name a test"))))) + +(defun ert-read-test-name-at-point (prompt) + "Read the name of a test and return it as a symbol. +As a default, use the symbol at point, or the test at point if in +the ERT results buffer. Prompt with PROMPT, augmented with the +default (if any)." + (ert-read-test-name prompt (ert-test-at-point) nil t)) + +(defun ert-find-test-other-window (test-name) + "Find, in another window, the definition of TEST-NAME." + (interactive (list (ert-read-test-name-at-point "Find test definition: "))) + (find-function-do-it test-name 'ert-deftest 'switch-to-buffer-other-window)) + +(defun ert-delete-test (test-name) + "Make the test TEST-NAME unbound. + +Nothing more than an interactive interface to `ert-make-test-unbound'." + (interactive (list (ert-read-test-name-at-point "Delete test"))) + (ert-make-test-unbound test-name)) + +(defun ert-delete-all-tests () + "Make all symbols in `obarray' name no test." + (interactive) + (when (interactive-p) + (unless (y-or-n-p "Delete all tests? ") + (error "Aborted"))) + ;; We can't use `ert-select-tests' here since that gives us only + ;; test objects, and going from them back to the test name symbols + ;; can fail if the `ert-test' defstruct has been redefined. + (mapc #'ert-make-test-unbound (apropos-internal "" #'ert-test-boundp)) + t) + + +;;; Display of test progress and results. + +;; An entry in the results buffer ewoc. There is one entry per test. +(defstruct ert--ewoc-entry + (test (assert nil)) + ;; If the result of this test was expected, its ewoc entry is hidden + ;; initially. + (hidden-p (assert nil)) + ;; An ewoc entry may be collapsed to hide details such as the error + ;; condition. + ;; + ;; I'm not sure the ability to expand and collapse entries is still + ;; a useful feature. + (expanded-p t) + ;; By default, the ewoc entry presents the error condition with + ;; certain limits on how much to print (`print-level', + ;; `print-length'). The user can interactively switch to a set of + ;; higher limits. + (extended-printer-limits-p nil)) + +;; Variables local to the results buffer. + +;; The ewoc. +(defvar ert--results-ewoc) +;; The stats object. +(defvar ert--results-stats) +;; A string with one character per test. Each character represents +;; the result of the corresponding test. The string is displayed near +;; the top of the buffer and serves as a progress bar. +(defvar ert--results-progress-bar-string) +;; The position where the progress bar button begins. +(defvar ert--results-progress-bar-button-begin) +;; The test result listener that updates the buffer when tests are run. +(defvar ert--results-listener) + +(defun ert-insert-test-name-button (test-name) + "Insert a button that links to TEST-NAME." + (insert-text-button (format "%S" test-name) + :type 'ert--test-name-button + 'ert-test-name test-name)) + +(defun ert--results-format-expected-unexpected (expected unexpected) + "Return a string indicating EXPECTED expected results, UNEXPECTED unexpected." + (if (zerop unexpected) + (format "%s" expected) + (format "%s (%s unexpected)" (+ expected unexpected) unexpected))) + +(defun ert--results-update-ewoc-hf (ewoc stats) + "Update the header and footer of EWOC to show certain information from STATS. + +Also sets `ert--results-progress-bar-button-begin'." + (let ((run-count (ert-stats-completed stats)) + (results-buffer (current-buffer)) + ;; Need to save buffer-local value. + (font-lock font-lock-mode)) + (ewoc-set-hf + ewoc + ;; header + (with-temp-buffer + (insert "Selector: ") + (ert--insert-human-readable-selector (ert--stats-selector stats)) + (insert "\n") + (insert + (format (concat "Passed: %s\n" + "Failed: %s\n" + "Total: %s/%s\n\n") + (ert--results-format-expected-unexpected + (ert--stats-passed-expected stats) + (ert--stats-passed-unexpected stats)) + (ert--results-format-expected-unexpected + (ert--stats-failed-expected stats) + (ert--stats-failed-unexpected stats)) + run-count + (ert-stats-total stats))) + (insert + (format "Started at: %s\n" + (ert--format-time-iso8601 (ert--stats-start-time stats)))) + ;; FIXME: This is ugly. Need to properly define invariants of + ;; the `stats' data structure. + (let ((state (cond ((ert--stats-aborted-p stats) 'aborted) + ((ert--stats-current-test stats) 'running) + ((ert--stats-end-time stats) 'finished) + (t 'preparing)))) + (ecase state + (preparing + (insert "")) + (aborted + (cond ((ert--stats-current-test stats) + (insert "Aborted during test: ") + (ert-insert-test-name-button + (ert-test-name (ert--stats-current-test stats)))) + (t + (insert "Aborted.")))) + (running + (assert (ert--stats-current-test stats)) + (insert "Running test: ") + (ert-insert-test-name-button (ert-test-name + (ert--stats-current-test stats)))) + (finished + (assert (not (ert--stats-current-test stats))) + (insert "Finished."))) + (insert "\n") + (if (ert--stats-end-time stats) + (insert + (format "%s%s\n" + (if (ert--stats-aborted-p stats) + "Aborted at: " + "Finished at: ") + (ert--format-time-iso8601 (ert--stats-end-time stats)))) + (insert "\n")) + (insert "\n")) + (let ((progress-bar-string (with-current-buffer results-buffer + ert--results-progress-bar-string))) + (let ((progress-bar-button-begin + (insert-text-button progress-bar-string + :type 'ert--results-progress-bar-button + 'face (or (and font-lock + (ert-face-for-stats stats)) + 'button)))) + ;; The header gets copied verbatim to the results buffer, + ;; and all positions remain the same, so + ;; `progress-bar-button-begin' will be the right position + ;; even in the results buffer. + (with-current-buffer results-buffer + (set (make-local-variable 'ert--results-progress-bar-button-begin) + progress-bar-button-begin)))) + (insert "\n\n") + (buffer-string)) + ;; footer + ;; + ;; We actually want an empty footer, but that would trigger a bug + ;; in ewoc, sometimes clearing the entire buffer. (It's possible + ;; that this bug has been fixed since this has been tested; we + ;; should test it again.) + "\n"))) + + +(defvar ert-test-run-redisplay-interval-secs .1 + "How many seconds ERT should wait between redisplays while running tests. + +While running tests, ERT shows the current progress, and this variable +determines how frequently the progress display is updated.") + +(defun ert--results-update-stats-display (ewoc stats) + "Update EWOC and the mode line to show data from STATS." + ;; TODO(ohler): investigate using `make-progress-reporter'. + (ert--results-update-ewoc-hf ewoc stats) + (force-mode-line-update) + (redisplay t) + (setf (ert--stats-next-redisplay stats) + (+ (float-time) ert-test-run-redisplay-interval-secs))) + +(defun ert--results-update-stats-display-maybe (ewoc stats) + "Call `ert--results-update-stats-display' if not called recently. + +EWOC and STATS are arguments for `ert--results-update-stats-display'." + (when (>= (float-time) (ert--stats-next-redisplay stats)) + (ert--results-update-stats-display ewoc stats))) + +(defun ert--tests-running-mode-line-indicator () + "Return a string for the mode line that shows the test run progress." + (let* ((stats ert--current-run-stats) + (tests-total (ert-stats-total stats)) + (tests-completed (ert-stats-completed stats))) + (if (>= tests-completed tests-total) + (format " ERT(%s/%s,finished)" tests-completed tests-total) + (format " ERT(%s/%s):%s" + (1+ tests-completed) + tests-total + (if (null (ert--stats-current-test stats)) + "?" + (format "%S" + (ert-test-name (ert--stats-current-test stats)))))))) + +(defun ert--make-xrefs-region (begin end) + "Attach cross-references to function names between BEGIN and END. + +BEGIN and END specify a region in the current buffer." + (save-excursion + (save-restriction + (narrow-to-region begin (point)) + ;; Inhibit optimization in `debugger-make-xrefs' that would + ;; sometimes insert unrelated backtrace info into our buffer. + (let ((debugger-previous-backtrace nil)) + (debugger-make-xrefs))))) + +(defun ert--string-first-line (s) + "Return the first line of S, or S if it contains no newlines. + +The return value does not include the line terminator." + (substring s 0 (ert--string-position ?\n s))) + +(defun ert-face-for-test-result (expectedp) + "Return a face that shows whether a test result was expected or unexpected. + +If EXPECTEDP is nil, returns the face for unexpected results; if +non-nil, returns the face for expected results.." + (if expectedp 'ert-test-result-expected 'ert-test-result-unexpected)) + +(defun ert-face-for-stats (stats) + "Return a face that represents STATS." + (cond ((ert--stats-aborted-p stats) 'nil) + ((plusp (ert-stats-completed-unexpected stats)) + (ert-face-for-test-result nil)) + ((eql (ert-stats-completed-expected stats) (ert-stats-total stats)) + (ert-face-for-test-result t)) + (t 'nil))) + +(defun ert--print-test-for-ewoc (entry) + "The ewoc print function for ewoc test entries. ENTRY is the entry to print." + (let* ((test (ert--ewoc-entry-test entry)) + (stats ert--results-stats) + (result (let ((pos (ert--stats-test-pos stats test))) + (assert pos) + (aref (ert--stats-test-results stats) pos))) + (hiddenp (ert--ewoc-entry-hidden-p entry)) + (expandedp (ert--ewoc-entry-expanded-p entry)) + (extended-printer-limits-p (ert--ewoc-entry-extended-printer-limits-p + entry))) + (cond (hiddenp) + (t + (let ((expectedp (ert-test-result-expected-p test result))) + (insert-text-button (format "%c" (ert-char-for-test-result + result expectedp)) + :type 'ert--results-expand-collapse-button + 'face (or (and font-lock-mode + (ert-face-for-test-result + expectedp)) + 'button))) + (insert " ") + (ert-insert-test-name-button (ert-test-name test)) + (insert "\n") + (when (and expandedp (not (eql result 'nil))) + (when (ert-test-documentation test) + (insert " " + (propertize + (ert--string-first-line (ert-test-documentation test)) + 'font-lock-face 'font-lock-doc-face) + "\n")) + (etypecase result + (ert-test-passed + (if (ert-test-result-expected-p test result) + (insert " passed\n") + (insert " passed unexpectedly\n")) + (insert "")) + (ert-test-result-with-condition + (ert--insert-infos result) + (let ((print-escape-newlines t) + (print-level (if extended-printer-limits-p 12 6)) + (print-length (if extended-printer-limits-p 100 10))) + (insert " ") + (let ((begin (point))) + (ert--pp-with-indentation-and-newline + (ert-test-result-with-condition-condition result)) + (ert--make-xrefs-region begin (point))))) + (ert-test-aborted-with-non-local-exit + (insert " aborted\n"))) + (insert "\n"))))) + nil) + +(defun ert--results-font-lock-function (enabledp) + "Redraw the ERT results buffer after font-lock-mode was switched on or off. + +ENABLEDP is true if font-lock-mode is switched on, false +otherwise." + (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) + (ewoc-refresh ert--results-ewoc) + (font-lock-default-function enabledp)) + +(defun ert--setup-results-buffer (stats listener buffer-name) + "Set up a test results buffer. + +STATS is the stats object; LISTENER is the results listener; +BUFFER-NAME, if non-nil, is the buffer name to use." + (unless buffer-name (setq buffer-name "*ert*")) + (let ((buffer (get-buffer-create buffer-name))) + (with-current-buffer buffer + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-results-mode) + ;; Erase buffer again in case switching out of the previous + ;; mode inserted anything. (This happens e.g. when switching + ;; from ert-results-mode to ert-results-mode when + ;; font-lock-mode turns itself off in change-major-mode-hook.) + (erase-buffer) + (set (make-local-variable 'font-lock-function) + 'ert--results-font-lock-function) + (let ((ewoc (ewoc-create 'ert--print-test-for-ewoc nil nil t))) + (set (make-local-variable 'ert--results-ewoc) ewoc) + (set (make-local-variable 'ert--results-stats) stats) + (set (make-local-variable 'ert--results-progress-bar-string) + (make-string (ert-stats-total stats) + (ert-char-for-test-result nil t))) + (set (make-local-variable 'ert--results-listener) listener) + (loop for test across (ert--stats-tests stats) do + (ewoc-enter-last ewoc + (make-ert--ewoc-entry :test test :hidden-p t))) + (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) + (goto-char (1- (point-max))) + buffer))))) + + +(defvar ert--selector-history nil + "List of recent test selectors read from terminal.") + +;; Should OUTPUT-BUFFER-NAME and MESSAGE-FN really be arguments here? +;; They are needed only for our automated self-tests at the moment. +;; Or should there be some other mechanism? +;;;###autoload +(defun ert-run-tests-interactively (selector + &optional output-buffer-name message-fn) + "Run the tests specified by SELECTOR and display the results in a buffer. + +SELECTOR works as described in `ert-select-tests'. +OUTPUT-BUFFER-NAME and MESSAGE-FN should normally be nil; they +are used for automated self-tests and specify which buffer to use +and how to display message." + (interactive + (list (let ((default (if ert--selector-history + ;; Can't use `first' here as this form is + ;; not compiled, and `first' is not + ;; defined without cl. + (car ert--selector-history) + "t"))) + (read-from-minibuffer (if (null default) + "Run tests: " + (format "Run tests (default %s): " default)) + nil nil t 'ert--selector-history + default nil)) + nil)) + (unless message-fn (setq message-fn 'message)) + (lexical-let ((output-buffer-name output-buffer-name) + buffer + listener + (message-fn message-fn)) + (setq listener + (lambda (event-type &rest event-args) + (ecase event-type + (run-started + (destructuring-bind (stats) event-args + (setq buffer (ert--setup-results-buffer stats + listener + output-buffer-name)) + (pop-to-buffer buffer))) + (run-ended + (destructuring-bind (stats abortedp) event-args + (funcall message-fn + "%sRan %s tests, %s results were as expected%s" + (if (not abortedp) + "" + "Aborted: ") + (ert-stats-total stats) + (ert-stats-completed-expected stats) + (let ((unexpected + (ert-stats-completed-unexpected stats))) + (if (zerop unexpected) + "" + (format ", %s unexpected" unexpected)))) + (ert--results-update-stats-display (with-current-buffer buffer + ert--results-ewoc) + stats))) + (test-started + (destructuring-bind (stats test) event-args + (with-current-buffer buffer + (let* ((ewoc ert--results-ewoc) + (pos (ert--stats-test-pos stats test)) + (node (ewoc-nth ewoc pos))) + (assert node) + (setf (ert--ewoc-entry-test (ewoc-data node)) test) + (aset ert--results-progress-bar-string pos + (ert-char-for-test-result nil t)) + (ert--results-update-stats-display-maybe ewoc stats) + (ewoc-invalidate ewoc node))))) + (test-ended + (destructuring-bind (stats test result) event-args + (with-current-buffer buffer + (let* ((ewoc ert--results-ewoc) + (pos (ert--stats-test-pos stats test)) + (node (ewoc-nth ewoc pos))) + (when (ert--ewoc-entry-hidden-p (ewoc-data node)) + (setf (ert--ewoc-entry-hidden-p (ewoc-data node)) + (ert-test-result-expected-p test result))) + (aset ert--results-progress-bar-string pos + (ert-char-for-test-result result + (ert-test-result-expected-p + test result))) + (ert--results-update-stats-display-maybe ewoc stats) + (ewoc-invalidate ewoc node)))))))) + (ert-run-tests + selector + listener))) +;;;###autoload +(defalias 'ert 'ert-run-tests-interactively) + + +;;; Simple view mode for auxiliary information like stack traces or +;;; messages. Mainly binds "q" for quit. + +(define-derived-mode ert-simple-view-mode fundamental-mode "ERT-View" + "Major mode for viewing auxiliary information in ERT.") + +(loop for (key binding) in + '(("q" quit-window) + ) + do + (define-key ert-simple-view-mode-map key binding)) + + +;;; Commands and button actions for the results buffer. + +(define-derived-mode ert-results-mode fundamental-mode "ERT-Results" + "Major mode for viewing results of ERT test runs.") + +(loop for (key binding) in + '(;; Stuff that's not in the menu. + ("\t" forward-button) + ([backtab] backward-button) + ("j" ert-results-jump-between-summary-and-result) + ("q" quit-window) + ("L" ert-results-toggle-printer-limits-for-test-at-point) + ("n" ert-results-next-test) + ("p" ert-results-previous-test) + ;; Stuff that is in the menu. + ("R" ert-results-rerun-all-tests) + ("r" ert-results-rerun-test-at-point) + ("d" ert-results-rerun-test-at-point-debugging-errors) + ("." ert-results-find-test-at-point-other-window) + ("b" ert-results-pop-to-backtrace-for-test-at-point) + ("m" ert-results-pop-to-messages-for-test-at-point) + ("l" ert-results-pop-to-should-forms-for-test-at-point) + ("h" ert-results-describe-test-at-point) + ("D" ert-delete-test) + ("T" ert-results-pop-to-timings) + ) + do + (define-key ert-results-mode-map key binding)) + +(easy-menu-define ert-results-mode-menu ert-results-mode-map + "Menu for `ert-results-mode'." + '("ERT Results" + ["Re-run all tests" ert-results-rerun-all-tests] + "--" + ["Re-run test" ert-results-rerun-test-at-point] + ["Debug test" ert-results-rerun-test-at-point-debugging-errors] + ["Show test definition" ert-results-find-test-at-point-other-window] + "--" + ["Show backtrace" ert-results-pop-to-backtrace-for-test-at-point] + ["Show messages" ert-results-pop-to-messages-for-test-at-point] + ["Show `should' forms" ert-results-pop-to-should-forms-for-test-at-point] + ["Describe test" ert-results-describe-test-at-point] + "--" + ["Delete test" ert-delete-test] + "--" + ["Show execution time of each test" ert-results-pop-to-timings] + )) + +(define-button-type 'ert--results-progress-bar-button + 'action #'ert--results-progress-bar-button-action + 'help-echo "mouse-2, RET: Reveal test result") + +(define-button-type 'ert--test-name-button + 'action #'ert--test-name-button-action + 'help-echo "mouse-2, RET: Find test definition") + +(define-button-type 'ert--results-expand-collapse-button + 'action #'ert--results-expand-collapse-button-action + 'help-echo "mouse-2, RET: Expand/collapse test result") + +(defun ert--results-test-node-or-null-at-point () + "If point is on a valid ewoc node, return it; return nil otherwise. + +To be used in the ERT results buffer." + (let* ((ewoc ert--results-ewoc) + (node (ewoc-locate ewoc))) + ;; `ewoc-locate' will return an arbitrary node when point is on + ;; header or footer, or when all nodes are invisible. So we need + ;; to validate its return value here. + ;; + ;; Update: I'm seeing nil being returned in some cases now, + ;; perhaps this has been changed? + (if (and node + (>= (point) (ewoc-location node)) + (not (ert--ewoc-entry-hidden-p (ewoc-data node)))) + node + nil))) + +(defun ert--results-test-node-at-point () + "If point is on a valid ewoc node, return it; signal an error otherwise. + +To be used in the ERT results buffer." + (or (ert--results-test-node-or-null-at-point) + (error "No test at point"))) + +(defun ert-results-next-test () + "Move point to the next test. + +To be used in the ERT results buffer." + (interactive) + (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-next + "No tests below")) + +(defun ert-results-previous-test () + "Move point to the previous test. + +To be used in the ERT results buffer." + (interactive) + (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-prev + "No tests above")) + +(defun ert--results-move (node ewoc-fn error-message) + "Move point from NODE to the previous or next node. + +EWOC-FN specifies the direction and should be either `ewoc-prev' +or `ewoc-next'. If there are no more nodes in that direction, an +error is signalled with the message ERROR-MESSAGE." + (loop + (setq node (funcall ewoc-fn ert--results-ewoc node)) + (when (null node) + (error "%s" error-message)) + (unless (ert--ewoc-entry-hidden-p (ewoc-data node)) + (goto-char (ewoc-location node)) + (return)))) + +(defun ert--results-expand-collapse-button-action (button) + "Expand or collapse the test node BUTTON belongs to." + (let* ((ewoc ert--results-ewoc) + (node (save-excursion + (goto-char (ert--button-action-position)) + (ert--results-test-node-at-point))) + (entry (ewoc-data node))) + (setf (ert--ewoc-entry-expanded-p entry) + (not (ert--ewoc-entry-expanded-p entry))) + (ewoc-invalidate ewoc node))) + +(defun ert-results-find-test-at-point-other-window () + "Find the definition of the test at point in another window. + +To be used in the ERT results buffer." + (interactive) + (let ((name (ert-test-at-point))) + (unless name + (error "No test at point")) + (ert-find-test-other-window name))) + +(defun ert--test-name-button-action (button) + "Find the definition of the test BUTTON belongs to, in another window." + (let ((name (button-get button 'ert-test-name))) + (ert-find-test-other-window name))) + +(defun ert--ewoc-position (ewoc node) + ;; checkdoc-order: nil + "Return the position of NODE in EWOC, or nil if NODE is not in EWOC." + (loop for i from 0 + for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here) + do (when (eql node node-here) + (return i)) + finally (return nil))) + +(defun ert-results-jump-between-summary-and-result () + "Jump back and forth between the test run summary and individual test results. + +From an ewoc node, jumps to the character that represents the +same test in the progress bar, and vice versa. + +To be used in the ERT results buffer." + ;; Maybe this command isn't actually needed much, but if it is, it + ;; seems like an indication that the UI design is not optimal. If + ;; jumping back and forth between a summary at the top of the buffer + ;; and the error log in the remainder of the buffer is useful, then + ;; the summary apparently needs to be easily accessible from the + ;; error log, and perhaps it would be better to have it in a + ;; separate buffer to keep it visible. + (interactive) + (let ((ewoc ert--results-ewoc) + (progress-bar-begin ert--results-progress-bar-button-begin)) + (cond ((ert--results-test-node-or-null-at-point) + (let* ((node (ert--results-test-node-at-point)) + (pos (ert--ewoc-position ewoc node))) + (goto-char (+ progress-bar-begin pos)))) + ((and (<= progress-bar-begin (point)) + (< (point) (button-end (button-at progress-bar-begin)))) + (let* ((node (ewoc-nth ewoc (- (point) progress-bar-begin))) + (entry (ewoc-data node))) + (when (ert--ewoc-entry-hidden-p entry) + (setf (ert--ewoc-entry-hidden-p entry) nil) + (ewoc-invalidate ewoc node)) + (ewoc-goto-node ewoc node))) + (t + (goto-char progress-bar-begin))))) + +(defun ert-test-at-point () + "Return the name of the test at point as a symbol, or nil if none." + (or (and (eql major-mode 'ert-results-mode) + (let ((test (ert--results-test-at-point-no-redefinition))) + (and test (ert-test-name test)))) + (let* ((thing (thing-at-point 'symbol)) + (sym (intern-soft thing))) + (and (ert-test-boundp sym) + sym)))) + +(defun ert--results-test-at-point-no-redefinition () + "Return the test at point, or nil. + +To be used in the ERT results buffer." + (assert (eql major-mode 'ert-results-mode)) + (if (ert--results-test-node-or-null-at-point) + (let* ((node (ert--results-test-node-at-point)) + (test (ert--ewoc-entry-test (ewoc-data node)))) + test) + (let ((progress-bar-begin ert--results-progress-bar-button-begin)) + (when (and (<= progress-bar-begin (point)) + (< (point) (button-end (button-at progress-bar-begin)))) + (let* ((test-index (- (point) progress-bar-begin)) + (test (aref (ert--stats-tests ert--results-stats) + test-index))) + test))))) + +(defun ert--results-test-at-point-allow-redefinition () + "Look up the test at point, and check whether it has been redefined. + +To be used in the ERT results buffer. + +Returns a list of two elements: the test (or nil) and a symbol +specifying whether the test has been redefined. + +If a new test has been defined with the same name as the test at +point, replaces the test at point with the new test, and returns +the new test and the symbol `redefined'. + +If the test has been deleted, returns the old test and the symbol +`deleted'. + +If the test is still current, returns the test and the symbol nil. + +If there is no test at point, returns a list with two nils." + (let ((test (ert--results-test-at-point-no-redefinition))) + (cond ((null test) + `(nil nil)) + ((null (ert-test-name test)) + `(,test nil)) + (t + (let* ((name (ert-test-name test)) + (new-test (and (ert-test-boundp name) + (ert-get-test name)))) + (cond ((eql test new-test) + `(,test nil)) + ((null new-test) + `(,test deleted)) + (t + (ert--results-update-after-test-redefinition + (ert--stats-test-pos ert--results-stats test) + new-test) + `(,new-test redefined)))))))) + +(defun ert--results-update-after-test-redefinition (pos new-test) + "Update results buffer after the test at pos POS has been redefined. + +Also updates the stats object. NEW-TEST is the new test +definition." + (let* ((stats ert--results-stats) + (ewoc ert--results-ewoc) + (node (ewoc-nth ewoc pos)) + (entry (ewoc-data node))) + (ert--stats-set-test-and-result stats pos new-test nil) + (setf (ert--ewoc-entry-test entry) new-test + (aref ert--results-progress-bar-string pos) (ert-char-for-test-result + nil t)) + (ewoc-invalidate ewoc node)) + nil) + +(defun ert--button-action-position () + "The buffer position where the last button action was triggered." + (cond ((integerp last-command-event) + (point)) + ((eventp last-command-event) + (posn-point (event-start last-command-event))) + (t (assert nil)))) + +(defun ert--results-progress-bar-button-action (button) + "Jump to details for the test represented by the character clicked in BUTTON." + (goto-char (ert--button-action-position)) + (ert-results-jump-between-summary-and-result)) + +(defun ert-results-rerun-all-tests () + "Re-run all tests, using the same selector. + +To be used in the ERT results buffer." + (interactive) + (assert (eql major-mode 'ert-results-mode)) + (let ((selector (ert--stats-selector ert--results-stats))) + (ert-run-tests-interactively selector (buffer-name)))) + +(defun ert-results-rerun-test-at-point () + "Re-run the test at point. + +To be used in the ERT results buffer." + (interactive) + (destructuring-bind (test redefinition-state) + (ert--results-test-at-point-allow-redefinition) + (when (null test) + (error "No test at point")) + (let* ((stats ert--results-stats) + (progress-message (format "Running %stest %S" + (ecase redefinition-state + ((nil) "") + (redefined "new definition of ") + (deleted "deleted ")) + (ert-test-name test)))) + ;; Need to save and restore point manually here: When point is on + ;; the first visible ewoc entry while the header is updated, point + ;; moves to the top of the buffer. This is undesirable, and a + ;; simple `save-excursion' doesn't prevent it. + (let ((point (point))) + (unwind-protect + (unwind-protect + (progn + (message "%s..." progress-message) + (ert-run-or-rerun-test stats test + ert--results-listener)) + (ert--results-update-stats-display ert--results-ewoc stats) + (message "%s...%s" + progress-message + (let ((result (ert-test-most-recent-result test))) + (ert-string-for-test-result + result (ert-test-result-expected-p test result))))) + (goto-char point)))))) + +(defun ert-results-rerun-test-at-point-debugging-errors () + "Re-run the test at point with `ert-debug-on-error' bound to t. + +To be used in the ERT results buffer." + (interactive) + (let ((ert-debug-on-error t)) + (ert-results-rerun-test-at-point))) + +(defun ert-results-pop-to-backtrace-for-test-at-point () + "Display the backtrace for the test at point. + +To be used in the ERT results buffer." + (interactive) + (let* ((test (ert--results-test-at-point-no-redefinition)) + (stats ert--results-stats) + (pos (ert--stats-test-pos stats test)) + (result (aref (ert--stats-test-results stats) pos))) + (etypecase result + (ert-test-passed (error "Test passed, no backtrace available")) + (ert-test-result-with-condition + (let ((backtrace (ert-test-result-with-condition-backtrace result)) + (buffer (get-buffer-create "*ERT Backtrace*"))) + (pop-to-buffer buffer) + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + ;; Use unibyte because `debugger-setup-buffer' also does so. + (set-buffer-multibyte nil) + (setq truncate-lines t) + (ert--print-backtrace backtrace) + (debugger-make-xrefs) + (goto-char (point-min)) + (insert "Backtrace for test `") + (ert-insert-test-name-button (ert-test-name test)) + (insert "':\n"))))))) + +(defun ert-results-pop-to-messages-for-test-at-point () + "Display the part of the *Messages* buffer generated during the test at point. + +To be used in the ERT results buffer." + (interactive) + (let* ((test (ert--results-test-at-point-no-redefinition)) + (stats ert--results-stats) + (pos (ert--stats-test-pos stats test)) + (result (aref (ert--stats-test-results stats) pos))) + (let ((buffer (get-buffer-create "*ERT Messages*"))) + (pop-to-buffer buffer) + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + (insert (ert-test-result-messages result)) + (goto-char (point-min)) + (insert "Messages for test `") + (ert-insert-test-name-button (ert-test-name test)) + (insert "':\n"))))) + +(defun ert-results-pop-to-should-forms-for-test-at-point () + "Display the list of `should' forms executed during the test at point. + +To be used in the ERT results buffer." + (interactive) + (let* ((test (ert--results-test-at-point-no-redefinition)) + (stats ert--results-stats) + (pos (ert--stats-test-pos stats test)) + (result (aref (ert--stats-test-results stats) pos))) + (let ((buffer (get-buffer-create "*ERT list of should forms*"))) + (pop-to-buffer buffer) + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + (if (null (ert-test-result-should-forms result)) + (insert "\n(No should forms during this test.)\n") + (loop for form-description in (ert-test-result-should-forms result) + for i from 1 do + (insert "\n") + (insert (format "%s: " i)) + (let ((begin (point))) + (ert--pp-with-indentation-and-newline form-description) + (ert--make-xrefs-region begin (point))))) + (goto-char (point-min)) + (insert "`should' forms executed during test `") + (ert-insert-test-name-button (ert-test-name test)) + (insert "':\n") + (insert "\n") + (insert (concat "(Values are shallow copies and may have " + "looked different during the test if they\n" + "have been modified destructively.)\n")) + (forward-line 1))))) + +(defun ert-results-toggle-printer-limits-for-test-at-point () + "Toggle how much of the condition to print for the test at point. + +To be used in the ERT results buffer." + (interactive) + (let* ((ewoc ert--results-ewoc) + (node (ert--results-test-node-at-point)) + (entry (ewoc-data node))) + (setf (ert--ewoc-entry-extended-printer-limits-p entry) + (not (ert--ewoc-entry-extended-printer-limits-p entry))) + (ewoc-invalidate ewoc node))) + +(defun ert-results-pop-to-timings () + "Display test timings for the last run. + +To be used in the ERT results buffer." + (interactive) + (let* ((stats ert--results-stats) + (start-times (ert--stats-test-start-times stats)) + (end-times (ert--stats-test-end-times stats)) + (buffer (get-buffer-create "*ERT timings*")) + (data (loop for test across (ert--stats-tests stats) + for start-time across (ert--stats-test-start-times stats) + for end-time across (ert--stats-test-end-times stats) + collect (list test + (float-time (subtract-time end-time + start-time)))))) + (setq data (sort data (lambda (a b) + (> (second a) (second b))))) + (pop-to-buffer buffer) + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + (if (null data) + (insert "(No data)\n") + (insert (format "%-3s %8s %8s\n" "" "time" "cumul")) + (loop for (test time) in data + for cumul-time = time then (+ cumul-time time) + for i from 1 do + (let ((begin (point))) + (insert (format "%3s: %8.3f %8.3f " i time cumul-time)) + (ert-insert-test-name-button (ert-test-name test)) + (insert "\n")))) + (goto-char (point-min)) + (insert "Tests by run time (seconds):\n\n") + (forward-line 1)))) + +;;;###autoload +(defun ert-describe-test (test-or-test-name) + "Display the documentation for TEST-OR-TEST-NAME (a symbol or ert-test)." + (interactive (list (ert-read-test-name-at-point "Describe test"))) + (when (< emacs-major-version 24) + (error "Requires Emacs 24")) + (let (test-name + test-definition) + (etypecase test-or-test-name + (symbol (setq test-name test-or-test-name + test-definition (ert-get-test test-or-test-name))) + (ert-test (setq test-name (ert-test-name test-or-test-name) + test-definition test-or-test-name))) + (help-setup-xref (list #'ert-describe-test test-or-test-name) + (called-interactively-p 'interactive)) + (save-excursion + (with-help-window (help-buffer) + (with-current-buffer (help-buffer) + (insert (if test-name (format "%S" test-name) "<anonymous test>")) + (insert " is a test") + (let ((file-name (and test-name + (symbol-file test-name 'ert-deftest)))) + (when file-name + (insert " defined in `" (file-name-nondirectory file-name) "'") + (save-excursion + (re-search-backward "`\\([^`']+\\)'" nil t) + (help-xref-button 1 'help-function-def test-name file-name))) + (insert ".") + (fill-region-as-paragraph (point-min) (point)) + (insert "\n\n") + (unless (and (ert-test-boundp test-name) + (eql (ert-get-test test-name) test-definition)) + (let ((begin (point))) + (insert "Note: This test has been redefined or deleted, " + "this documentation refers to an old definition.") + (fill-region-as-paragraph begin (point))) + (insert "\n\n")) + (insert (or (ert-test-documentation test-definition) + "It is not documented.") + "\n"))))))) + +(defun ert-results-describe-test-at-point () + "Display the documentation of the test at point. + +To be used in the ERT results buffer." + (interactive) + (ert-describe-test (ert--results-test-at-point-no-redefinition))) + + +;;; Actions on load/unload. + +(add-to-list 'find-function-regexp-alist '(ert-deftest . ert--find-test-regexp)) +(add-to-list 'minor-mode-alist '(ert--current-run-stats + (:eval + (ert--tests-running-mode-line-indicator)))) +(add-to-list 'emacs-lisp-mode-hook 'ert--activate-font-lock-keywords) + +(defun ert--unload-function () + "Unload function to undo the side-effects of loading ert.el." + (ert--remove-from-list 'find-function-regexp-alist 'ert-deftest :key #'car) + (ert--remove-from-list 'minor-mode-alist 'ert--current-run-stats :key #'car) + (ert--remove-from-list 'emacs-lisp-mode-hook + 'ert--activate-font-lock-keywords) + nil) + +(defvar ert-unload-hook '()) +(add-hook 'ert-unload-hook 'ert--unload-function) + + +(provide 'ert) + +;;; ert.el ends here
--- a/lisp/emacs-lisp/package.el Tue Jan 11 22:13:06 2011 -0800 +++ b/lisp/emacs-lisp/package.el Thu Jan 13 09:17:33 2011 -0800 @@ -1663,15 +1663,15 @@ Optional PACKAGES is a list of names of packages (symbols) to list; the default is to display everything in `package-alist'." (require 'finder-inf nil t) - (with-current-buffer (get-buffer-create "*Packages*") - (package-menu-mode) - (set (make-local-variable 'package-menu-package-list) packages) - (set (make-local-variable 'package-menu-sort-key) nil) - (package--generate-package-list) - ;; It's okay to use pop-to-buffer here. The package menu buffer - ;; has keybindings, and the user just typed `M-x list-packages', - ;; suggesting that they might want to use them. - (pop-to-buffer (current-buffer)))) + (let ((buf (get-buffer-create "*Packages*"))) + (with-current-buffer buf + (package-menu-mode) + (set (make-local-variable 'package-menu-package-list) packages) + (set (make-local-variable 'package-menu-sort-key) nil) + (package--generate-package-list)) + ;; The package menu buffer has keybindings. If the user types + ;; `M-x list-packages', that suggests it should become current. + (switch-to-buffer buf))) ;;;###autoload (defun list-packages ()
--- a/lisp/font-lock.el Tue Jan 11 22:13:06 2011 -0800 +++ b/lisp/font-lock.el Thu Jan 13 09:17:33 2011 -0800 @@ -276,13 +276,14 @@ (integer :tag "level" 1))))) :group 'font-lock) -(defcustom font-lock-verbose 0 +(defcustom font-lock-verbose nil "If non-nil, means show status messages for buffer fontification. If a number, only buffers greater than this size have fontification messages." :type '(choice (const :tag "never" nil) (other :tag "always" t) (integer :tag "size")) - :group 'font-lock) + :group 'font-lock + :version "24.1") ;; Originally these variable values were face names such as `bold' etc.
--- a/lisp/gnus/ChangeLog Tue Jan 11 22:13:06 2011 -0800 +++ b/lisp/gnus/ChangeLog Thu Jan 13 09:17:33 2011 -0800 @@ -1,3 +1,16 @@ +2011-01-13 Chong Yidong <cyd@stupidchicken.com> + + * message.el (message-tool-bar-gnome): Tweak tool-bar items. Add + :vert-only tags. + (message-mail): New arg RETURN-ACTION. + (message-return-action): New var. + (message-bury): Use it. + (message-mode): Make it buffer-local. + (message-send-and-exit): Always call message-bury. + + * gnus-msg.el (gnus-msg-mail): New arg RETURN-ACTION. Pass it to + message-mail. + 2011-01-11 Lars Magne Ingebrigtsen <larsi@gnus.org> * nnimap.el (nnimap-convert-partial-article): Protect against
--- a/lisp/gnus/gnus-msg.el Tue Jan 11 22:13:06 2011 -0800 +++ b/lisp/gnus/gnus-msg.el Thu Jan 13 09:17:33 2011 -0800 @@ -477,7 +477,7 @@ ;;;###autoload (defun gnus-msg-mail (&optional to subject other-headers continue - switch-action yank-action send-actions) + switch-action yank-action send-actions return-action) "Start editing a mail message to be sent. Like `message-mail', but with Gnus paraphernalia, particularly the Gcc: header for archiving purposes." @@ -486,7 +486,7 @@ mail-buf) (gnus-setup-message 'message (message-mail to subject other-headers continue - nil yank-action send-actions)) + nil yank-action send-actions return-action)) (when switch-action (setq mail-buf (current-buffer)) (switch-to-buffer buf)
--- a/lisp/gnus/message.el Tue Jan 11 22:13:06 2011 -0800 +++ b/lisp/gnus/message.el Thu Jan 13 09:17:33 2011 -0800 @@ -1120,6 +1120,8 @@ (defvar message-checksum nil) (defvar message-send-actions nil "A list of actions to be performed upon successful sending of a message.") +(defvar message-return-action nil + "Action to return to the caller after sending or postphoning a message.") (defvar message-exit-actions nil "A list of actions to be performed upon exiting after sending a message.") (defvar message-kill-actions nil @@ -2863,6 +2865,7 @@ (set (make-local-variable 'message-reply-buffer) nil) (set (make-local-variable 'message-inserted-headers) nil) (set (make-local-variable 'message-send-actions) nil) + (set (make-local-variable 'message-return-action) nil) (set (make-local-variable 'message-exit-actions) nil) (set (make-local-variable 'message-kill-actions) nil) (set (make-local-variable 'message-postpone-actions) nil) @@ -3955,11 +3958,9 @@ (actions message-exit-actions)) (when (and (message-send arg) (buffer-name buf)) + (message-bury buf) (if message-kill-buffer-on-exit - (kill-buffer buf) - (bury-buffer buf) - (when (eq buf (current-buffer)) - (message-bury buf))) + (kill-buffer buf)) (message-do-actions actions) t))) @@ -4009,9 +4010,8 @@ "Bury this mail BUFFER." (let ((newbuf (other-buffer buffer))) (bury-buffer buffer) - (if (and (window-dedicated-p (selected-window)) - (not (null (delq (selected-frame) (visible-frame-list))))) - (delete-frame (selected-frame)) + (if message-return-action + (apply (car message-return-action) (cdr message-return-action)) (switch-to-buffer newbuf)))) (defun message-send (&optional arg) @@ -6304,11 +6304,11 @@ ;; YANK-ACTION, if non-nil, can be a buffer or a yank action of the ;; form (FUNCTION . ARGS). (defun message-setup (headers &optional yank-action actions - continue switch-function) + continue switch-function return-action) (let ((mua (message-mail-user-agent)) subject to field) (if (not (and message-this-is-mail mua)) - (message-setup-1 headers yank-action actions) + (message-setup-1 headers yank-action actions return-action) (setq headers (copy-sequence headers)) (setq field (assq 'Subject headers)) (when field @@ -6356,11 +6356,12 @@ (push header result))) (nreverse result))) -(defun message-setup-1 (headers &optional yank-action actions) +(defun message-setup-1 (headers &optional yank-action actions return-action) (dolist (action actions) (condition-case nil (add-to-list 'message-send-actions `(apply ',(car action) ',(cdr action))))) + (setq message-return-action return-action) (setq message-reply-buffer (if (and (consp yank-action) (eq (car yank-action) 'insert-buffer)) @@ -6489,9 +6490,9 @@ ;;; ;;;###autoload -(defun message-mail (&optional to subject - other-headers continue switch-function - yank-action send-actions) +(defun message-mail (&optional to subject other-headers continue + switch-function yank-action send-actions + return-action &rest ignored) "Start editing a mail message to be sent. OTHER-HEADERS is an alist of header/value pairs. CONTINUE says whether to continue editing a message already being composed. SWITCH-FUNCTION @@ -6512,7 +6513,8 @@ (nconc `((To . ,(or to "")) (Subject . ,(or subject ""))) (when other-headers other-headers)) - yank-action send-actions continue switch-function) + yank-action send-actions continue switch-function + return-action) ;; FIXME: Should return nil if failure. t)) @@ -7642,24 +7644,22 @@ (defcustom message-tool-bar-gnome '((ispell-message "spell" nil + :vert-only t :visible (or (not (boundp 'flyspell-mode)) (not flyspell-mode))) (flyspell-buffer "spell" t + :vert-only t :visible (and (boundp 'flyspell-mode) flyspell-mode) :help "Flyspell whole buffer") - (gmm-ignore "separator") - (message-send-and-exit "mail/send") + (message-send-and-exit "mail/send" t :label "Send") (message-dont-send "mail/save-draft") - (message-kill-buffer "close") ;; stock_cancel - (mml-attach-file "attach" mml-mode-map) + (mml-attach-file "attach" mml-mode-map :vert-only t) (mml-preview "mail/preview" mml-mode-map) (mml-secure-message-sign-encrypt "lock" mml-mode-map :visible nil) (message-insert-importance-high "important" nil :visible nil) (message-insert-importance-low "unimportant" nil :visible nil) - (message-insert-disposition-notification-to "receipt" nil :visible nil) - (gmm-customize-mode "preferences" t :help "Edit mode preferences") - (message-info "help" t :help "Message manual")) + (message-insert-disposition-notification-to "receipt" nil :visible nil)) "List of items for the message tool bar (GNOME style). See `gmm-tool-bar-from-list' for details on the format of the list."
--- a/lisp/ido.el Tue Jan 11 22:13:06 2011 -0800 +++ b/lisp/ido.el Thu Jan 13 09:17:33 2011 -0800 @@ -1289,8 +1289,6 @@ (defun ido-may-cache-directory (&optional dir) (setq dir (or dir ido-current-directory)) (cond - ((ido-directory-too-big-p dir) - nil) ((and (ido-is-root-directory dir) (or ido-enable-tramp-completion (memq system-type '(windows-nt ms-dos)))) @@ -1299,6 +1297,8 @@ (ido-cache-unc-valid)) ((ido-is-ftp-directory dir) (ido-cache-ftp-valid)) + ((ido-directory-too-big-p dir) + nil) (t t))) (defun ido-pp (list &optional sep) @@ -3072,8 +3072,8 @@ (if ido-matches (let ((next (cadr ido-matches))) (setq ido-cur-list (ido-chop ido-cur-list next)) - (setq ido-rescan t) - (setq ido-rotate t)))) + (setq ido-matches (ido-chop ido-matches next)) + (setq ido-rescan nil)))) (defun ido-prev-match () "Put last element of `ido-matches' at the front of the list." @@ -3081,8 +3081,8 @@ (if ido-matches (let ((prev (car (last ido-matches)))) (setq ido-cur-list (ido-chop ido-cur-list prev)) - (setq ido-rescan t) - (setq ido-rotate t)))) + (setq ido-matches (ido-chop ido-matches prev)) + (setq ido-rescan nil)))) (defun ido-next-match-dir () "Find next directory in match list.
--- a/lisp/mail/rmail.el Tue Jan 11 22:13:06 2011 -0800 +++ b/lisp/mail/rmail.el Thu Jan 13 09:17:33 2011 -0800 @@ -3441,30 +3441,62 @@ ;;;; *** Rmail Mailing Commands *** (defun rmail-start-mail (&optional noerase to subject in-reply-to cc - replybuffer sendactions same-window others) - (let (yank-action) + replybuffer sendactions same-window + other-headers) + (let ((switch-function + (cond (same-window nil) + (rmail-mail-new-frame 'switch-to-buffer-other-frame) + (t 'switch-to-buffer-other-window))) + yank-action) (if replybuffer ;; The function used here must behave like insert-buffer wrt ;; point and mark (see doc of sc-cite-original). (setq yank-action (list 'insert-buffer replybuffer))) - (setq others (cons (cons "cc" cc) others)) - (setq others (cons (cons "in-reply-to" in-reply-to) others)) - (if same-window - (compose-mail to subject others - noerase nil - yank-action sendactions) - (if rmail-mail-new-frame - (prog1 - (compose-mail to subject others - noerase 'switch-to-buffer-other-frame - yank-action sendactions) - ;; This is not a standard frame parameter; - ;; nothing except sendmail.el looks at it. - (modify-frame-parameters (selected-frame) - '((mail-dedicated-frame . t)))) - (compose-mail to subject others - noerase 'switch-to-buffer-other-window - yank-action sendactions))))) + (push (cons "cc" cc) other-headers) + (push (cons "in-reply-to" in-reply-to) other-headers) + (prog1 + (compose-mail to subject other-headers noerase + switch-function yank-action sendactions + '(rmail-mail-return)) + (if (eq switch-function 'switch-to-buffer-other-frame) + ;; This is not a standard frame parameter; nothing except + ;; sendmail.el looks at it. + (modify-frame-parameters (selected-frame) + '((mail-dedicated-frame . t))))))) + +(defun rmail-mail-return () + (cond + ;; If there is only one visible frame with no special handling, + ;; consider deleting the mail window to return to Rmail. + ((or (null (delq (selected-frame) (visible-frame-list))) + (not (or (window-dedicated-p (frame-selected-window)) + (and pop-up-frames (one-window-p)) + (cdr (assq 'mail-dedicated-frame + (frame-parameters)))))) + (let (rmail-flag summary-buffer) + (and (not (one-window-p)) + (with-current-buffer + (window-buffer (next-window (selected-window) 'not)) + (setq rmail-flag (eq major-mode 'rmail-mode)) + (setq summary-buffer + (and (boundp 'mail-bury-selects-summary) + mail-bury-selects-summary + (boundp 'rmail-summary-buffer) + rmail-summary-buffer + (buffer-name rmail-summary-buffer) + (not (get-buffer-window rmail-summary-buffer)) + rmail-summary-buffer)))) + (if rmail-flag + ;; If the Rmail buffer has a summary, show that. + (if summary-buffer (switch-to-buffer summary-buffer) + (delete-window))))) + ;; If the frame was probably made for this buffer, the user + ;; probably wants to delete it now. + ((display-multi-frame-p) + (delete-frame (selected-frame))) + ;; The previous frame is where normally they have the Rmail buffer + ;; displayed. + (t (other-frame -1)))) (defun rmail-mail () "Send mail in another window.
--- a/lisp/mail/sendmail.el Tue Jan 11 22:13:06 2011 -0800 +++ b/lisp/mail/sendmail.el Thu Jan 13 09:17:33 2011 -0800 @@ -419,8 +419,7 @@ (defvar mail-reply-action nil) (defvar mail-send-actions nil "A list of actions to be performed upon successful sending of a message.") -(put 'mail-reply-action 'permanent-local t) -(put 'mail-send-actions 'permanent-local t) +(defvar mail-return-action nil) ;;;###autoload (defcustom mail-default-headers nil @@ -521,7 +520,46 @@ (setq mail-alias-modtime modtime mail-aliases t))))) -(defun mail-setup (to subject in-reply-to cc replybuffer actions) + +;;;###autoload +(define-mail-user-agent 'sendmail-user-agent + 'sendmail-user-agent-compose + 'mail-send-and-exit) + +;;;###autoload +(defun sendmail-user-agent-compose (&optional to subject other-headers + continue switch-function yank-action + send-actions return-action + &rest ignored) + (if switch-function + (let ((special-display-buffer-names nil) + (special-display-regexps nil) + (same-window-buffer-names nil) + (same-window-regexps nil)) + (funcall switch-function "*mail*"))) + (let ((cc (cdr (assoc-string "cc" other-headers t))) + (in-reply-to (cdr (assoc-string "in-reply-to" other-headers t))) + (body (cdr (assoc-string "body" other-headers t)))) + (or (mail continue to subject in-reply-to cc yank-action + send-actions return-action) + continue + (error "Message aborted")) + (save-excursion + (rfc822-goto-eoh) + (while other-headers + (unless (member-ignore-case (car (car other-headers)) + '("in-reply-to" "cc" "body")) + (insert (car (car other-headers)) ": " + (cdr (car other-headers)) + (if use-hard-newlines hard-newline "\n"))) + (setq other-headers (cdr other-headers))) + (when body + (forward-line 1) + (insert body)) + t))) + +(defun mail-setup (to subject in-reply-to cc replybuffer + actions return-action) (or mail-default-reply-to (setq mail-default-reply-to (getenv "REPLYTO"))) (sendmail-sync-aliases) @@ -537,8 +575,12 @@ (set-buffer-multibyte (default-value 'enable-multibyte-characters)) (if current-input-method (inactivate-input-method)) + + ;; Local variables for Mail mode. (setq mail-send-actions actions) (setq mail-reply-action replybuffer) + (setq mail-return-action return-action) + (goto-char (point-min)) (if mail-setup-with-from (mail-insert-from-field)) @@ -629,6 +671,7 @@ `mail-mode-hook' (in that order)." (make-local-variable 'mail-reply-action) (make-local-variable 'mail-send-actions) + (make-local-variable 'mail-return-action) (setq buffer-offer-save t) (make-local-variable 'font-lock-defaults) (setq font-lock-defaults '(mail-font-lock-keywords t t)) @@ -762,39 +805,9 @@ "Bury this mail buffer." (let ((newbuf (other-buffer (current-buffer)))) (bury-buffer (current-buffer)) - (if (and (or nil - ;; In this case, we need to go to a different frame. - (window-dedicated-p (frame-selected-window)) - ;; In this mode of operation, the frame was probably - ;; made for this buffer, so the user probably wants - ;; to delete it now. - (and pop-up-frames (one-window-p)) - (cdr (assq 'mail-dedicated-frame (frame-parameters)))) - (not (null (delq (selected-frame) (visible-frame-list))))) - (progn - (if (display-multi-frame-p) - (delete-frame (selected-frame)) - ;; The previous frame is where normally they have the - ;; Rmail buffer displayed. - (other-frame -1))) - (let (rmail-flag summary-buffer) - (and (not arg) - (not (one-window-p)) - (with-current-buffer - (window-buffer (next-window (selected-window) 'not)) - (setq rmail-flag (eq major-mode 'rmail-mode)) - (setq summary-buffer - (and mail-bury-selects-summary - (boundp 'rmail-summary-buffer) - rmail-summary-buffer - (buffer-name rmail-summary-buffer) - (not (get-buffer-window rmail-summary-buffer)) - rmail-summary-buffer)))) - (if rmail-flag - ;; If the Rmail buffer has a summary, show that. - (if summary-buffer (switch-to-buffer summary-buffer) - (delete-window)) - (switch-to-buffer newbuf)))))) + (if (and (null arg) mail-return-action) + (apply (car mail-return-action) (cdr mail-return-action)) + (switch-to-buffer newbuf)))) (defcustom mail-send-hook nil "Hook run just before sending a message." @@ -1643,7 +1656,8 @@ ;;;###autoload (add-hook 'same-window-buffer-names (purecopy "*unsent mail*")) ;;;###autoload -(defun mail (&optional noerase to subject in-reply-to cc replybuffer actions) +(defun mail (&optional noerase to subject in-reply-to cc replybuffer + actions return-action) "Edit a message to be sent. Prefix arg means resume editing (don't erase). When this function returns, the buffer `*mail*' is selected. The value is t if the message was newly initialized; otherwise, nil. @@ -1691,49 +1705,6 @@ when the message is sent, we apply FUNCTION to ARGS. This is how Rmail arranges to mark messages `answered'." (interactive "P") - ;; This is commented out because I found it was confusing in practice. - ;; It is easy enough to rename *mail* by hand with rename-buffer - ;; if you want to have multiple mail buffers. - ;; And then you can control which messages to save. --rms. - ;; (let ((index 1) - ;; buffer) - ;; ;; If requested, look for a mail buffer that is modified and go to it. - ;; (if noerase - ;; (progn - ;; (while (and (setq buffer - ;; (get-buffer (if (= 1 index) "*mail*" - ;; (format "*mail*<%d>" index)))) - ;; (not (buffer-modified-p buffer))) - ;; (setq index (1+ index))) - ;; (if buffer (switch-to-buffer buffer) - ;; ;; If none exists, start a new message. - ;; ;; This will never re-use an existing unmodified mail buffer - ;; ;; (since index is not 1 anymore). Perhaps it should. - ;; (setq noerase nil)))) - ;; ;; Unless we found a modified message and are happy, start a new message. - ;; (if (not noerase) - ;; (progn - ;; ;; Look for existing unmodified mail buffer. - ;; (while (and (setq buffer - ;; (get-buffer (if (= 1 index) "*mail*" - ;; (format "*mail*<%d>" index)))) - ;; (buffer-modified-p buffer)) - ;; (setq index (1+ index))) - ;; ;; If none, make a new one. - ;; (or buffer - ;; (setq buffer (generate-new-buffer "*mail*"))) - ;; ;; Go there and initialize it. - ;; (switch-to-buffer buffer) - ;; (erase-buffer) - ;; (setq default-directory (expand-file-name "~/")) - ;; (auto-save-mode auto-save-default) - ;; (mail-mode) - ;; (mail-setup to subject in-reply-to cc replybuffer actions) - ;; (if (and buffer-auto-save-file-name - ;; (file-exists-p buffer-auto-save-file-name)) - ;; (message "Auto save file for draft message exists; consider M-x mail-recover")) - ;; t)) - (if (eq noerase 'new) (pop-to-buffer (generate-new-buffer "*mail*")) (and noerase @@ -1772,7 +1743,8 @@ t)) (let ((inhibit-read-only t)) (erase-buffer) - (mail-setup to subject in-reply-to cc replybuffer actions) + (mail-setup to subject in-reply-to cc replybuffer actions + return-action) (setq initialized t))) (if (and buffer-auto-save-file-name (file-exists-p buffer-auto-save-file-name))
--- a/lisp/menu-bar.el Tue Jan 11 22:13:06 2011 -0800 +++ b/lisp/menu-bar.el Thu Jan 13 09:17:33 2011 -0800 @@ -584,18 +584,15 @@ (defvar menu-bar-custom-menu (make-sparse-keymap "Customize")) -(define-key menu-bar-custom-menu [customize-apropos-groups] - `(menu-item ,(purecopy "Groups Matching Regexp...") customize-apropos-groups - :help ,(purecopy "Browse groups whose names match regexp"))) (define-key menu-bar-custom-menu [customize-apropos-faces] - `(menu-item ,(purecopy "Faces Matching Regexp...") customize-apropos-faces - :help ,(purecopy "Browse faces whose names match regexp"))) + `(menu-item ,(purecopy "Faces Matching...") customize-apropos-faces + :help ,(purecopy "Browse faces matching a regexp or word list"))) (define-key menu-bar-custom-menu [customize-apropos-options] - `(menu-item ,(purecopy "Options Matching Regexp...") customize-apropos-options - :help ,(purecopy "Browse options whose names match regexp"))) + `(menu-item ,(purecopy "Options Matching...") customize-apropos-options + :help ,(purecopy "Browse options matching a regexp or word list"))) (define-key menu-bar-custom-menu [customize-apropos] - `(menu-item ,(purecopy "Settings Matching Regexp...") customize-apropos - :help ,(purecopy "Browse customizable settings whose names match regexp"))) + `(menu-item ,(purecopy "All Settings Matching...") customize-apropos + :help ,(purecopy "Browse customizable settings matching a regexp or word list"))) (define-key menu-bar-custom-menu [separator-1] menu-bar-separator) (define-key menu-bar-custom-menu [customize-group] @@ -623,6 +620,9 @@ (define-key menu-bar-custom-menu [customize] `(menu-item ,(purecopy "Top-level Customization Group") customize :help ,(purecopy "The master group called `Emacs'"))) +(define-key menu-bar-custom-menu [customize-themes] + `(menu-item ,(purecopy "Custom Themes") customize-themes + :help ,(purecopy "Choose a pre-defined customization theme"))) ;(defvar menu-bar-preferences-menu (make-sparse-keymap "Preferences")) @@ -1144,7 +1144,7 @@ ;; It is better not to use backquote here, ;; because that makes a bootstrapping problem ;; if you need to recompile all the Lisp files using interpreted code. - `(menu-item ,(purecopy "Mule (Multilingual Environment)") ,mule-menu-keymap + `(menu-item ,(purecopy "Multilingual Environment") ,mule-menu-keymap ;; Most of the MULE menu actually does make sense in unibyte mode, ;; e.g. language selection. ;;; :visible '(default-value 'enable-multibyte-characters)
--- a/lisp/mh-e/ChangeLog Tue Jan 11 22:13:06 2011 -0800 +++ b/lisp/mh-e/ChangeLog Thu Jan 13 09:17:33 2011 -0800 @@ -1,3 +1,7 @@ +2011-01-13 Chong Yidong <cyd@stupidchicken.com> + + * mh-comp.el (mh-user-agent-compose): New arg RETURN-ACTION. + 2010-11-07 Glenn Morris <rgm@gnu.org> * mh-seq.el (mh-read-msg-list): Use point-at-eol.
--- a/lisp/mh-e/mh-comp.el Tue Jan 11 22:13:06 2011 -0800 +++ b/lisp/mh-e/mh-comp.el Thu Jan 13 09:17:33 2011 -0800 @@ -199,7 +199,8 @@ ;;;###autoload (defun mh-user-agent-compose (&optional to subject other-headers continue switch-function yank-action - send-actions) + send-actions return-action + &rest ignored) "Set up mail composition draft with the MH mail system. This is the `mail-user-agent' entry point to MH-E. This function conforms to the contract specified by `define-mail-user-agent' @@ -213,8 +214,8 @@ Elements look like (HEADER . VALUE) where both HEADER and VALUE are strings. -CONTINUE, SWITCH-FUNCTION, YANK-ACTION and SEND-ACTIONS are -ignored." +CONTINUE, SWITCH-FUNCTION, YANK-ACTION, SEND-ACTIONS, and +RETURN-ACTION are ignored." (mh-find-path) (let ((mh-error-if-no-draft t)) (mh-send to "" subject)
--- a/lisp/simple.el Tue Jan 11 22:13:06 2011 -0800 +++ b/lisp/simple.el Thu Jan 13 09:17:33 2011 -0800 @@ -5712,10 +5712,6 @@ :version "23.2" :group 'mail) -(define-mail-user-agent 'sendmail-user-agent - 'sendmail-user-agent-compose - 'mail-send-and-exit) - (defun rfc822-goto-eoh () ;; Go to header delimiter line in a mail message, following RFC822 rules (goto-char (point-min)) @@ -5723,37 +5719,9 @@ "^\\([:\n]\\|[^: \t\n]+[ \t\n]\\)" nil 'move) (goto-char (match-beginning 0)))) -(defun sendmail-user-agent-compose (&optional to subject other-headers continue - switch-function yank-action - send-actions) - (if switch-function - (let ((special-display-buffer-names nil) - (special-display-regexps nil) - (same-window-buffer-names nil) - (same-window-regexps nil)) - (funcall switch-function "*mail*"))) - (let ((cc (cdr (assoc-string "cc" other-headers t))) - (in-reply-to (cdr (assoc-string "in-reply-to" other-headers t))) - (body (cdr (assoc-string "body" other-headers t)))) - (or (mail continue to subject in-reply-to cc yank-action send-actions) - continue - (error "Message aborted")) - (save-excursion - (rfc822-goto-eoh) - (while other-headers - (unless (member-ignore-case (car (car other-headers)) - '("in-reply-to" "cc" "body")) - (insert (car (car other-headers)) ": " - (cdr (car other-headers)) - (if use-hard-newlines hard-newline "\n"))) - (setq other-headers (cdr other-headers))) - (when body - (forward-line 1) - (insert body)) - t))) - (defun compose-mail (&optional to subject other-headers continue - switch-function yank-action send-actions) + switch-function yank-action send-actions + return-action) "Start composing a mail message to send. This uses the user's chosen mail composition package as selected with the variable `mail-user-agent'. @@ -5778,7 +5746,12 @@ original text has been inserted in this way.) SEND-ACTIONS is a list of actions to call when the message is sent. -Each action has the form (FUNCTION . ARGS)." +Each action has the form (FUNCTION . ARGS). + +RETURN-ACTION, if non-nil, is an action for returning to the +caller. It has the form (FUNCTION . ARGS). The function is +called after the mail has been sent or put aside, and the mail +buffer buried." (interactive (list nil nil nil current-prefix-arg)) @@ -5808,25 +5781,27 @@ warn-vars " ")))))) (let ((function (get mail-user-agent 'composefunc))) - (funcall function to subject other-headers continue - switch-function yank-action send-actions))) + (funcall function to subject other-headers continue switch-function + yank-action send-actions return-action))) (defun compose-mail-other-window (&optional to subject other-headers continue - yank-action send-actions) + yank-action send-actions + return-action) "Like \\[compose-mail], but edit the outgoing message in another window." - (interactive - (list nil nil nil current-prefix-arg)) + (interactive (list nil nil nil current-prefix-arg)) (compose-mail to subject other-headers continue - 'switch-to-buffer-other-window yank-action send-actions)) - + 'switch-to-buffer-other-window yank-action send-actions + return-action)) (defun compose-mail-other-frame (&optional to subject other-headers continue - yank-action send-actions) + yank-action send-actions + return-action) "Like \\[compose-mail], but edit the outgoing message in another frame." - (interactive - (list nil nil nil current-prefix-arg)) + (interactive (list nil nil nil current-prefix-arg)) (compose-mail to subject other-headers continue - 'switch-to-buffer-other-frame yank-action send-actions)) + 'switch-to-buffer-other-frame yank-action send-actions + return-action)) + (defvar set-variable-value-history nil "History of values entered with `set-variable'.
--- a/src/image.c Tue Jan 11 22:13:06 2011 -0800 +++ b/src/image.c Thu Jan 13 09:17:33 2011 -0800 @@ -7519,7 +7519,7 @@ image to see how many sub-images it contains. Pinging is faster than loading the image to find out things about it. */ - /* MagickWandGenesis() initializes the imagemagick library. */ + /* `MagickWandGenesis' initializes the imagemagick environment. */ MagickWandGenesis (); image = image_spec_value (img->spec, QCindex, NULL); ino = INTEGERP (image) ? XFASTINT (image) : 0; @@ -7807,6 +7807,7 @@ /* Final cleanup. image_wand should be the only resource left. */ DestroyMagickWand (image_wand); + /* `MagickWandTerminus' terminates the imagemagick environment. */ MagickWandTerminus (); return 1;
--- a/test/ChangeLog Tue Jan 11 22:13:06 2011 -0800 +++ b/test/ChangeLog Thu Jan 13 09:17:33 2011 -0800 @@ -1,3 +1,11 @@ +2011-01-13 Christian Ohler <ohler@gnu.org> + + * automated: New directory for automated tests. + + * automated/ert-tests.el, automated/ert-x-tests.el: New files. + + * automated/Makefile.in: New file. + 2010-11-11 Stefan Monnier <monnier@iro.umontreal.ca> * indent/modula2.mod: New file.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/test/automated/Makefile.in Thu Jan 13 09:17:33 2011 -0800 @@ -0,0 +1,158 @@ +# Maintenance productions for the automated test directory +# Copyright (C) 2010, 2011 Free Software Foundation, Inc. + +# This file is part of GNU Emacs. + +# GNU Emacs is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. + +# GNU Emacs is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. + +# You should have received a copy of the GNU General Public License +# along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +SHELL = /bin/sh + +srcdir = @srcdir@ +top_srcdir = @top_srcdir@ +abs_top_builddir = @abs_top_builddir@ +test = $(srcdir) +VPATH = $(srcdir) +lispsrc = $(top_srcdir)/lisp +lisp = ${abs_top_builddir}/lisp + +# You can specify a different executable on the make command line, +# e.g. "make EMACS=../src/emacs ...". + +# We sometimes change directory before running Emacs (typically when +# building out-of-tree, we chdir to the source directory), so we need +# to use an absolute file name. +EMACS = ${abs_top_builddir}/src/emacs + +# Command line flags for Emacs. + +EMACSOPT = -batch --no-site-file --no-site-lisp + +# Extra flags to pass to the byte compiler +BYTE_COMPILE_EXTRA_FLAGS = +# For example to not display the undefined function warnings you can use this: +# BYTE_COMPILE_EXTRA_FLAGS = --eval '(setq byte-compile-warnings (quote (not unresolved)))' +# The example above is just for developers, it should not be used by default. + +# The actual Emacs command run in the targets below. +emacs = EMACSLOADPATH=$(lispsrc):$(test) LC_ALL=C $(EMACS) $(EMACSOPT) + +# Common command to find subdirectories +setwins=subdirs=`(find . -type d -print)`; \ + for file in $$subdirs; do \ + case $$file in */.* | */.*/* | */=* ) ;; \ + *) wins="$$wins $$file" ;; \ + esac; \ + done + +all: test + +doit: + + +# Files MUST be compiled one by one. If we compile several files in a +# row (i.e., in the same instance of Emacs) we can't make sure that +# the compilation environment is clean. We also set the load-path of +# the Emacs used for compilation to the current directory and its +# subdirectories, to make sure require's and load's in the files being +# compiled find the right files. + +.SUFFIXES: .elc .el + +# An old-fashioned suffix rule, which, according to the GNU Make manual, +# cannot have prerequisites. +.el.elc: + @echo Compiling $< + @$(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $< + +.PHONY: lisp-compile compile-main compile compile-always + +lisp-compile: + cd $(lisp); $(MAKE) $(MFLAGS) compile EMACS=$(EMACS) + +# In `compile-main' we could directly do +# ... | xargs $(MAKE) $(MFLAGS) EMACS="$(EMACS)" +# and it works, but it generates a lot of messages like +# make[2]: « gnus/gnus-mlspl.elc » is up to date. +# so instead, we use "xargs echo" to split the list of file into manageable +# chunks and then use an intermediate `compile-targets' target so the +# actual targets (the .elc files) are not mentioned as targets on the +# make command line. + + +.PHONY: compile-targets +# TARGETS is set dynamically in the recursive call from `compile-main'. +compile-targets: $(TARGETS) + +# Compile all the Elisp files that need it. Beware: it approximates +# `no-byte-compile', so watch out for false-positives! +compile-main: compile-clean lisp-compile + @(cd $(test); $(setwins); \ + els=`echo "$$wins " | sed -e 's|/\./|/|g' -e 's|/\. | |g' -e 's| |/*.el |g'`; \ + for el in $$els; do \ + test -f $$el || continue; \ + test ! -f $${el}c && GREP_OPTIONS= grep '^;.*no-byte-compile: t' $$el > /dev/null && continue; \ + echo "$${el}c"; \ + done | xargs echo) | \ + while read chunk; do \ + $(MAKE) $(MFLAGS) compile-targets EMACS="$(EMACS)" TARGETS="$$chunk"; \ + done + +.PHONY: compile-clean +# Erase left-over .elc files that do not have a corresponding .el file. +compile-clean: + @cd $(test); $(setwins); \ + elcs=`echo "$$wins " | sed -e 's|/\./|/|g' -e 's|/\. | |g' -e 's| |/*.elc |g'`; \ + for el in $$(echo $$elcs | sed -e 's/\.elc/\.el/g'); do \ + if test -f "$$el" -o \! -f "$${el}c"; then :; else \ + echo rm "$${el}c"; \ + rm "$${el}c"; \ + fi \ + done + +# Compile all Lisp files, but don't recompile those that are up to +# date. Some .el files don't get compiled because they set the +# local variable no-byte-compile. +# Calling make recursively because suffix rule cannot have prerequisites. +# Explicitly pass EMACS (sometimes ../src/bootstrap-emacs) to those +# sub-makes that run rules that use it, for the sake of some non-GNU makes. +compile: $(LOADDEFS) autoloads compile-first + $(MAKE) $(MFLAGS) compile-main EMACS=$(EMACS) + +# Compile all Lisp files. This is like `compile' but compiles files +# unconditionally. Some files don't actually get compiled because they +# set the local variable no-byte-compile. +compile-always: doit + cd $(test); rm -f *.elc */*.elc */*/*.elc */*/*/*.elc + $(MAKE) $(MFLAGS) compile EMACS=$(EMACS) + +bootstrap-clean: + cd $(test); rm -f *.elc */*.elc */*/*.elc */*/*/*.elc + +distclean: + -rm -f ./Makefile + +maintainer-clean: distclean bootstrap-clean + +check: compile-main + @(cd $(test); $(setwins); \ + pattern=`echo "$$wins " | sed -e 's|/\./|/|g' -e 's|/\. | |g' -e 's| |/*.el |g'`; \ + for el in $$pattern; do \ + test -f $$el || continue; \ + args="$$args -l $$el"; \ + els="$$els $$el"; \ + done; \ + echo Testing $$els; \ + $(emacs) $$args -f ert-run-tests-batch-and-exit) + +# Makefile ends here.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/test/automated/ert-tests.el Thu Jan 13 09:17:33 2011 -0800 @@ -0,0 +1,949 @@ +;;; ert-tests.el --- ERT's self-tests + +;; Copyright (C) 2007, 2008, 2010, 2011 Free Software Foundation, Inc. + +;; Author: Christian Ohler <ohler@gnu.org> + +;; This file is part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `http://www.gnu.org/licenses/'. + +;;; Commentary: + +;; This file is part of ERT, the Emacs Lisp Regression Testing tool. +;; See ert.el or the texinfo manual for more details. + +;;; Code: + +(eval-when-compile + (require 'cl)) +(require 'ert) + + +;;; Self-test that doesn't rely on ERT, for bootstrapping. + +;; This is used to test that bodies actually run. +(defvar ert--test-body-was-run) +(ert-deftest ert-test-body-runs () + (setq ert--test-body-was-run t)) + +(defun ert-self-test () + "Run ERT's self-tests and make sure they actually ran." + (let ((window-configuration (current-window-configuration))) + (let ((ert--test-body-was-run nil)) + ;; The buffer name chosen here should not compete with the default + ;; results buffer name for completion in `switch-to-buffer'. + (let ((stats (ert-run-tests-interactively "^ert-" " *ert self-tests*"))) + (assert ert--test-body-was-run) + (if (zerop (ert-stats-completed-unexpected stats)) + ;; Hide results window only when everything went well. + (set-window-configuration window-configuration) + (error "ERT self-test failed")))))) + +(defun ert-self-test-and-exit () + "Run ERT's self-tests and exit Emacs. + +The exit code will be zero if the tests passed, nonzero if they +failed or if there was a problem." + (unwind-protect + (progn + (ert-self-test) + (kill-emacs 0)) + (unwind-protect + (progn + (message "Error running tests") + (backtrace)) + (kill-emacs 1)))) + + +;;; Further tests are defined using ERT. + +(ert-deftest ert-test-nested-test-body-runs () + "Test that nested test bodies run." + (lexical-let ((was-run nil)) + (let ((test (make-ert-test :body (lambda () + (setq was-run t))))) + (assert (not was-run)) + (ert-run-test test) + (assert was-run)))) + + +;;; Test that pass/fail works. +(ert-deftest ert-test-pass () + (let ((test (make-ert-test :body (lambda ())))) + (let ((result (ert-run-test test))) + (assert (ert-test-passed-p result))))) + +(ert-deftest ert-test-fail () + (let ((test (make-ert-test :body (lambda () (ert-fail "failure message"))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (assert (ert-test-failed-p result) t) + (assert (equal (ert-test-result-with-condition-condition result) + '(ert-test-failed "failure message")) + t)))) + +(ert-deftest ert-test-fail-debug-with-condition-case () + (let ((test (make-ert-test :body (lambda () (ert-fail "failure message"))))) + (condition-case condition + (progn + (let ((ert-debug-on-error t)) + (ert-run-test test)) + (assert nil)) + ((error) + (assert (equal condition '(ert-test-failed "failure message")) t))))) + +(ert-deftest ert-test-fail-debug-with-debugger-1 () + (let ((test (make-ert-test :body (lambda () (ert-fail "failure message"))))) + (let ((debugger (lambda (&rest debugger-args) + (assert nil)))) + (let ((ert-debug-on-error nil)) + (ert-run-test test))))) + +(ert-deftest ert-test-fail-debug-with-debugger-2 () + (let ((test (make-ert-test :body (lambda () (ert-fail "failure message"))))) + (block nil + (let ((debugger (lambda (&rest debugger-args) + (return-from nil nil)))) + (let ((ert-debug-on-error t)) + (ert-run-test test)) + (assert nil))))) + +(ert-deftest ert-test-fail-debug-nested-with-debugger () + (let ((test (make-ert-test :body (lambda () + (let ((ert-debug-on-error t)) + (ert-fail "failure message")))))) + (let ((debugger (lambda (&rest debugger-args) + (assert nil nil "Assertion a")))) + (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (let ((test (make-ert-test :body (lambda () + (let ((ert-debug-on-error nil)) + (ert-fail "failure message")))))) + (block nil + (let ((debugger (lambda (&rest debugger-args) + (return-from nil nil)))) + (let ((ert-debug-on-error t)) + (ert-run-test test)) + (assert nil nil "Assertion b"))))) + +(ert-deftest ert-test-error () + (let ((test (make-ert-test :body (lambda () (error "Error message"))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (assert (ert-test-failed-p result) t) + (assert (equal (ert-test-result-with-condition-condition result) + '(error "Error message")) + t)))) + +(ert-deftest ert-test-error-debug () + (let ((test (make-ert-test :body (lambda () (error "Error message"))))) + (condition-case condition + (progn + (let ((ert-debug-on-error t)) + (ert-run-test test)) + (assert nil)) + ((error) + (assert (equal condition '(error "Error message")) t))))) + + +;;; Test that `should' works. +(ert-deftest ert-test-should () + (let ((test (make-ert-test :body (lambda () (should nil))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (assert (ert-test-failed-p result) t) + (assert (equal (ert-test-result-with-condition-condition result) + '(ert-test-failed ((should nil) :form nil :value nil))) + t))) + (let ((test (make-ert-test :body (lambda () (should t))))) + (let ((result (ert-run-test test))) + (assert (ert-test-passed-p result) t)))) + +(ert-deftest ert-test-should-value () + (should (eql (should 'foo) 'foo)) + (should (eql (should 'bar) 'bar))) + +(ert-deftest ert-test-should-not () + (let ((test (make-ert-test :body (lambda () (should-not t))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (assert (ert-test-failed-p result) t) + (assert (equal (ert-test-result-with-condition-condition result) + '(ert-test-failed ((should-not t) :form t :value t))) + t))) + (let ((test (make-ert-test :body (lambda () (should-not nil))))) + (let ((result (ert-run-test test))) + (assert (ert-test-passed-p result))))) + +(ert-deftest ert-test-should-with-macrolet () + (let ((test (make-ert-test :body (lambda () + (macrolet ((foo () `(progn t nil))) + (should (foo))))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (should (ert-test-failed-p result)) + (should (equal + (ert-test-result-with-condition-condition result) + '(ert-test-failed ((should (foo)) + :form (progn t nil) + :value nil))))))) + +(ert-deftest ert-test-should-error () + ;; No error. + (let ((test (make-ert-test :body (lambda () (should-error (progn)))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (should (ert-test-failed-p result)) + (should (equal (ert-test-result-with-condition-condition result) + '(ert-test-failed + ((should-error (progn)) + :form (progn) + :value nil + :fail-reason "did not signal an error")))))) + ;; A simple error. + (should (equal (should-error (error "Foo")) + '(error "Foo"))) + ;; Error of unexpected type. + (let ((test (make-ert-test :body (lambda () + (should-error (error "Foo") + :type 'singularity-error))))) + (let ((result (ert-run-test test))) + (should (ert-test-failed-p result)) + (should (equal + (ert-test-result-with-condition-condition result) + '(ert-test-failed + ((should-error (error "Foo") :type 'singularity-error) + :form (error "Foo") + :condition (error "Foo") + :fail-reason + "the error signalled did not have the expected type")))))) + ;; Error of the expected type. + (let* ((error nil) + (test (make-ert-test + :body (lambda () + (setq error + (should-error (signal 'singularity-error nil) + :type 'singularity-error)))))) + (let ((result (ert-run-test test))) + (should (ert-test-passed-p result)) + (should (equal error '(singularity-error)))))) + +(ert-deftest ert-test-should-error-subtypes () + (should-error (signal 'singularity-error nil) + :type 'singularity-error + :exclude-subtypes t) + (let ((test (make-ert-test + :body (lambda () + (should-error (signal 'arith-error nil) + :type 'singularity-error))))) + (let ((result (ert-run-test test))) + (should (ert-test-failed-p result)) + (should (equal + (ert-test-result-with-condition-condition result) + '(ert-test-failed + ((should-error (signal 'arith-error nil) + :type 'singularity-error) + :form (signal arith-error nil) + :condition (arith-error) + :fail-reason + "the error signalled did not have the expected type")))))) + (let ((test (make-ert-test + :body (lambda () + (should-error (signal 'arith-error nil) + :type 'singularity-error + :exclude-subtypes t))))) + (let ((result (ert-run-test test))) + (should (ert-test-failed-p result)) + (should (equal + (ert-test-result-with-condition-condition result) + '(ert-test-failed + ((should-error (signal 'arith-error nil) + :type 'singularity-error + :exclude-subtypes t) + :form (signal arith-error nil) + :condition (arith-error) + :fail-reason + "the error signalled did not have the expected type")))))) + (let ((test (make-ert-test + :body (lambda () + (should-error (signal 'singularity-error nil) + :type 'arith-error + :exclude-subtypes t))))) + (let ((result (ert-run-test test))) + (should (ert-test-failed-p result)) + (should (equal + (ert-test-result-with-condition-condition result) + '(ert-test-failed + ((should-error (signal 'singularity-error nil) + :type 'arith-error + :exclude-subtypes t) + :form (signal singularity-error nil) + :condition (singularity-error) + :fail-reason + "the error signalled was a subtype of the expected type"))))) + )) + +(defmacro ert--test-my-list (&rest args) + "Don't use this. Instead, call `list' with ARGS, it does the same thing. + +This macro is used to test if macroexpansion in `should' works." + `(list ,@args)) + +(ert-deftest ert-test-should-failure-debugging () + "Test that `should' errors contain the information we expect them to." + (loop for (body expected-condition) in + `((,(lambda () (let ((x nil)) (should x))) + (ert-test-failed ((should x) :form x :value nil))) + (,(lambda () (let ((x t)) (should-not x))) + (ert-test-failed ((should-not x) :form x :value t))) + (,(lambda () (let ((x t)) (should (not x)))) + (ert-test-failed ((should (not x)) :form (not t) :value nil))) + (,(lambda () (let ((x nil)) (should-not (not x)))) + (ert-test-failed ((should-not (not x)) :form (not nil) :value t))) + (,(lambda () (let ((x t) (y nil)) (should-not + (ert--test-my-list x y)))) + (ert-test-failed + ((should-not (ert--test-my-list x y)) + :form (list t nil) + :value (t nil)))) + (,(lambda () (let ((x t)) (should (error "Foo")))) + (error "Foo"))) + do + (let ((test (make-ert-test :body body))) + (condition-case actual-condition + (progn + (let ((ert-debug-on-error t)) + (ert-run-test test)) + (assert nil)) + ((error) + (should (equal actual-condition expected-condition))))))) + +(ert-deftest ert-test-deftest () + (should (equal (macroexpand '(ert-deftest abc () "foo" :tags '(bar))) + '(progn + (ert-set-test 'abc + (make-ert-test :name 'abc + :documentation "foo" + :tags '(bar) + :body (lambda ()))) + (push '(ert-deftest . abc) current-load-list) + 'abc))) + (should (equal (macroexpand '(ert-deftest def () + :expected-result ':passed)) + '(progn + (ert-set-test 'def + (make-ert-test :name 'def + :expected-result-type ':passed + :body (lambda ()))) + (push '(ert-deftest . def) current-load-list) + 'def))) + ;; :documentation keyword is forbidden + (should-error (macroexpand '(ert-deftest ghi () + :documentation "foo")))) + +(ert-deftest ert-test-record-backtrace () + (let ((test (make-ert-test :body (lambda () (ert-fail "foo"))))) + (let ((result (ert-run-test test))) + (should (ert-test-failed-p result)) + (with-temp-buffer + (ert--print-backtrace (ert-test-failed-backtrace result)) + (goto-char (point-min)) + (end-of-line) + (let ((first-line (buffer-substring-no-properties (point-min) (point)))) + (should (equal first-line " signal(ert-test-failed (\"foo\"))"))))))) + +(ert-deftest ert-test-messages () + :tags '(:causes-redisplay) + (let* ((message-string "Test message") + (messages-buffer (get-buffer-create "*Messages*")) + (test (make-ert-test :body (lambda () (message "%s" message-string))))) + (with-current-buffer messages-buffer + (let ((result (ert-run-test test))) + (should (equal (concat message-string "\n") + (ert-test-result-messages result))))))) + +(ert-deftest ert-test-running-tests () + (let ((outer-test (ert-get-test 'ert-test-running-tests))) + (should (equal (ert-running-test) outer-test)) + (let (test1 test2 test3) + (setq test1 (make-ert-test + :name "1" + :body (lambda () + (should (equal (ert-running-test) outer-test)) + (should (equal ert--running-tests + (list test1 test2 test3 + outer-test))))) + test2 (make-ert-test + :name "2" + :body (lambda () + (should (equal (ert-running-test) outer-test)) + (should (equal ert--running-tests + (list test3 test2 outer-test))) + (ert-run-test test1))) + test3 (make-ert-test + :name "3" + :body (lambda () + (should (equal (ert-running-test) outer-test)) + (should (equal ert--running-tests + (list test3 outer-test))) + (ert-run-test test2)))) + (should (ert-test-passed-p (ert-run-test test3)))))) + +(ert-deftest ert-test-test-result-expected-p () + "Test `ert-test-result-expected-p' and (implicitly) `ert-test-result-type-p'." + ;; passing test + (let ((test (make-ert-test :body (lambda ())))) + (should (ert-test-result-expected-p test (ert-run-test test)))) + ;; unexpected failure + (let ((test (make-ert-test :body (lambda () (ert-fail "failed"))))) + (should-not (ert-test-result-expected-p test (ert-run-test test)))) + ;; expected failure + (let ((test (make-ert-test :body (lambda () (ert-fail "failed")) + :expected-result-type ':failed))) + (should (ert-test-result-expected-p test (ert-run-test test)))) + ;; `not' expected type + (let ((test (make-ert-test :body (lambda ()) + :expected-result-type '(not :failed)))) + (should (ert-test-result-expected-p test (ert-run-test test)))) + (let ((test (make-ert-test :body (lambda ()) + :expected-result-type '(not :passed)))) + (should-not (ert-test-result-expected-p test (ert-run-test test)))) + ;; `and' expected type + (let ((test (make-ert-test :body (lambda ()) + :expected-result-type '(and :passed :failed)))) + (should-not (ert-test-result-expected-p test (ert-run-test test)))) + (let ((test (make-ert-test :body (lambda ()) + :expected-result-type '(and :passed + (not :failed))))) + (should (ert-test-result-expected-p test (ert-run-test test)))) + ;; `or' expected type + (let ((test (make-ert-test :body (lambda ()) + :expected-result-type '(or (and :passed :failed) + :passed)))) + (should (ert-test-result-expected-p test (ert-run-test test)))) + (let ((test (make-ert-test :body (lambda ()) + :expected-result-type '(or (and :passed :failed) + nil (not t))))) + (should-not (ert-test-result-expected-p test (ert-run-test test))))) + +;;; Test `ert-select-tests'. +(ert-deftest ert-test-select-regexp () + (should (equal (ert-select-tests "^ert-test-select-regexp$" t) + (list (ert-get-test 'ert-test-select-regexp))))) + +(ert-deftest ert-test-test-boundp () + (should (ert-test-boundp 'ert-test-test-boundp)) + (should-not (ert-test-boundp (make-symbol "ert-not-a-test")))) + +(ert-deftest ert-test-select-member () + (should (equal (ert-select-tests '(member ert-test-select-member) t) + (list (ert-get-test 'ert-test-select-member))))) + +(ert-deftest ert-test-select-test () + (should (equal (ert-select-tests (ert-get-test 'ert-test-select-test) t) + (list (ert-get-test 'ert-test-select-test))))) + +(ert-deftest ert-test-select-symbol () + (should (equal (ert-select-tests 'ert-test-select-symbol t) + (list (ert-get-test 'ert-test-select-symbol))))) + +(ert-deftest ert-test-select-and () + (let ((test (make-ert-test + :name nil + :body nil + :most-recent-result (make-ert-test-failed + :condition nil + :backtrace nil + :infos nil)))) + (should (equal (ert-select-tests `(and (member ,test) :failed) t) + (list test))))) + +(ert-deftest ert-test-select-tag () + (let ((test (make-ert-test + :name nil + :body nil + :tags '(a b)))) + (should (equal (ert-select-tests `(tag a) (list test)) (list test))) + (should (equal (ert-select-tests `(tag b) (list test)) (list test))) + (should (equal (ert-select-tests `(tag c) (list test)) '())))) + + +;;; Tests for utility functions. +(ert-deftest ert-test-proper-list-p () + (should (ert--proper-list-p '())) + (should (ert--proper-list-p '(1))) + (should (ert--proper-list-p '(1 2))) + (should (ert--proper-list-p '(1 2 3))) + (should (ert--proper-list-p '(1 2 3 4))) + (should (not (ert--proper-list-p 'a))) + (should (not (ert--proper-list-p '(1 . a)))) + (should (not (ert--proper-list-p '(1 2 . a)))) + (should (not (ert--proper-list-p '(1 2 3 . a)))) + (should (not (ert--proper-list-p '(1 2 3 4 . a)))) + (let ((a (list 1))) + (setf (cdr (last a)) a) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2))) + (setf (cdr (last a)) a) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2 3))) + (setf (cdr (last a)) a) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2 3 4))) + (setf (cdr (last a)) a) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2))) + (setf (cdr (last a)) (cdr a)) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2 3))) + (setf (cdr (last a)) (cdr a)) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2 3 4))) + (setf (cdr (last a)) (cdr a)) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2 3))) + (setf (cdr (last a)) (cddr a)) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2 3 4))) + (setf (cdr (last a)) (cddr a)) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2 3 4))) + (setf (cdr (last a)) (cdddr a)) + (should (not (ert--proper-list-p a))))) + +(ert-deftest ert-test-parse-keys-and-body () + (should (equal (ert--parse-keys-and-body '(foo)) '(nil (foo)))) + (should (equal (ert--parse-keys-and-body '(:bar foo)) '((:bar foo) nil))) + (should (equal (ert--parse-keys-and-body '(:bar foo a (b))) + '((:bar foo) (a (b))))) + (should (equal (ert--parse-keys-and-body '(:bar foo :a (b))) + '((:bar foo :a (b)) nil))) + (should (equal (ert--parse-keys-and-body '(bar foo :a (b))) + '(nil (bar foo :a (b))))) + (should-error (ert--parse-keys-and-body '(:bar foo :a)))) + + +(ert-deftest ert-test-run-tests-interactively () + :tags '(:causes-redisplay) + (let ((passing-test (make-ert-test :name 'passing-test + :body (lambda () (ert-pass)))) + (failing-test (make-ert-test :name 'failing-test + :body (lambda () (ert-fail + "failure message"))))) + (let ((ert-debug-on-error nil)) + (let* ((buffer-name (generate-new-buffer-name " *ert-test-run-tests*")) + (messages nil) + (mock-message-fn + (lambda (format-string &rest args) + (push (apply #'format format-string args) messages)))) + (save-window-excursion + (unwind-protect + (let ((case-fold-search nil)) + (ert-run-tests-interactively + `(member ,passing-test ,failing-test) buffer-name + mock-message-fn) + (should (equal messages `(,(concat + "Ran 2 tests, 1 results were " + "as expected, 1 unexpected")))) + (with-current-buffer buffer-name + (goto-char (point-min)) + (should (equal + (buffer-substring (point-min) + (save-excursion + (forward-line 4) + (point))) + (concat + "Selector: (member <passing-test> <failing-test>)\n" + "Passed: 1\n" + "Failed: 1 (1 unexpected)\n" + "Total: 2/2\n"))))) + (when (get-buffer buffer-name) + (kill-buffer buffer-name)))))))) + +(ert-deftest ert-test-special-operator-p () + (should (ert--special-operator-p 'if)) + (should-not (ert--special-operator-p 'car)) + (should-not (ert--special-operator-p 'ert--special-operator-p)) + (let ((b (ert--gensym))) + (should-not (ert--special-operator-p b)) + (fset b 'if) + (should (ert--special-operator-p b)))) + +(ert-deftest ert-test-list-of-should-forms () + (let ((test (make-ert-test :body (lambda () + (should t) + (should (null '())) + (should nil) + (should t))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (should (equal (ert-test-result-should-forms result) + '(((should t) :form t :value t) + ((should (null '())) :form (null nil) :value t) + ((should nil) :form nil :value nil))))))) + +(ert-deftest ert-test-list-of-should-forms-observers-should-not-stack () + (let ((test (make-ert-test + :body (lambda () + (let ((test2 (make-ert-test + :body (lambda () + (should t))))) + (let ((result (ert-run-test test2))) + (should (ert-test-passed-p result)))))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (should (ert-test-passed-p result)) + (should (eql (length (ert-test-result-should-forms result)) + 1))))) + +(ert-deftest ert-test-list-of-should-forms-no-deep-copy () + (let ((test (make-ert-test :body (lambda () + (let ((obj (list 'a))) + (should (equal obj '(a))) + (setf (car obj) 'b) + (should (equal obj '(b)))))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (should (ert-test-passed-p result)) + (should (equal (ert-test-result-should-forms result) + '(((should (equal obj '(a))) :form (equal (b) (a)) :value t + :explanation nil) + ((should (equal obj '(b))) :form (equal (b) (b)) :value t + :explanation nil) + )))))) + +(ert-deftest ert-test-remprop () + (let ((x (ert--gensym))) + (should (equal (symbol-plist x) '())) + ;; Remove nonexistent property on empty plist. + (ert--remprop x 'b) + (should (equal (symbol-plist x) '())) + (put x 'a 1) + (should (equal (symbol-plist x) '(a 1))) + ;; Remove nonexistent property on nonempty plist. + (ert--remprop x 'b) + (should (equal (symbol-plist x) '(a 1))) + (put x 'b 2) + (put x 'c 3) + (put x 'd 4) + (should (equal (symbol-plist x) '(a 1 b 2 c 3 d 4))) + ;; Remove property that is neither first nor last. + (ert--remprop x 'c) + (should (equal (symbol-plist x) '(a 1 b 2 d 4))) + ;; Remove last property from a plist of length >1. + (ert--remprop x 'd) + (should (equal (symbol-plist x) '(a 1 b 2))) + ;; Remove first property from a plist of length >1. + (ert--remprop x 'a) + (should (equal (symbol-plist x) '(b 2))) + ;; Remove property when there is only one. + (ert--remprop x 'b) + (should (equal (symbol-plist x) '())))) + +(ert-deftest ert-test-remove-if-not () + (let ((list (list 'a 'b 'c 'd)) + (i 0)) + (let ((result (ert--remove-if-not (lambda (x) + (should (eql x (nth i list))) + (incf i) + (member i '(2 3))) + list))) + (should (equal i 4)) + (should (equal result '(b c))) + (should (equal list '(a b c d))))) + (should (equal '() + (ert--remove-if-not (lambda (x) (should nil)) '())))) + +(ert-deftest ert-test-remove* () + (let ((list (list 'a 'b 'c 'd)) + (key-index 0) + (test-index 0)) + (let ((result + (ert--remove* 'foo list + :key (lambda (x) + (should (eql x (nth key-index list))) + (prog1 + (list key-index x) + (incf key-index))) + :test + (lambda (a b) + (should (eql a 'foo)) + (should (equal b (list test-index + (nth test-index list)))) + (incf test-index) + (member test-index '(2 3)))))) + (should (equal key-index 4)) + (should (equal test-index 4)) + (should (equal result '(a d))) + (should (equal list '(a b c d))))) + (let ((x (cons nil nil)) + (y (cons nil nil))) + (should (equal (ert--remove* x (list x y)) + ;; or (list x), since we use `equal' -- the + ;; important thing is that only one element got + ;; removed, this proves that the default test is + ;; `eql', not `equal' + (list y))))) + + +(ert-deftest ert-test-set-functions () + (let ((c1 (cons nil nil)) + (c2 (cons nil nil)) + (sym (make-symbol "a"))) + (let ((e '()) + (a (list 'a 'b sym nil "" "x" c1 c2)) + (b (list c1 'y 'b sym 'x))) + (should (equal (ert--set-difference e e) e)) + (should (equal (ert--set-difference a e) a)) + (should (equal (ert--set-difference e a) e)) + (should (equal (ert--set-difference a a) e)) + (should (equal (ert--set-difference b e) b)) + (should (equal (ert--set-difference e b) e)) + (should (equal (ert--set-difference b b) e)) + (should (equal (ert--set-difference a b) (list 'a nil "" "x" c2))) + (should (equal (ert--set-difference b a) (list 'y 'x))) + + ;; We aren't testing whether this is really using `eq' rather than `eql'. + (should (equal (ert--set-difference-eq e e) e)) + (should (equal (ert--set-difference-eq a e) a)) + (should (equal (ert--set-difference-eq e a) e)) + (should (equal (ert--set-difference-eq a a) e)) + (should (equal (ert--set-difference-eq b e) b)) + (should (equal (ert--set-difference-eq e b) e)) + (should (equal (ert--set-difference-eq b b) e)) + (should (equal (ert--set-difference-eq a b) (list 'a nil "" "x" c2))) + (should (equal (ert--set-difference-eq b a) (list 'y 'x))) + + (should (equal (ert--union e e) e)) + (should (equal (ert--union a e) a)) + (should (equal (ert--union e a) a)) + (should (equal (ert--union a a) a)) + (should (equal (ert--union b e) b)) + (should (equal (ert--union e b) b)) + (should (equal (ert--union b b) b)) + (should (equal (ert--union a b) (list 'a 'b sym nil "" "x" c1 c2 'y 'x))) + (should (equal (ert--union b a) (list c1 'y 'b sym 'x 'a nil "" "x" c2))) + + (should (equal (ert--intersection e e) e)) + (should (equal (ert--intersection a e) e)) + (should (equal (ert--intersection e a) e)) + (should (equal (ert--intersection a a) a)) + (should (equal (ert--intersection b e) e)) + (should (equal (ert--intersection e b) e)) + (should (equal (ert--intersection b b) b)) + (should (equal (ert--intersection a b) (list 'b sym c1))) + (should (equal (ert--intersection b a) (list c1 'b sym)))))) + +(ert-deftest ert-test-gensym () + ;; Since the expansion of `should' calls `ert--gensym' and thus has a + ;; side-effect on `ert--gensym-counter', we have to make sure all + ;; macros in our test body are expanded before we rebind + ;; `ert--gensym-counter' and run the body. Otherwise, the test would + ;; fail if run interpreted. + (let ((body (byte-compile + '(lambda () + (should (equal (symbol-name (ert--gensym)) "G0")) + (should (equal (symbol-name (ert--gensym)) "G1")) + (should (equal (symbol-name (ert--gensym)) "G2")) + (should (equal (symbol-name (ert--gensym "foo")) "foo3")) + (should (equal (symbol-name (ert--gensym "bar")) "bar4")) + (should (equal ert--gensym-counter 5)))))) + (let ((ert--gensym-counter 0)) + (funcall body)))) + +(ert-deftest ert-test-coerce-to-vector () + (let* ((a (vector)) + (b (vector 1 a 3)) + (c (list)) + (d (list b a))) + (should (eql (ert--coerce-to-vector a) a)) + (should (eql (ert--coerce-to-vector b) b)) + (should (equal (ert--coerce-to-vector c) (vector))) + (should (equal (ert--coerce-to-vector d) (vector b a))))) + +(ert-deftest ert-test-string-position () + (should (eql (ert--string-position ?x "") nil)) + (should (eql (ert--string-position ?a "abc") 0)) + (should (eql (ert--string-position ?b "abc") 1)) + (should (eql (ert--string-position ?c "abc") 2)) + (should (eql (ert--string-position ?d "abc") nil)) + (should (eql (ert--string-position ?A "abc") nil))) + +(ert-deftest ert-test-mismatch () + (should (eql (ert--mismatch "" "") nil)) + (should (eql (ert--mismatch "" "a") 0)) + (should (eql (ert--mismatch "a" "a") nil)) + (should (eql (ert--mismatch "ab" "a") 1)) + (should (eql (ert--mismatch "Aa" "aA") 0)) + (should (eql (ert--mismatch '(a b c) '(a b d)) 2))) + +(ert-deftest ert-test-string-first-line () + (should (equal (ert--string-first-line "") "")) + (should (equal (ert--string-first-line "abc") "abc")) + (should (equal (ert--string-first-line "abc\n") "abc")) + (should (equal (ert--string-first-line "foo\nbar") "foo")) + (should (equal (ert--string-first-line " foo\nbar\nbaz\n") " foo"))) + +(ert-deftest ert-test-explain-not-equal () + (should (equal (ert--explain-not-equal nil 'foo) + '(different-atoms nil foo))) + (should (equal (ert--explain-not-equal '(a a) '(a b)) + '(list-elt 1 (different-atoms a b)))) + (should (equal (ert--explain-not-equal '(1 48) '(1 49)) + '(list-elt 1 (different-atoms (48 "#x30" "?0") + (49 "#x31" "?1"))))) + (should (equal (ert--explain-not-equal 'nil '(a)) + '(different-types nil (a)))) + (should (equal (ert--explain-not-equal '(a b c) '(a b c d)) + '(proper-lists-of-different-length 3 4 (a b c) (a b c d) + first-mismatch-at 3))) + (let ((sym (make-symbol "a"))) + (should (equal (ert--explain-not-equal 'a sym) + `(different-symbols-with-the-same-name a ,sym))))) + +(ert-deftest ert-test-explain-not-equal-improper-list () + (should (equal (ert--explain-not-equal '(a . b) '(a . c)) + '(cdr (different-atoms b c))))) + +(ert-deftest ert-test-significant-plist-keys () + (should (equal (ert--significant-plist-keys '()) '())) + (should (equal (ert--significant-plist-keys '(a b c d e f c g p q r nil s t)) + '(a c e p s)))) + +(ert-deftest ert-test-plist-difference-explanation () + (should (equal (ert--plist-difference-explanation + '(a b c nil) '(a b)) + nil)) + (should (equal (ert--plist-difference-explanation + '(a b c t) '(a b)) + '(different-properties-for-key c (different-atoms t nil)))) + (should (equal (ert--plist-difference-explanation + '(a b c t) '(c nil a b)) + '(different-properties-for-key c (different-atoms t nil)))) + (should (equal (ert--plist-difference-explanation + '(a b c (foo . bar)) '(c (foo . baz) a b)) + '(different-properties-for-key c + (cdr + (different-atoms bar baz)))))) + +(ert-deftest ert-test-abbreviate-string () + (should (equal (ert--abbreviate-string "foo" 4 nil) "foo")) + (should (equal (ert--abbreviate-string "foo" 3 nil) "foo")) + (should (equal (ert--abbreviate-string "foo" 3 nil) "foo")) + (should (equal (ert--abbreviate-string "foo" 2 nil) "fo")) + (should (equal (ert--abbreviate-string "foo" 1 nil) "f")) + (should (equal (ert--abbreviate-string "foo" 0 nil) "")) + (should (equal (ert--abbreviate-string "bar" 4 t) "bar")) + (should (equal (ert--abbreviate-string "bar" 3 t) "bar")) + (should (equal (ert--abbreviate-string "bar" 3 t) "bar")) + (should (equal (ert--abbreviate-string "bar" 2 t) "ar")) + (should (equal (ert--abbreviate-string "bar" 1 t) "r")) + (should (equal (ert--abbreviate-string "bar" 0 t) ""))) + +(ert-deftest ert-test-explain-not-equal-string-properties () + (should + (equal (ert--explain-not-equal-including-properties #("foo" 0 1 (a b)) + "foo") + '(char 0 "f" + (different-properties-for-key a (different-atoms b nil)) + context-before "" + context-after "oo"))) + (should (equal (ert--explain-not-equal-including-properties + #("foo" 1 3 (a b)) + #("goo" 0 1 (c d))) + '(array-elt 0 (different-atoms (?f "#x66" "?f") + (?g "#x67" "?g"))))) + (should + (equal (ert--explain-not-equal-including-properties + #("foo" 0 1 (a b c d) 1 3 (a b)) + #("foo" 0 1 (c d a b) 1 2 (a foo))) + '(char 1 "o" (different-properties-for-key a (different-atoms b foo)) + context-before "f" context-after "o")))) + +(ert-deftest ert-test-equal-including-properties () + (should (equal-including-properties "foo" "foo")) + (should (ert-equal-including-properties "foo" "foo")) + + (should (equal-including-properties #("foo" 0 3 (a b)) + (propertize "foo" 'a 'b))) + (should (ert-equal-including-properties #("foo" 0 3 (a b)) + (propertize "foo" 'a 'b))) + + (should (equal-including-properties #("foo" 0 3 (a b c d)) + (propertize "foo" 'a 'b 'c 'd))) + (should (ert-equal-including-properties #("foo" 0 3 (a b c d)) + (propertize "foo" 'a 'b 'c 'd))) + + (should-not (equal-including-properties #("foo" 0 3 (a b c e)) + (propertize "foo" 'a 'b 'c 'd))) + (should-not (ert-equal-including-properties #("foo" 0 3 (a b c e)) + (propertize "foo" 'a 'b 'c 'd))) + + ;; This is bug 6581. + (should-not (equal-including-properties #("foo" 0 3 (a (t))) + (propertize "foo" 'a (list t)))) + (should (ert-equal-including-properties #("foo" 0 3 (a (t))) + (propertize "foo" 'a (list t))))) + +(ert-deftest ert-test-stats-set-test-and-result () + (let* ((test-1 (make-ert-test :name 'test-1 + :body (lambda () nil))) + (test-2 (make-ert-test :name 'test-2 + :body (lambda () nil))) + (test-3 (make-ert-test :name 'test-2 + :body (lambda () nil))) + (stats (ert--make-stats (list test-1 test-2) 't)) + (failed (make-ert-test-failed :condition nil + :backtrace nil + :infos nil))) + (should (eql 2 (ert-stats-total stats))) + (should (eql 0 (ert-stats-completed stats))) + (should (eql 0 (ert-stats-completed-expected stats))) + (should (eql 0 (ert-stats-completed-unexpected stats))) + (ert--stats-set-test-and-result stats 0 test-1 (make-ert-test-passed)) + (should (eql 2 (ert-stats-total stats))) + (should (eql 1 (ert-stats-completed stats))) + (should (eql 1 (ert-stats-completed-expected stats))) + (should (eql 0 (ert-stats-completed-unexpected stats))) + (ert--stats-set-test-and-result stats 0 test-1 failed) + (should (eql 2 (ert-stats-total stats))) + (should (eql 1 (ert-stats-completed stats))) + (should (eql 0 (ert-stats-completed-expected stats))) + (should (eql 1 (ert-stats-completed-unexpected stats))) + (ert--stats-set-test-and-result stats 0 test-1 nil) + (should (eql 2 (ert-stats-total stats))) + (should (eql 0 (ert-stats-completed stats))) + (should (eql 0 (ert-stats-completed-expected stats))) + (should (eql 0 (ert-stats-completed-unexpected stats))) + (ert--stats-set-test-and-result stats 0 test-3 failed) + (should (eql 2 (ert-stats-total stats))) + (should (eql 1 (ert-stats-completed stats))) + (should (eql 0 (ert-stats-completed-expected stats))) + (should (eql 1 (ert-stats-completed-unexpected stats))) + (ert--stats-set-test-and-result stats 1 test-2 (make-ert-test-passed)) + (should (eql 2 (ert-stats-total stats))) + (should (eql 2 (ert-stats-completed stats))) + (should (eql 1 (ert-stats-completed-expected stats))) + (should (eql 1 (ert-stats-completed-unexpected stats))) + (ert--stats-set-test-and-result stats 0 test-1 (make-ert-test-passed)) + (should (eql 2 (ert-stats-total stats))) + (should (eql 2 (ert-stats-completed stats))) + (should (eql 2 (ert-stats-completed-expected stats))) + (should (eql 0 (ert-stats-completed-unexpected stats))))) + + +(provide 'ert-tests) + +;;; ert-tests.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/test/automated/ert-x-tests.el Thu Jan 13 09:17:33 2011 -0800 @@ -0,0 +1,273 @@ +;;; ert-x-tests.el --- Tests for ert-x.el + +;; Copyright (C) 2008, 2010, 2011 Free Software Foundation, Inc. + +;; Author: Phil Hagelberg +;; Author: Christian Ohler <ohler@gnu.org> + +;; This file is part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `http://www.gnu.org/licenses/'. + +;;; Commentary: + +;; This file is part of ERT, the Emacs Lisp Regression Testing tool. +;; See ert.el or the texinfo manual for more details. + +;;; Code: + +(eval-when-compile + (require 'cl)) +(require 'ert) +(require 'ert-x) + +;;; Utilities + +(ert-deftest ert-test-buffer-string-reindented () + (ert-with-test-buffer (:name "well-indented") + (insert (concat "(hello (world\n" + " 'elisp)\n")) + (emacs-lisp-mode) + (should (equal (ert-buffer-string-reindented) (buffer-string)))) + (ert-with-test-buffer (:name "badly-indented") + (insert (concat "(hello\n" + " world)")) + (emacs-lisp-mode) + (should-not (equal (ert-buffer-string-reindented) (buffer-string))))) + +(defun ert--hash-table-to-alist (table) + (let ((accu nil)) + (maphash (lambda (key value) + (push (cons key value) accu)) + table) + (nreverse accu))) + +(ert-deftest ert-test-test-buffers () + (let (buffer-1 + buffer-2) + (let ((test-1 + (make-ert-test + :name 'test-1 + :body (lambda () + (ert-with-test-buffer (:name "foo") + (should (string-match + "[*]Test buffer (ert-test-test-buffers): foo[*]" + (buffer-name))) + (setq buffer-1 (current-buffer)))))) + (test-2 + (make-ert-test + :name 'test-2 + :body (lambda () + (ert-with-test-buffer (:name "bar") + (should (string-match + "[*]Test buffer (ert-test-test-buffers): bar[*]" + (buffer-name))) + (setq buffer-2 (current-buffer)) + (ert-fail "fail for test")))))) + (let ((ert--test-buffers (make-hash-table :weakness t))) + (ert-run-tests `(member ,test-1 ,test-2) #'ignore) + (should (equal (ert--hash-table-to-alist ert--test-buffers) + `((,buffer-2 . t)))) + (should-not (buffer-live-p buffer-1)) + (should (buffer-live-p buffer-2)))))) + + +(ert-deftest ert-filter-string () + (should (equal (ert-filter-string "foo bar baz" "quux") + "foo bar baz")) + (should (equal (ert-filter-string "foo bar baz" "bar") + "foo baz"))) + +(ert-deftest ert-propertized-string () + (should (ert-equal-including-properties + (ert-propertized-string "a" '(a b) "b" '(c t) "cd") + #("abcd" 1 2 (a b) 2 4 (c t)))) + (should (ert-equal-including-properties + (ert-propertized-string "foo " '(face italic) "bar" " baz" nil + " quux") + #("foo bar baz quux" 4 11 (face italic))))) + + +;;; Tests for ERT itself that require test features from ert-x.el. + +(ert-deftest ert-test-run-tests-interactively-2 () + :tags '(:causes-redisplay) + (let ((passing-test (make-ert-test :name 'passing-test + :body (lambda () (ert-pass)))) + (failing-test (make-ert-test :name 'failing-test + :body (lambda () + (ert-info ((propertize "foo\nbar" + 'a 'b)) + (ert-fail + "failure message")))))) + (let ((ert-debug-on-error nil)) + (let* ((buffer-name (generate-new-buffer-name "*ert-test-run-tests*")) + (messages nil) + (mock-message-fn + (lambda (format-string &rest args) + (push (apply #'format format-string args) messages)))) + (flet ((expected-string (with-font-lock-p) + (ert-propertized-string + "Selector: (member <passing-test> <failing-test>)\n" + "Passed: 1\n" + "Failed: 1 (1 unexpected)\n" + "Total: 2/2\n\n" + "Started at:\n" + "Finished.\n" + "Finished at:\n\n" + `(category ,(button-category-symbol + 'ert--results-progress-bar-button) + button (t) + face ,(if with-font-lock-p + 'ert-test-result-unexpected + 'button)) + ".F" nil "\n\n" + `(category ,(button-category-symbol + 'ert--results-expand-collapse-button) + button (t) + face ,(if with-font-lock-p + 'ert-test-result-unexpected + 'button)) + "F" nil " " + `(category ,(button-category-symbol + 'ert--test-name-button) + button (t) + ert-test-name failing-test) + "failing-test" + nil "\n Info: " '(a b) "foo\n" + nil " " '(a b) "bar" + nil "\n (ert-test-failed \"failure message\")\n\n\n" + ))) + (save-window-excursion + (unwind-protect + (let ((case-fold-search nil)) + (ert-run-tests-interactively + `(member ,passing-test ,failing-test) buffer-name + mock-message-fn) + (should (equal messages `(,(concat + "Ran 2 tests, 1 results were " + "as expected, 1 unexpected")))) + (with-current-buffer buffer-name + (font-lock-mode 0) + (should (ert-equal-including-properties + (ert-filter-string (buffer-string) + '("Started at:\\(.*\\)$" 1) + '("Finished at:\\(.*\\)$" 1)) + (expected-string nil))) + ;; `font-lock-mode' only works if interactive, so + ;; pretend we are. + (let ((noninteractive nil)) + (font-lock-mode 1)) + (should (ert-equal-including-properties + (ert-filter-string (buffer-string) + '("Started at:\\(.*\\)$" 1) + '("Finished at:\\(.*\\)$" 1)) + (expected-string t))))) + (when (get-buffer buffer-name) + (kill-buffer buffer-name))))))))) + +(ert-deftest ert-test-describe-test () + "Tests `ert-describe-test'." + (save-window-excursion + (ert-with-buffer-renamed ("*Help*") + (if (< emacs-major-version 24) + (should (equal (should-error (ert-describe-test 'ert-describe-test)) + '(error "Requires Emacs 24"))) + (ert-describe-test 'ert-test-describe-test) + (with-current-buffer "*Help*" + (let ((case-fold-search nil)) + (should (string-match (concat + "\\`ert-test-describe-test is a test" + " defined in `ert-x-tests.elc?'\\.\n\n" + "Tests `ert-describe-test'\\.\n\\'") + (buffer-string))))))))) + +(ert-deftest ert-test-message-log-truncation () + :tags '(:causes-redisplay) + (let ((test (make-ert-test + :body (lambda () + ;; Emacs would combine messages if we + ;; generate the same message multiple + ;; times. + (message "a") + (message "b") + (message "c") + (message "d"))))) + (let (result) + (ert-with-buffer-renamed ("*Messages*") + (let ((message-log-max 2)) + (setq result (ert-run-test test))) + (should (equal (with-current-buffer "*Messages*" + (buffer-string)) + "c\nd\n"))) + (should (equal (ert-test-result-messages result) "a\nb\nc\nd\n"))))) + +(ert-deftest ert-test-builtin-message-log-flushing () + "This test attempts to demonstrate that there is no way to +force immediate truncation of the *Messages* buffer from Lisp +\(and hence justifies the existence of +`ert--force-message-log-buffer-truncation'\): The only way that +came to my mind was \(message \"\"\), which doesn't have the +desired effect." + :tags '(:causes-redisplay) + (ert-with-buffer-renamed ("*Messages*") + (with-current-buffer "*Messages*" + (should (equal (buffer-string) "")) + ;; We used to get sporadic failures in this test that involved + ;; a spurious newline at the beginning of the buffer, before + ;; the first message. Below, we print a message and erase the + ;; buffer since this seems to eliminate the sporadic failures. + (message "foo") + (erase-buffer) + (should (equal (buffer-string) "")) + (let ((message-log-max 2)) + (let ((message-log-max t)) + (loop for i below 4 do + (message "%s" i)) + (should (equal (buffer-string) "0\n1\n2\n3\n"))) + (should (equal (buffer-string) "0\n1\n2\n3\n")) + (message "") + (should (equal (buffer-string) "0\n1\n2\n3\n")) + (message "Test message") + (should (equal (buffer-string) "3\nTest message\n")))))) + +(ert-deftest ert-test-force-message-log-buffer-truncation () + :tags '(:causes-redisplay) + (labels ((body () + (loop for i below 3 do + (message "%s" i))) + ;; Uses the implicit messages buffer truncation implemented + ;; in Emacs' C core. + (c (x) + (ert-with-buffer-renamed ("*Messages*") + (let ((message-log-max x)) + (body)) + (with-current-buffer "*Messages*" + (buffer-string)))) + ;; Uses our lisp reimplementation. + (lisp (x) + (ert-with-buffer-renamed ("*Messages*") + (let ((message-log-max t)) + (body)) + (let ((message-log-max x)) + (ert--force-message-log-buffer-truncation)) + (with-current-buffer "*Messages*" + (buffer-string))))) + (loop for x in '(0 1 2 3 4 t) do + (should (equal (c x) (lisp x)))))) + + +(provide 'ert-x-tests) + +;;; ert-x-tests.el ends here