diff options
Diffstat (limited to 'emacs.d/nxhtml/tests/ert.el')
| -rw-r--r-- | emacs.d/nxhtml/tests/ert.el | 2418 |
1 files changed, 0 insertions, 2418 deletions
diff --git a/emacs.d/nxhtml/tests/ert.el b/emacs.d/nxhtml/tests/ert.el deleted file mode 100644 index 491d79f..0000000 --- a/emacs.d/nxhtml/tests/ert.el +++ /dev/null @@ -1,2418 +0,0 @@ -;;; ert.el --- Emacs Lisp Regression Testing - -;; Modified by Lennart Borgman 2008-07-13 to make all global symbols -;; use the "ert-" prefix. - -;; Copyright (C) 2007, 2008 Christian M. Ohler - -;; Author: Christian M. Ohler -;; Version: 0.2 -;; Keywords: lisp, tools - -;; This file is NOT 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' 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. -;; -;; For example, -;; -;; ;; Define a test named `foo'. -;; (ert-deftest foo () -;; (ert-should (= (+ 1 2) 4))) -;; -;; ;; Run it. -;; (ert-run-tests-interactively 'foo) -;; -;; generates the following output (in addition to some statistics) in -;; the *ert* results buffer: -;; -;; F foo -;; (ert-test-failed -;; ((ert-should -;; (= -;; (+ 1 2) -;; 4)) -;; :form -;; (= 3 4) -;; :value nil)) -;; -;; This indicates that the test failed. The `should' form that failed -;; was (ert-should (= (+ 1 2) 4)), because its inner form, after -;; evaluation of its arguments, was the function call (= 3 4), which -;; returned nil. -;; -;; Obviously, this is a bug in the test case, not in the functions `+' -;; or `='. In the results buffer, with point on the test result, the -;; key "." can be used to jump to the definition of the test to modify -;; it to correct the bug. After evaluating the modified definition -;; and switching back to the results buffer, the key "r" will re-run -;; the test and show the new result. - - -;; Test selectors -;; -;; Functions like `ert-run-tests-interactively' accept a test -;; selector, which is a Lisp expression specifying a set of tests. -;; Each test name is a selector that refers to that test, the selector -;; `t' refers to all tests, and the selector `:failed' refers to all -;; tests that failed; but more complex selectors are available. Test -;; selector syntax is similar to cl's type specifier syntax. See the -;; docstring of `ert-select-tests' for details. - - -;; Comparison with other testing tools -;; -;; ERT allows test-driven development similar to *Unit frameworks for -;; other languages. However, two common *Unit features are notably -;; absent from ERT: fixtures and test suites. -;; -;; Fixtures, as used e.g. in SUnit or JUnit, have two main purposes: -;; Setting up (and tearing down) an environment for a set of test -;; cases, and making that environment accessible through object -;; attributes that can be used like local variables. -;; -;; While fixtures are a great syntactic simplification in other -;; languages, they are not very useful in Lisp, where higher-order -;; functions and `unwind-protect' are available. One way to implement -;; and use a fixture in ERT is -;; -;; (defun my-fixture (body) -;; (unwind-protect -;; (progn ...set up... -;; (funcall body)) -;; ...tear down...)) -;; -;; (ert-deftest my-test () -;; (my-fixture -;; (lambda () -;; ...test code...))) -;; -;; (Another way would be a `with-my-fixture' macro.) This solves the -;; set-up and tear-down part, and additionally allows any test case to -;; use any combination of fixtures, so it is more general than what -;; other tools typically allow. -;; -;; If the test case needs access to the environment the fixture sets -;; up, the fixture can be modified to pass arguments to the body. -;; -;; These are standard Lisp idioms. Special syntax for them could be -;; added easily enough, but would provide only a minor simplification. -;; -;; (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 test cases 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. -;; -;; If test suites containing arbitrary sets of tests are found to be -;; desirable, it would be easy to add a `define-test-selector' -;; mechanism that introduces a new selector, defined in terms of -;; existing ones; e.g. -;; -;; ;; Note that `define-test-selector' does not exist yet. -;; (define-test-selector my-test-suite () `(member foo-test bar-test)) -;; -;; would define a test suite named `my-test-suite' consisting of -;; `foo-test' and `bar-test'. See also `deftype' in Common Lisp. - - -;; TODO: Add `skip' feature for tests that can't run in current environment. - - -;;; Code: - -(eval-when-compile (require 'cl)) -(require 'ewoc) -(require 'find-func) -(require 'debug) - -(defvar ert-debug-on-error nil - "Non-nil means enter debugger when a test fails or terminates with an error.") - - -;;; 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 'ert-test-passed)) - -(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." - (assert (ert-test-boundp symbol) t) - (get symbol 'ert-test)) - -(defun ert-set-test (symbol doc definition) - "Make SYMBOL name the test DEFINITION, and return DEFINITION." - (when doc - (put symbol 'ert-test-documentation doc)) - (put symbol 'ert-test definition) - definition) - -(defun ert-make-test-unbound (symbol) - "Make SYMBOL name no test. Return SYMBOL." - (remprop symbol 'ert-test) - symbol) - -(defun ert-test-result-expected-p (test result) - "Return non-nil if RESULT matches the expected result type for TEST." - (typep result (ert-test-expected-result-type test))) - -(defvar ert-find-test-regexp - (concat "^\\s-*(ert-deftest" - find-function-space-re - "%s\\(\\s-\\|$\\)") - "The regexp the `find-function' mechanisms use for locating test definitions.") - -(eval-and-compile - (defun ert-parse-keys-and-body (docstr 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." - (unless (stringp docstr) - (when docstr - (setq keys-and-body (cons docstr keys-and-body)) - (setq docstr nil))) - (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) - docstr - remaining)))) - -(defvar ert-error-on-test-redefinition nil) - -;;;###autoload -(defmacro* ert-deftest (name () - &optional docstr - &body keys-and-body) - "Define NAME (a symbol) as a test. - -\(fn NAME () [:documentation DOCSTRING] [:expected-result TYPE] BODY...)" - ;; The :documentation would be unreadable. I have therefore added - ;; docstr that will look like documentation use to in Emacs. Maybe - ;; add function ert-describe-test? - (declare (indent 2) - (debug (&define :name test name sexp - [&optional [":documentation" stringp]] - [&optional [":expected-result" sexp]] - def-body))) - (destructuring-bind ((&key (expected-result nil expected-result-supplied-p) - (documentation nil documentation-supplied-p)) - doc - body) - (ert-parse-keys-and-body docstr keys-and-body) - `(progn - ;; Guard against missing/badly named tests: - (when (and ert-error-on-test-redefinition - (symbolp ',name) - (get ',name 'ert-test)) - (with-output-to-temp-buffer "*Ert Error*" - (with-current-buffer "*Ert Error*" - (insert "Test " - (format "%s" ',name) - " is already defined in " - (format "%s" (find-definition-noselect ',name 'ert-deftest)) - "\n\n" - "Tip: Use `ert-delete-all-tests' or `ert-delete-test' before redefining tests." - ))) - (if (y-or-n-p "Do you want to call ert-delete-all-tests and then continue? ") - ;; Fix-me: This does not work, why? - (ert-delete-all-tests) - (error "Test %s is already defined in %s" - ',name - (find-definition-noselect ',name 'ert-deftest)))) - (ert-set-test ',name - nil ;;doc - (make-ert-test - :name ',name - :body (lambda () ,@body) - ,@(when expected-result-supplied-p - `(:expected-result-type ,expected-result)) - ,@(when documentation-supplied-p - `(:documentation ,documentation)))) - ;; 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))) - -(defun ert-read-test-name (prompt &optional default-value history) - "Read the name of a test and return it as a symbol. -Prompt with PROMPT. By default, return DEFAULT-VALUE." - (when (symbolp default-value) (setq default-value (symbol-name default-value))) - (intern (completing-read prompt obarray #'ert-test-boundp - t nil history default-value nil))) - -(defun ert-find-test-other-window (test-name) - "Find, in another window, the definition of TEST-NAME." - (interactive (list (ert-read-test-name "Find test definition: "))) - (find-function-do-it test-name 'ert-deftest 'switch-to-buffer-other-window)) - -(defun ert-delete-test (test-name) - "An interactive interface to `ert-make-test-unbound'." - (interactive (list (let ((default (thing-at-point 'symbol))) - (when default - (set-text-properties 0 (length default) nil default) - (when (or (string= default "nil") (intern-soft default)) - (setq default (intern default))) - (unless (ert-test-boundp default) - (setq default nil))) - (completing-read (if (null default) - "Delete test: " - (format "Delete test (default %s): " - default)) - obarray #'ert-test-boundp - 'really-require-match - nil nil default nil)))) - (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"))) - (mapc #'ert-delete-test (mapcar #'ert-test-name (ert-select-tests t t))) - t) - - -(defun ert-make-end-marker (buffer must-exist) - "Return a marker to the end of buffer BUFFER. -BUFFER may be a string or a buffer. If BUFFER does not exist -return nil. - -The buffer must exist if MUST-EXIST is non-nil. - -See also: - `ert-end-of-messages' - `ert-end-of-warnings'" - (let ((buf (if must-exist - (get-buffer buffer) - (get-buffer-create buffer)))) - (when (and buf - (bufferp buf) - (buffer-live-p buf)) - (with-current-buffer buf - (save-restriction - (widen) - (point-max-marker)))))) - -(defun ert-end-of-messages () - "Return a marker to the end of *Messages* buffer." - (ert-make-end-marker "*Messages*" nil)) - -(defun ert-end-of-warnings () - "Return a marker to the end of *Warnings* buffer." - (ert-make-end-marker "*Warnings*" nil)) - -(defun ert-search-after (after regexp) - "Search after marker in AFTER for regular expression REGEXP. -Return a alist of position and matches. AFTER should have been -created with `ert-make-end-marker'. - -This is supposed to be used for messages and trace buffers. - -See also - `ert-get-messages'" - (let ((buf (marker-buffer after))) - (with-current-buffer buf - (let ((here (point)) - res) - (goto-char after) - (save-match-data - (while (re-search-forward regexp nil t) - (setq res (cons (match-data) res)))) - (goto-char here) - (reverse res))))) -;; fix-me: add a conventient way to look at the result of -;; `ert-search-after'. Probably this means adding something more to -;; the returned result. - -(defvar ert-messages-mark) -(defun ert-get-messages (regexp) - "Search *Messages* buffer for regular expression REGEXP. -This should be used within `ert-deftest'. Search begins where -the buffer ended when test started. - -See also: - `ert-get-warnings' - `ert-search-after'" - (ert-search-after ert-messages-mark regexp)) - -(defvar ert-warnings-mark) -(defun ert-get-warnings (regexp) - "Search *Warnings* buffer for regular expression REGEXP. -See `ert-get-messages' for more information." - (ert-search-after ert-warnings-mark regexp)) - - -;;; Test selectors. - -(defun ert-select-tests (selector universe) - "Select, from UNIVERSE, a set of tests according to SELECTOR. - -UNIVERSE 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, :error -- 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. -\(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) - (typep (ert-test-most-recent-result test) - 'null))) - universe)) - ((member :failed) (ert-select-tests - `(satisfies ,(lambda (test) - (typep (ert-test-most-recent-result test) - 'ert-test-failed))) - universe)) - ((member :passed) (ert-select-tests - `(satisfies ,(lambda (test) - (typep (ert-test-most-recent-result test) - 'ert-test-passed))) - universe)) - ((member :error) (ert-select-tests - `(satisfies ,(lambda (test) - (typep (ert-test-most-recent-result test) - 'ert-test-error))) - 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 (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 rules? 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)) - (set-difference (ert-select-tests 't universe) - (ert-select-tests (first operands) universe))) - (or - (case (length operands) - (0 (ert-select-tests 'nil universe)) - (t (union (ert-select-tests (first operands) universe) - (ert-select-tests `(or ,@(rest operands)) universe))))) - (satisfies - (assert (eql (length operands) 1)) - (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 :error - :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))) - (satisfies - selector))))))) - (insert (format "%S" (rec selector))))) - - -;;; Running tests. - -(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 data structures that represent the result of running a test. -(defstruct ert-test-result - (messages 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))) -(defstruct (ert-test-error (:include ert-test-result-with-condition))) -(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)) - -;; 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) - "The function that `debugger' is bound to during the execution of tests. - -Records failures and errors and either terminates the test -silently or calls the interactive debugger, as appropriate." - (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) - ((ert-test-failed) 'failed) - (otherwise 'error))) - (backtrace (ert-record-backtrace))) - (setf (ert-test-execution-info-result info) - (ecase type - (quit - (make-ert-test-quit :condition condition - :backtrace backtrace)) - (failed - (make-ert-test-failed :condition condition - :backtrace backtrace)) - (error - (make-ert-test-error :condition condition - :backtrace backtrace)))) - ;; 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) - (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-messages-mark (ert-end-of-messages)) - (ert-warnings-mark (ert-end-of-warnings))) - (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-make-marker-in-messages-buffer () - (with-current-buffer (get-buffer-create "*Messages*") - (set-marker (make-marker) (point-max)))) - -(defun ert-force-message-log-buffer-truncation () - (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))))) - -(defun ert-run-test (test) - "Run TEST. Return the result and store it in TEST's `most-recent-result' slot." - (setf (ert-test-most-recent-result test) nil) - (block error - (lexical-let* ((begin-marker (ert-make-marker-in-messages-buffer)) - (info (make-ert-test-execution-info - :test test - :result (make-ert-test-aborted-with-non-local-exit) - :exit-continuation (lambda () - (return-from error nil))))) - (unwind-protect - (let ((message-log-max t)) - (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) - (setf (ert-test-most-recent-result test) result))))) - (ert-test-most-recent-result test)) - - -;;; The `should' macros. - -(eval-and-compile - (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 (whole form env inner-expander) - "Helper function for the `should' macro and its variants. - -Analyzes FORM and produces an expression that has the same -semantics under evaluation but records additional debugging -information. INNER-EXPANDER adds the actual checks specific to -the particular variant of `should'." - (let ((form (macroexpand form env))) - ;; It's sort of a wart that `inner-expander' can't influence the - ;; value the expansion returns. - (cond - ((atom form) - (funcall inner-expander form `(list ',whole :form ',form :value ,form))) - ((ert-special-operator-p (car form)) - (let ((value (gensym "value-"))) - `(let ((,value (make-symbol "ert-form-evaluation-aborted"))) - ,(funcall inner-expander - `(setq ,value ,form) - `(list ',whole :form ',form :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 (gensym "fn-")) - (args (gensym "args-")) - (value (gensym "value-")) - (default-value (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))))))))) - -(defmacro* ert-should (form &environment env) - "Evaluate FORM. If it returns nil, abort the current test as failed. - -Returns the value of FORM." - (ert-expand-should `(ert-should ,form) form env - (lambda (inner-form form-description-form) - `(unless ,inner-form - (ert-fail ,form-description-form))))) - -(defmacro* ert-should-not (form &environment env) - "Evaluate FORM. If it returns non-nil, abort the current test as failed. - -Returns nil." - (ert-expand-should `(ert-should-not ,form) form env - (lambda (inner-form form-description-form) - `(unless (not ,inner-form) - (ert-fail ,form-description-form))))) - -(defun ert-should-error-handle-error (form-description-fn - condition type exclude-subtypes test) - "Helper function for `should-error'. - -Determines whether CONDITION matches TYPE, EXCLUDE-SUBTYPES and -TEST, 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 (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")))))) - (unless (funcall test condition) - (ert-fail (append - (funcall form-description-fn) - (list - :condition condition - :fail-reason "the error signalled did not pass the test")))))) - -;; FIXME: The expansion will evaluate the keyword args (if any) in -;; nonstandard order. -(defmacro* ert-should-error (form &rest keys &key type exclude-subtypes test - &environment env) - "Evaluate FORM. Unless it signals an error, abort the current test as failed. - -The error signalled additionally needs to match TYPE and satisfy -TEST. TYPE should be a condition name or a list of condition -names. 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. TEST should be a predicate." - ;; Returns a gensym named `ert-form-evaluation-aborted-XXX', but - ;; that's a wart, so let's not document it. - (unless type (setq type ''error)) - (unless test (setq test '(lambda (condition) t))) - (ert-expand-should - `(ert-should-error ,form ,@keys) - form env - (lambda (inner-form form-description-form) - (let ((errorp (gensym "errorp")) - (form-description-fn (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 ,test) - ;; It would make sense to have the `should-error' form - ;; return the error in this case, but `ert-expand-should' - ;; doesn't allow that at the moment. - )) - (unless ,errorp - (ert-fail (append - (funcall ,form-description-fn) - (list - :fail-reason "did not signal an error"))))))))) - - -;;; Explanation of `should' failures. - -(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-not-equal (a b) - "Return a programmer-readable explanation of why A and B are not `equal'. - -Returns nil if they are equal." - (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))) - ;; This would be even more helpful if it showed - ;; something like what `set-difference' would - ;; return. - `(proper-lists-of-different-length ,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))))) - (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)) - nil))))))) - (array (if (not (equal (length a) (length b))) - `(arrays-of-different-length ,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)))))) - (atom (if (not (equal a b)) - `(different-atoms ,a ,b) - nil))))) -(put 'equal 'ert-explainer 'ert-explain-not-equal) - - -;;; Results display. - -;; 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 expected result types of the tests, in order. - (test-results-expected (assert nil) :type vector) - (total (assert nil)) - (passed-expected 0) - (passed-unexpected 0) - (failed-expected 0) - (failed-unexpected 0) - (error-expected 0) - (error-unexpected 0) - (start-time (assert nil)) - (end-time nil) - (aborted-p nil) - (current-test nil)) - -;; An entry in the results buffer ewoc. There is one entry per test. -(defstruct ert-ewoc-entry - (test (assert nil)) - (result 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) - -;; The same as `ert-results-stats', but dynamically bound. Used for -;; the mode line progress indicator. -(defvar ert-current-run-stats nil) - -(defun ert-format-time-iso8601 (time) - "Format TIME in the particular variant of ISO 8601 used for timestamps in ERT." - (format-time-string "%Y-%m-%d %T%z" time)) - -(defun ert-insert-test-name-button (test-name) - (insert-text-button (format "%S" test-name) - :type 'ert-test-name-button - 'ert-test-name test-name)) - -(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-passed-expected stats) - (ert-stats-passed-unexpected stats) - (ert-stats-failed-expected stats) - (ert-stats-failed-unexpected stats) - (ert-stats-error-expected stats) - (ert-stats-error-unexpected stats))) - (results-buffer (current-buffer))) - (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 (%s unexpected)\n" - "Failed: %s (%s unexpected)\n" - "Error: %s (%s unexpected)\n" - "Total: %s/%s\n\n") - (+ (ert-stats-passed-expected stats) - (ert-stats-passed-unexpected stats)) - (ert-stats-passed-unexpected stats) - (+ (ert-stats-failed-expected stats) - (ert-stats-failed-unexpected stats)) - (ert-stats-failed-unexpected stats) - (+ (ert-stats-error-expected stats) - (ert-stats-error-unexpected stats)) - (ert-stats-error-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 (substring progress-bar-string 0 run-count) - :type 'ert-results-progress-bar-button))) - (with-current-buffer results-buffer - (set (make-local-variable 'ert-results-progress-bar-button-begin) - progress-bar-button-begin))) - (insert (substring progress-bar-string run-count))) - (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. - "\n"))) - -(defun ert-results-update-stats-display (ewoc stats) - "Update EWOC and the mode line to show data from STATS." - (ert-results-update-ewoc-hf ewoc stats) - (force-mode-line-update) - (redisplay t)) - -(defun ert-char-for-test-result (result expectedp) - "Return a character that represents the test result RESULT." - (let ((char - (etypecase result - (ert-test-passed ?.) - (ert-test-failed ?f) - (ert-test-error ?e) - (null ?-) - (ert-test-aborted-with-non-local-exit ?a)))) - (if expectedp - char - (upcase char)))) - -(defun ert-string-for-test-result (result expectedp) - "Return a string that represents the test result RESULT." - (etypecase result - (ert-test-passed "passed") - (ert-test-failed "failed") - (ert-test-error "error") - (null "unknown") - (ert-test-aborted-with-non-local-exit "aborted"))) - -(defun ert-tests-running-mode-line-indicator () - (let* ((stats ert-current-run-stats) - (tests-total (ert-stats-total stats)) - (tests-completed (+ (ert-stats-passed-expected stats) - (ert-stats-passed-unexpected stats) - (ert-stats-failed-expected stats) - (ert-stats-failed-unexpected stats) - (ert-stats-error-expected stats) - (ert-stats-error-unexpected 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-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-print-test-for-ewoc (entry) - "The ewoc print function for ewoc test entries." - (let* ((test (ert-ewoc-entry-test entry)) - (result (ert-ewoc-entry-result entry)) - (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 - (insert-text-button (format "%c" - (ert-char-for-test-result - result - (ert-test-result-expected-p test - result))) - :type 'ert-results-expand-collapse-button) - (insert " ") - (ert-insert-test-name-button (ert-test-name test)) - (insert "\n") - (when (and expandedp (not (eql result 'nil))) - (etypecase result - (ert-test-passed - (insert " passed\n") - (insert "")) - (ert-test-result-with-condition - (insert " ") - (let ((print-escape-newlines t) - (print-level (if extended-printer-limits-p 10 5)) - (print-length (if extended-printer-limits-p 100 10))) - (let ((begin (point))) - (ert-pp-with-indentation-and-newline - (ert-test-result-with-condition-condition result)) - (save-restriction - (narrow-to-region begin (point)) - ;; Inhibit optimization in `debugger-make-xrefs' - ;; that sometimes inserts unrelated backtrace - ;; info into our buffer. - (let ((debugger-previous-backtrace nil)) - (debugger-make-xrefs)))))) - (ert-test-aborted-with-non-local-exit - (insert " aborted\n"))) - (insert "\n"))))) - nil) - -(defun ert-setup-results-buffer (stats listener buffer-name) - "Set up a test results buffer." - (unless buffer-name (setq buffer-name "*ert*")) - (let ((buffer (let ((default-major-mode 'fundamental-mode)) - (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) - (set (make-local-variable 'ert-results-ewoc) - (ewoc-create 'ert-print-test-for-ewoc nil nil t)) - (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) - (ert-results-update-ewoc-hf ert-results-ewoc ert-results-stats) - (goto-char (1- (point-max))) - buffer)))) - -(defun ert-run-or-rerun-test (stats test listener) - "Run the single test TEST and record the result using STATS and LISTENER." - (let ((ert-current-run-stats stats) - (pos (ert-stats-test-index stats test)) - (results (ert-stats-test-results stats)) - (expected (ert-stats-test-results-expected stats))) - ;; Adjust stats to remove previous result. - (if (aref expected pos) - (etypecase (aref results pos) - (ert-test-passed (decf (ert-stats-passed-expected stats))) - (ert-test-failed (decf (ert-stats-failed-expected stats))) - (ert-test-error (decf (ert-stats-error-expected stats))) - (null) - (ert-test-aborted-with-non-local-exit)) - (etypecase (aref results pos) - (ert-test-passed (decf (ert-stats-passed-unexpected stats))) - (ert-test-failed (decf (ert-stats-failed-unexpected stats))) - (ert-test-error (decf (ert-stats-error-unexpected stats))) - (null) - (ert-test-aborted-with-non-local-exit))) - (setf (aref results pos) 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) - (unwind-protect - (ert-run-test test) - (let* ((result (ert-test-most-recent-result test)) - (expectedp (typep result (ert-test-expected-result-type test)))) - ;; Adjust stats to add new result. - (if expectedp - (etypecase result - (ert-test-passed (incf (ert-stats-passed-expected stats))) - (ert-test-failed (incf (ert-stats-failed-expected stats))) - (ert-test-error (incf (ert-stats-error-expected stats))) - (null) - (ert-test-aborted-with-non-local-exit)) - (etypecase result - (ert-test-passed (incf (ert-stats-passed-unexpected stats))) - (ert-test-failed (incf (ert-stats-failed-unexpected stats))) - (ert-test-error (incf (ert-stats-error-unexpected stats))) - (null) - (ert-test-aborted-with-non-local-exit))) - (setf (aref results pos) result - (aref expected pos) expectedp) - (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 (coerce (ert-select-tests selector t) 'vector)) - (map (let ((map (make-hash-table :size (length tests)))) - (loop for i from 0 - for test across tests - for key = (or (ert-test-name test) test) do - (assert (not (gethash key map))) - (setf (gethash key map) i)) - map)) - (stats (make-ert-stats :selector selector - :tests tests - :test-map map - :test-results (make-vector (length tests) nil) - :test-results-expected (make-vector - (length tests) nil) - :total (length tests) - :start-time (current-time)))) - (funcall listener 'run-started stats) - (let ((abortedp t)) - (let ((ert-current-run-stats stats)) - (force-mode-line-update) - (unwind-protect - (progn - (loop for test across 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))) - stats))) - -(defun ert-stats-test-index (stats test) - "Return the index of TEST in the run represented by STATS." - (gethash (or (ert-test-name test) test) (ert-stats-test-map stats))) - -(defvar ert-selector-history nil - "List of recent test selectors read from terminal.") - -;; Fix-me: return (regep (list of matches))? -;; Fix-me: Add prompt parameter? -(defun ert-read-test-selector () - "Read a regexp for test selection from minibuffer. -The user can use TAB to see which tests match." - (let* ((all-tests - (mapcar (lambda (rec) (format "%s" (elt rec 1))) - (ert-select-tests "" t)) - ;;'("ert-group1-1" "ert-group1-2" "ert-other") - ) - regexp - ret - (get-completions - (lambda () - (let* ((ret (save-match-data - (mapcar (lambda (alt) - (when (string-match regexp alt) - alt)) - all-tests)))) - (setq ret (delq nil ret)) - ret)))) - (setq all-tests (append all-tests - '(":new" - ":failed" ":passed" ":error" - ) - nil)) - (let ((mini-map (copy-keymap minibuffer-local-map))) - (define-key mini-map [?\t] - (lambda () (interactive) - (with-output-to-temp-buffer "*Completions*" - (display-completion-list - (progn - (setq regexp (minibuffer-contents)) - (set-text-properties 0 (length regexp) nil regexp) - (funcall get-completions)))))) - (setq regexp - (let* ((sym-here (thing-at-point 'symbol)) - (test-here (when (and sym-here - (memq sym-here all-tests)) - sym-here)) - (default (if sym-here - (substring-no-properties sym-here) - (if ert-selector-history - (first ert-selector-history) - "t")))) - (read-from-minibuffer - (if (null default) - "Run tests, use TAB to see matches: " - (format "Run tests, use TAB to see matches (default %s): " - default)) - nil ;; initial-contents - mini-map ;; keymap - nil ;; read - 'ert-selector-history - default nil)))) - (setq ret regexp) - (when (string= "t" ret) - (setq ret t)) - ret)) - -;; 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." - (interactive -;;; (list (let ((default (if ert-selector-history -;;; (first ert-selector-history) -;;; "t"))) -;;; (read-from-minibuffer (if (null default) -;;; "Run tests: " -;;; (format "Run tests (default %s): " default)) -;;; ;;nil nil t 'ert-selector-history -;;; ;; -;;; ;; fix-me: seems like I am misunderstanding Christians intent here. -;;; nil nil nil 'ert-selector-history -;;; default nil)) -;;; nil nil)) - (list (ert-read-test-selector) - 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-passed-expected stats) - (ert-stats-failed-expected stats) - (ert-stats-error-expected stats)) - (let ((unexpected - (+ (ert-stats-passed-unexpected stats) - (ert-stats-failed-unexpected stats) - (ert-stats-error-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-index stats test)) - (node (ewoc-nth ewoc pos))) - (unless node - ;; FIXME: How expensive is this assertion? - (assert (or (zerop pos) (ewoc-nth ewoc (1- pos))) - t) - (setq node (ewoc-enter-last - ewoc - (make-ert-ewoc-entry :test test - :hidden-p t)))) - (setf (ert-ewoc-entry-test (ewoc-data node)) test) - (setf (ert-ewoc-entry-result (ewoc-data node)) nil) - (aset ert-results-progress-bar-string pos - (ert-char-for-test-result nil t)) - (ert-results-update-stats-display 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-index stats test)) - (node (ewoc-nth ewoc pos))) - (setf (ert-ewoc-entry-result (ewoc-data node)) result) - (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 ewoc stats) - (ewoc-invalidate ewoc node)))))))) - (ert-run-tests - selector - listener))) - -(defvar ert-batch-backtrace-right-margin 70 - "*The maximum line length for printing backtraces in `ert-run-tests-batch'.") - -(defun ert-run-tests-batch (selector) - "Run the tests specified by SELECTOR, printing results to the terminal. - -Returns the stats object." - (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-passed-unexpected stats) - (ert-stats-failed-unexpected stats) - (ert-stats-error-unexpected stats)))) - (message "\n%sRan %s tests, %s results were as expected%s (%s)\n" - (if (not abortedp) - "" - "Aborted: ") - (ert-stats-total stats) - (+ (ert-stats-passed-expected stats) - (ert-stats-failed-expected stats) - (ert-stats-error-expected stats)) - (if (zerop unexpected) - "" - (format ", %s unexpected" unexpected)) - (ert-format-time-iso8601 (ert-stats-end-time stats))) - (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 - (etypecase result - (ert-test-passed) - (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 - (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)) - (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-index stats test)) - (ert-test-name test))))))))) - - -;;; 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 - '(("j" ert-results-jump-between-summary-and-result) - ("." ert-results-find-test-at-point-other-window) - ("r" ert-results-rerun-test-at-point) - ("d" ert-results-rerun-test-at-point-debugging-errors) - ("b" ert-results-pop-to-backtrace-for-test-at-point) - ("m" ert-results-pop-to-messages-for-test-at-point) - ("p" ert-results-toggle-printer-limits-for-test-at-point) - ("D" ert-delete-test) - ([?\t] forward-button) - ([backtab] backward-button) - ) - do - (define-key ert-results-mode-map key binding)) - -(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. - (if (and (>= (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-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* ((node (ert-results-test-node-at-point)) - (entry (ewoc-data node)) - (test (ert-ewoc-entry-test entry)) - (name (ert-test-name test))) - (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) - "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-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) - "Find the ewoc node that represents the same test as the character clicked on." - (goto-char (ert-button-action-position)) - (ert-results-jump-between-summary-and-result)) - -(defun ert-results-rerun-test-at-point () - "Re-run 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)) - (old-test (ert-ewoc-entry-test entry)) - (test-name (ert-test-name old-test)) - ;; FIXME: Write a test for this lookup. - (test (if test-name - (if (ert-test-boundp test-name) - (ert-get-test test-name) - (error "No such test: %S" test-name)) - old-test)) - (stats ert-results-stats) - (pos (gethash test (ert-stats-test-map stats))) - (progress-message (format "Running test %S" (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 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-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"))))))) - -(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* ((node (ert-results-test-node-at-point)) - (entry (ewoc-data node)) - (test (ert-ewoc-entry-test entry)) - (result (ert-ewoc-entry-result entry))) - (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 - (let ((default-major-mode 'fundamental-mode)) - (get-buffer-create "*ERT Backtrace*")))) - (pop-to-buffer buffer) - (setq buffer-read-only t) - (let ((inhibit-read-only t)) - (erase-buffer) - ;; 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)))))))) - -(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* ((node (ert-results-test-node-at-point)) - (entry (ewoc-data node)) - (test (ert-ewoc-entry-test entry)) - (result (ert-ewoc-entry-result entry))) - (let ((buffer - (let ((default-major-mode 'fundamental-mode)) - (get-buffer-create "*ERT Messages*")))) - (pop-to-buffer buffer) - (setq buffer-read-only t) - (let ((inhibit-read-only t)) - (erase-buffer) - (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-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-activate-font-lock-keywords () - (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 is an inverse of `add-to-list'." - (unless key (setq key #'identity)) - (unless test (setq test #'equal)) - (setf (symbol-value list-var) - (remove* element - (symbol-value list-var) - :key key - :test test))) - - -;;; 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 () - (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) - - -;;; Self-tests. - -(ert-delete-all-tests) - -;; Test that test bodies are actually run. -(defvar ert-test-body-was-run) -(ert-deftest ert-test-body-runs () - (setq ert-test-body-was-run t)) - - -;; Test that nested test bodies run. -(ert-deftest ert-nested-test-body-runs () - (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 (typep result 'ert-test-passed))))) - -(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 (typep result 'ert-test-failed) 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 (typep result 'ert-test-error) 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 () (ert-should nil))))) - (let ((result (let ((ert-debug-on-error nil)) - (ert-run-test test)))) - (assert (typep result 'ert-test-failed) t) - (assert (equal (ert-test-result-with-condition-condition result) - '(ert-test-failed ((ert-should nil) :form nil :value nil))) - t))) - (let ((test (make-ert-test :body (lambda () (ert-should t))))) - (let ((result (ert-run-test test))) - (assert (typep result 'ert-test-passed) t)))) - -(ert-deftest ert-test-should-value () - (ert-should (eql (ert-should 'foo) 'foo)) - (ert-should (eql (ert-should 'bar) 'bar))) - -(ert-deftest ert-test-should-not () - (let ((test (make-ert-test :body (lambda () (ert-should-not t))))) - (let ((result (let ((ert-debug-on-error nil)) - (ert-run-test test)))) - (assert (typep result 'ert-test-failed) t) - (assert (equal (ert-test-result-with-condition-condition result) - '(ert-test-failed ((ert-should-not t) :form t :value t))) - t))) - (let ((test (make-ert-test :body (lambda () (ert-should-not nil))))) - (let ((result (ert-run-test test))) - (assert (typep result 'ert-test-passed))))) - - -(ert-deftest ert-test-should-error () - ;; No error. - (let ((test (make-ert-test :body (lambda () (ert-should-error (progn)))))) - (let ((result (let ((ert-debug-on-error nil)) - (ert-run-test test)))) - (ert-should (typep result 'ert-test-failed)) - (ert-should (equal (ert-test-result-with-condition-condition result) - '(ert-test-failed - ((ert-should-error (progn)) - :form (progn) - :value nil - :fail-reason "did not signal an error")))))) - ;; A simple error. - (let ((test (make-ert-test :body (lambda () (ert-should-error (error "foo")))))) - (let ((result (ert-run-test test))) - (ert-should (typep result 'ert-test-passed)))) - ;; Error of unexpected type, no test. - (let ((test (make-ert-test :body (lambda () - (ert-should-error (error "foo") - :type 'singularity-error))))) - (let ((result (ert-run-test test))) - (ert-should (typep result 'ert-test-failed)) - (ert-should (equal - (ert-test-result-with-condition-condition result) - '(ert-test-failed - ((ert-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, no test. - (let ((test (make-ert-test :body (lambda () - (ert-should-error (signal 'singularity-error - nil) - :type 'singularity-error))))) - (let ((result (ert-run-test test))) - (ert-should (typep result 'ert-test-passed)))) - ;; Error that fails the test, no type. - (let ((test (make-ert-test :body (lambda () - (ert-should-error - (error "foo") - :test (lambda (error) nil)))))) - (let ((result (ert-run-test test))) - (ert-should (typep result 'ert-test-failed)) - (ert-should (equal (ert-test-result-with-condition-condition result) - '(ert-test-failed - ((ert-should-error (error "foo") :test (lambda (error) nil)) - :form (error "foo") - :condition (error "foo") - :fail-reason - "the error signalled did not pass the test")))))) - ;; Error that passes the test, no type. - (let ((test (make-ert-test :body (lambda () - (ert-should-error (error "foo") - :test (lambda (error) t)))))) - (let ((result (ert-run-test test))) - (ert-should (typep result 'ert-test-passed)))) - ;; Error that has the expected type but fails the test. - (let ((test (make-ert-test :body (lambda () - (ert-should-error - (signal 'singularity-error nil) - :type 'singularity-error - :test (lambda (error) nil)))))) - (let ((result (ert-run-test test))) - (ert-should (typep result 'ert-test-failed)) - (ert-should (equal (ert-test-result-with-condition-condition result) - '(ert-test-failed - ((ert-should-error (signal 'singularity-error nil) - :type 'singularity-error - :test (lambda (error) nil)) - :form (signal singularity-error nil) - :condition (singularity-error) - :fail-reason - "the error signalled did not pass the test")))))) - ;; Error that has the expected type and passes the test. - (let ((test (make-ert-test :body (lambda () - (ert-should-error - (signal 'singularity-error nil) - :type 'singularity-error - :test (lambda (error) t)))))) - (let ((result (ert-run-test test))) - (ert-should (typep result 'ert-test-passed)))) - ) - -(ert-deftest ert-test-should-error-subtypes () - (let ((test (make-ert-test - :body (lambda () - (ert-should-error (signal 'singularity-error nil) - :type 'singularity-error - :exclude-subtypes t))))) - (let ((result (ert-run-test test))) - (ert-should (typep result 'ert-test-passed)))) - (let ((test (make-ert-test - :body (lambda () - (ert-should-error (signal 'arith-error nil) - :type 'singularity-error))))) - (let ((result (ert-run-test test))) - (ert-should (typep result 'ert-test-failed)) - (ert-should (equal - (ert-test-result-with-condition-condition result) - '(ert-test-failed - ((ert-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 () - (ert-should-error (signal 'arith-error nil) - :type 'singularity-error - :exclude-subtypes t))))) - (let ((result (ert-run-test test))) - (ert-should (typep result 'ert-test-failed)) - (ert-should (equal - (ert-test-result-with-condition-condition result) - '(ert-test-failed - ((ert-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 () - (ert-should-error (signal 'singularity-error nil) - :type 'arith-error - :exclude-subtypes t))))) - (let ((result (ert-run-test test))) - (ert-should (typep result 'ert-test-failed)) - (ert-should (equal - (ert-test-result-with-condition-condition result) - '(ert-test-failed - ((ert-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")))))) - ) - -;; Test that `should' errors contain the information we expect them to. -(defmacro ert-test-my-list (&rest args) - `(list ,@args)) - -(ert-deftest ert-test-should-failure-debugging () - (loop for (body expected-condition) in - `((,(lambda () (let ((x nil)) (ert-should x))) - (ert-test-failed ((ert-should x) :form x :value nil))) - (,(lambda () (let ((x t)) (ert-should-not x))) - (ert-test-failed ((ert-should-not x) :form x :value t))) - (,(lambda () (let ((x t)) (ert-should (not x)))) - (ert-test-failed ((ert-should (not x)) :form (not t) :value nil))) - (,(lambda () (let ((x nil)) (ert-should-not (not x)))) - (ert-test-failed ((ert-should-not (not x)) :form (not nil) :value t))) - (,(lambda () (let ((x t) (y nil)) (ert-should-not (ert-test-my-list x y)))) - (ert-test-failed - ((ert-should-not (ert-test-my-list x y)) - :form (list t nil) - :value (t nil)))) - (,(lambda () (let ((x t)) (ert-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) - (ert-should (equal actual-condition expected-condition))))))) - -(ert-deftest ert-test-messages () - (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))) - (ert-should (equal (concat message-string "\n") - (ert-test-result-messages result))))))) - -(defun ert-call-with-temporary-messages-buffer (thunk) - (lexical-let ((new-buffer-name (generate-new-buffer-name - "*Messages* orig buffer"))) - (unwind-protect - (progn - (with-current-buffer (get-buffer-create "*Messages*") - (rename-buffer new-buffer-name)) - (get-buffer-create "*Messages*") - (funcall thunk)) - (kill-buffer "*Messages*") - (with-current-buffer new-buffer-name - (rename-buffer "*Messages*"))))) - -(ert-deftest ert-test-messages-on-log-truncation () - (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-call-with-temporary-messages-buffer - (lambda () - (let ((message-log-max 2)) - (setq result (ert-run-test test))) - (ert-should (equal (with-current-buffer "*Messages*" - (buffer-string)) - "c\nd\n")))) - (ert-should (equal (ert-test-result-messages result) "a\nb\nc\nd\n"))))) - -;; Test `ert-select-tests'. -(ert-deftest ert-test-select-regexp () - (ert-should (equal (ert-select-tests "^ert-test-select-regexp$" t) - (list (ert-get-test 'ert-test-select-regexp))))) - -(ert-deftest ert-test-test-boundp () - (ert-should (ert-test-boundp 'ert-test-test-boundp)) - (ert-should-not (ert-test-boundp (make-symbol "ert-not-a-test")))) - -(ert-deftest ert-test-select-member () - (ert-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 () - (ert-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 () - (ert-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)))) - (ert-should (equal (ert-select-tests `(and (member ,test) :failed) t) - (list test))))) - - -;; Test utility functions. -(ert-deftest ert-proper-list-p () - (ert-should (ert-proper-list-p '())) - (ert-should (ert-proper-list-p '(1))) - (ert-should (ert-proper-list-p '(1 2))) - (ert-should (ert-proper-list-p '(1 2 3))) - (ert-should (ert-proper-list-p '(1 2 3 4))) - (ert-should (not (ert-proper-list-p 'a))) - (ert-should (not (ert-proper-list-p '(1 . a)))) - (ert-should (not (ert-proper-list-p '(1 2 . a)))) - (ert-should (not (ert-proper-list-p '(1 2 3 . a)))) - (ert-should (not (ert-proper-list-p '(1 2 3 4 . a)))) - (let ((a (list 1))) - (setf (cdr (last a)) a) - (ert-should (not (ert-proper-list-p a)))) - (let ((a (list 1 2))) - (setf (cdr (last a)) a) - (ert-should (not (ert-proper-list-p a)))) - (let ((a (list 1 2 3))) - (setf (cdr (last a)) a) - (ert-should (not (ert-proper-list-p a)))) - (let ((a (list 1 2 3 4))) - (setf (cdr (last a)) a) - (ert-should (not (ert-proper-list-p a)))) - (let ((a (list 1 2))) - (setf (cdr (last a)) (cdr a)) - (ert-should (not (ert-proper-list-p a)))) - (let ((a (list 1 2 3))) - (setf (cdr (last a)) (cdr a)) - (ert-should (not (ert-proper-list-p a)))) - (let ((a (list 1 2 3 4))) - (setf (cdr (last a)) (cdr a)) - (ert-should (not (ert-proper-list-p a)))) - (let ((a (list 1 2 3))) - (setf (cdr (last a)) (cddr a)) - (ert-should (not (ert-proper-list-p a)))) - (let ((a (list 1 2 3 4))) - (setf (cdr (last a)) (cddr a)) - (ert-should (not (ert-proper-list-p a)))) - (let ((a (list 1 2 3 4))) - (setf (cdr (last a)) (cdddr a)) - (ert-should (not (ert-proper-list-p a))))) - -(ert-deftest ert-parse-keys-and-body () - (ert-should (equal (ert-parse-keys-and-body "doc" '(foo)) - '(nil "doc" (foo)))) - (ert-should (equal (ert-parse-keys-and-body "doc" '(:bar foo)) - '((:bar foo) "doc" nil))) - (ert-should (equal (ert-parse-keys-and-body nil '(:bar foo)) - '((:bar foo) nil nil))) - (ert-should (equal (ert-parse-keys-and-body "doc" '(:bar foo)) - '((:bar foo) "doc" nil))) - (ert-should (equal (ert-parse-keys-and-body nil '(:bar foo a (b))) - '((:bar foo) nil (a (b))))) - (ert-should (equal (ert-parse-keys-and-body nil '(:bar foo :a (b))) - '((:bar foo :a (b)) nil nil))) - (ert-should (equal (ert-parse-keys-and-body nil '(bar foo :a (b))) - '(nil nil (bar foo :a (b))))) - (ert-should-error (ert-parse-keys-and-body nil '(:bar foo :a)))) - - - -;; Test `ert-run-tests'. -(ert-deftest ert-test-run-tests () - (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) - (ert-should (equal messages `(,(concat - "Ran 2 tests, 1 results were " - "as expected, 1 unexpected")))) - (with-current-buffer buffer-name - (goto-char (point-min)) - (ert-should (equal - (buffer-substring (point-min) - (save-excursion - (forward-line 5) - (point))) - (concat - "Selector: (member <passing-test> <failing-test>)\n" - "Passed: 1 (0 unexpected)\n" - "Failed: 1 (1 unexpected)\n" - "Error: 0 (0 unexpected)\n" - "Total: 2/2\n"))))) - (when (get-buffer buffer-name) - (kill-buffer buffer-name)))))))) - -(ert-deftest ert-test-special-operator-p () - (ert-should (ert-special-operator-p 'if)) - (ert-should-not (ert-special-operator-p 'car)) - (ert-should-not (ert-special-operator-p 'ert-special-operator-p)) - (let ((b (gensym))) - (ert-should-not (ert-special-operator-p b)) - (fset b 'if) - (ert-should (ert-special-operator-p b)))) - -;; 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. -(ert-deftest ert-test-builtin-message-log-flushing () - (ert-call-with-temporary-messages-buffer - (lambda () - (with-current-buffer "*Messages*" - (let ((message-log-max 2)) - (let ((message-log-max t)) - (loop for i below 4 do - (message "%s" i)) - (ert-should (eql (count-lines (point-min) (point-max)) 4))) - (ert-should (eql (count-lines (point-min) (point-max)) 4)) - (message "") - (ert-should (eql (count-lines (point-min) (point-max)) 4)) - (message "Test message") - (ert-should (eql (count-lines (point-min) (point-max)) 2))))))) - -(ert-deftest ert-test-force-message-log-buffer-truncation () - (labels ((body () - (loop for i below 5 do - (message "%s" i))) - (c (x) - (ert-call-with-temporary-messages-buffer - (lambda () - (let ((message-log-max x)) - (body)) - (with-current-buffer "*Messages*" - (buffer-string))))) - (lisp (x) - (ert-call-with-temporary-messages-buffer - (lambda () - (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 5 6 t) do - (ert-should (equal (c x) (lisp x)))))) - -(defun ert-run-self-tests () - ;; Run 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) - (when (zerop (+ (ert-stats-passed-unexpected stats) - (ert-stats-failed-unexpected stats) - (ert-stats-error-unexpected stats))) - ;; Hide results window only when everything went well. - (set-window-configuration window-configuration)))))) - -(provide 'ert) - -;;; ert.el ends here |