├── util ├── .nosearch └── ert.el ├── .gitignore ├── Makefile ├── .gitmodules ├── Carton ├── run-travis-ci.sh ├── wishful-readme.md ├── watch-tests.watchr ├── features ├── support │ └── env.el ├── step-definitions │ └── multifiles-steps.el └── multifiles.feature ├── README.md └── multifiles.el /util/.nosearch: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | elpa 2 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | ECUKES = $(shell find elpa/ecukes-*/ecukes | tail -1) 2 | 3 | all: 4 | carton exec ${ECUKES} features 5 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "util/ecukes"] 2 | path = util/ecukes 3 | url = git://github.com/rejeep/ecukes.git 4 | [submodule "util/espuds"] 5 | path = util/espuds 6 | url = git://github.com/rejeep/espuds.git 7 | -------------------------------------------------------------------------------- /Carton: -------------------------------------------------------------------------------- 1 | (source "melpa" "http://melpa.milkbox.net/packages/") 2 | 3 | (package "multifiles" "0.0.1" "View and edit parts of multiple files in one buffer.") 4 | 5 | (depends-on "dash") 6 | 7 | (development 8 | (depends-on "ecukes") 9 | (depends-on "espuds")) 10 | -------------------------------------------------------------------------------- /run-travis-ci.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | cd "$(dirname "$0")" 4 | 5 | set_default () { 6 | eval " 7 | if [ -z \$$1 ]; then 8 | $1=$2 9 | fi 10 | " 11 | } 12 | 13 | set_default ECUKES_EMACS "$(which emacs)" 14 | 15 | echo "*** Emacs version ***" 16 | echo "ECUKES_EMACS =" $(which $ECUKES_EMACS) 17 | $ECUKES_EMACS --version 18 | echo 19 | 20 | make 21 | -------------------------------------------------------------------------------- /wishful-readme.md: -------------------------------------------------------------------------------- 1 | # multifiles.el 2 | 3 | An initial attempt at "multifiles" as defined 4 | [here](http://www.reddit.com/r/emacs/comments/10gc9u/can_i_have_multiple_parts_of_buffers_in_one_super/). 5 | 6 | ## Setup 7 | 8 | (require 'multifiles) 9 | 10 | ## Usage 11 | 12 | Bind a key to `mf/mirror-region-lines-in-multifile`, let's say `C-!`. Now 13 | mark a part of the buffer and press it. A new \*multifile\* buffer pops 14 | up. Mark some other part of another file, and press `C-!` again. This 15 | is added to the \*multifile\*. 16 | 17 | You can now edit the \*multifile\* buffer, and watch the original files change. 18 | Or you can edit the original files and watch the \*multifile\* buffer change. 19 | 20 | Saving in the \*multifile\* buffer saves all the original files. 21 | -------------------------------------------------------------------------------- /watch-tests.watchr: -------------------------------------------------------------------------------- 1 | ENV["WATCHR"] = "1" 2 | system 'clear' 3 | 4 | def run(cmd) 5 | `#{cmd}` 6 | end 7 | 8 | def run_all_tests 9 | system('clear') 10 | result = run "make" 11 | puts result 12 | end 13 | 14 | run_all_tests 15 | watch('.*.feature') { run_all_tests } 16 | watch('.*.el') { run_all_tests } 17 | 18 | # Ctrl-\ 19 | Signal.trap 'QUIT' do 20 | puts " --- Running all tests ---\n\n" 21 | run_all_tests 22 | end 23 | 24 | @interrupted = false 25 | 26 | # Ctrl-C 27 | Signal.trap 'INT' do 28 | if @interrupted then 29 | @wants_to_quit = true 30 | abort("\n") 31 | else 32 | puts "Interrupt a second time to quit" 33 | @interrupted = true 34 | Kernel.sleep 1.5 35 | # raise Interrupt, nil # let the run loop catch it 36 | run_all_tests 37 | @interrupted = false 38 | end 39 | end 40 | -------------------------------------------------------------------------------- /features/support/env.el: -------------------------------------------------------------------------------- 1 | (let* ((current-directory (file-name-directory load-file-name)) 2 | (features-directory (expand-file-name ".." current-directory)) 3 | (project-directory (expand-file-name ".." features-directory))) 4 | (setq multifiles-root-path project-directory) 5 | (setq multifiles-util-path (expand-file-name "util" project-directory))) 6 | 7 | (add-to-list 'load-path multifiles-root-path) 8 | (add-to-list 'load-path multifiles-util-path) 9 | (add-to-list 'load-path (expand-file-name "espuds" multifiles-util-path)) 10 | 11 | (require 'multifiles) 12 | (require 'espuds) 13 | (require 'ert) 14 | 15 | (Setup 16 | (global-set-key (kbd "C-!") 'mf/mirror-region-in-multifile)) 17 | 18 | (Before 19 | (ignore-errors 20 | (kill-buffer "*multifile*")) 21 | (transient-mark-mode 1) 22 | (cua-mode 0) 23 | (delete-selection-mode 0) 24 | (subword-mode 0) 25 | (setq set-mark-default-inactive nil) 26 | (deactivate-mark)) 27 | 28 | (After) 29 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # multifiles.el 2 | 3 | An initial attempt at "multifiles" as defined 4 | [here](http://www.reddit.com/r/emacs/comments/10gc9u/can_i_have_multiple_parts_of_buffers_in_one_super/). 5 | 6 | ## Setup 7 | 8 | (require 'multifiles) 9 | 10 | ## Usage 11 | 12 | Bind a key to `mf/mirror-region-in-multifile`, let's say `C-!`. Now 13 | mark a part of the buffer and press it. A new \*multifile\* buffer pops 14 | up. Mark some other part of another file, and press `C-!` again. This 15 | is added to the \*multifile\*. 16 | 17 | You can now edit the \*multifile\* buffer, and watch the original files change. 18 | Or you can edit the original files and watch the \*multifile\* buffer change. 19 | 20 | Saving the \*multifile\* buffer will save all the original files. 21 | 22 | **Warning** This API and functionality is highly volatile. 23 | 24 | ## License 25 | 26 | Copyright (C) 2011 Magnar Sveen 27 | 28 | Author: Magnar Sveen 29 | Keywords: multiple files 30 | 31 | This program is free software; you can redistribute it and/or modify 32 | it under the terms of the GNU General Public License as published by 33 | the Free Software Foundation, either version 3 of the License, or 34 | (at your option) any later version. 35 | 36 | This program is distributed in the hope that it will be useful, 37 | but WITHOUT ANY WARRANTY; without even the implied warranty of 38 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 39 | GNU General Public License for more details. 40 | 41 | You should have received a copy of the GNU General Public License 42 | along with this program. If not, see . 43 | -------------------------------------------------------------------------------- /features/step-definitions/multifiles-steps.el: -------------------------------------------------------------------------------- 1 | (Given "^I open and erase file \"\\(.+\\)\"$" 2 | (lambda (filename) 3 | (find-file filename) 4 | (kill-buffer) 5 | (find-file filename))) 6 | 7 | (When "^I press \"\\(.+\\)\"$" 8 | (lambda (keybinding) 9 | (let ((macro (edmacro-parse-keys keybinding))) 10 | (if espuds-chain-active 11 | (setq espuds-action-chain (vconcat espuds-action-chain macro)) 12 | (if (and (equal keybinding "C-g") 13 | (eq (key-binding (kbd "C-g")) 'keyboard-quit)) 14 | (espuds-quit) 15 | (execute-kbd-macro macro)))))) 16 | 17 | (When "^I go to character \"\\(.+\\)\"$" 18 | (lambda (char) 19 | (goto-char (point-min)) 20 | (let ((search (re-search-forward (format "%s" char) nil t)) 21 | (message "Can not go to character '%s' since it does not exist in the current buffer: %s")) 22 | (assert search nil message char (espuds-buffer-contents))))) 23 | 24 | (When "^I go to the \\(front\\|end\\) of the word \"\\(.+\\)\"$" 25 | (lambda (pos word) 26 | (goto-char (point-min)) 27 | (let ((search (re-search-forward (format "%s" word) nil t)) 28 | (message "Can not go to character '%s' since it does not exist in the current buffer: %s")) 29 | (assert search nil message word (espuds-buffer-contents)) 30 | (if (string-equal "front" pos) (backward-word))))) 31 | 32 | (When "^I select the last \"\\(.+\\)\"$" 33 | (lambda (text) 34 | (goto-char (point-max)) 35 | (let ((search (re-search-backward text nil t))) 36 | (assert search nil "The text '%s' was not found in the current buffer." text)) 37 | (set-mark (point)) 38 | (re-search-forward text))) 39 | 40 | (Then "^the major-mode should be \"\\(.+\\)\"$" 41 | (lambda (mode) 42 | (assert (string= (symbol-name major-mode) mode) nil 43 | "The major mode should be %s but was %S." mode major-mode))) 44 | 45 | (Then "^the buffer should be saved$" 46 | (lambda () 47 | (assert (not (buffer-modified-p)) nil 48 | "The buffer should be saved, but was modified."))) 49 | -------------------------------------------------------------------------------- /features/multifiles.feature: -------------------------------------------------------------------------------- 1 | Feature: Editing parts of multiple files in one buffer 2 | 3 | Background: 4 | Given I switch to buffer "*multifile*" 5 | And I press "" 6 | And I open and erase file "/tmp/test1.rb" 7 | And I insert: 8 | """ 9 | outside 10 | line a 11 | line b 12 | line c 13 | outside 14 | """ 15 | And I go to the front of the word "line" 16 | And I set the mark 17 | And I go to the end of the word "c" 18 | And I press "C-!" 19 | 20 | Scenario: Opening multi-buffer from region 21 | When I switch to buffer "*multifile*" 22 | Then I should see: 23 | """ 24 | line a 25 | line b 26 | line c 27 | """ 28 | 29 | Scenario: Editing from multifile, center 30 | When I switch to buffer "*multifile*" 31 | And I go to the end of the word "line b" 32 | And I insert "ooya!" 33 | And I switch to buffer "test1.rb" 34 | Then I should see "booya!" 35 | 36 | Scenario: Editing from multifile, beginning 37 | When I switch to buffer "*multifile*" 38 | And I go to the front of the word "a" 39 | And I press "M-b" 40 | And I insert "sp" 41 | And I switch to buffer "test1.rb" 42 | Then I should see "spline a" 43 | 44 | Scenario: Editing from multifile, end 45 | When I switch to buffer "*multifile*" 46 | And I go to the end of the word "c" 47 | And I insert "ool" 48 | And I switch to buffer "test1.rb" 49 | Then I should see "cool" 50 | 51 | Scenario: Editing from multifile, outside top 52 | When I switch to buffer "*multifile*" 53 | And I go to the front of the word "a" 54 | And I press "M-b" 55 | And I press "C-b" 56 | And I insert "mirror-only" 57 | And I switch to buffer "test1.rb" 58 | Then I should not see "mirror-only" 59 | 60 | Scenario: Editing from multifile, outside bottom 61 | When I switch to buffer "*multifile*" 62 | And I go to the end of the word "c" 63 | And I press "C-f" 64 | And I insert "mirror-only" 65 | And I switch to buffer "test1.rb" 66 | Then I should not see "mirror-only" 67 | 68 | Scenario: Editing from original file 69 | When I switch to buffer "test1.rb" 70 | And I go to the end of the word "line b" 71 | And I insert "ooya!" 72 | And I switch to buffer "*multifile*" 73 | Then I should see "booya!" 74 | 75 | Scenario: Editing from original, beginning 76 | When I switch to buffer "test1.rb" 77 | And I go to the front of the word "a" 78 | And I press "M-b" 79 | And I insert "sp" 80 | And I switch to buffer "*multifile*" 81 | Then I should see "spline a" 82 | 83 | Scenario: Editing from original, end 84 | When I switch to buffer "test1.rb" 85 | And I go to the end of the word "c" 86 | And I insert "ool" 87 | And I switch to buffer "*multifile*" 88 | Then I should see "cool" 89 | 90 | Scenario: Editing from original, outside top 91 | When I switch to buffer "test1.rb" 92 | And I go to the front of the word "a" 93 | And I press "M-b" 94 | And I press "C-b" 95 | And I insert "mirror-only" 96 | And I switch to buffer "*multifile*" 97 | Then I should not see "mirror-only" 98 | 99 | Scenario: Editing from original, outside bottom 100 | When I switch to buffer "test1.rb" 101 | And I go to the end of the word "c" 102 | And I press "C-f" 103 | And I insert "mirror-only" 104 | And I switch to buffer "*multifile*" 105 | Then I should not see "mirror-only" 106 | 107 | Scenario: Removing mirror 108 | When I switch to buffer "*multifile*" 109 | And I press "C-x h" 110 | And I press "C-w" 111 | And I switch to buffer "test1.rb" 112 | Then I should see: 113 | """ 114 | outside 115 | line a 116 | line b 117 | line c 118 | outside 119 | """ 120 | 121 | Scenario: Removing original 122 | And I switch to buffer "test1.rb" 123 | And I press "C-x h" 124 | And I press "C-w" 125 | When I switch to buffer "*multifile*" 126 | Then I should not see: 127 | """ 128 | line a 129 | line b 130 | line c 131 | """ 132 | 133 | Scenario: Support for delete-selection-mode 134 | Given I turn on delete-selection-mode 135 | And I switch to buffer "test1.rb" 136 | And I go to the end of the word "a" 137 | And I insert "ff" 138 | And I select "line b" 139 | And I press "f" 140 | Then I should see: 141 | """ 142 | line aff 143 | f 144 | line c 145 | """ 146 | 147 | Scenario: Same major mode as first original 148 | When I switch to buffer "*multifile*" 149 | Then the major-mode should be "ruby-mode" 150 | 151 | Scenario: Saving original files 152 | When I switch to buffer "*multifile*" 153 | And I go to the end of the word "line b" 154 | And I insert "ooya!" 155 | And I press "C-x C-s yes" 156 | And I switch to buffer "test1.rb" 157 | Then the buffer should be saved 158 | -------------------------------------------------------------------------------- /multifiles.el: -------------------------------------------------------------------------------- 1 | ;;; multifiles.el --- View and edit parts of multiple files in one buffer 2 | 3 | ;; Copyright (C) 2011 Magnar Sveen 4 | 5 | ;; Author: Magnar Sveen 6 | ;; Keywords: multiple files 7 | 8 | ;; This program is free software; you can redistribute it and/or modify 9 | ;; it under the terms of the GNU General Public License as published by 10 | ;; the Free Software Foundation, either version 3 of the License, or 11 | ;; (at your option) any later version. 12 | 13 | ;; This program is distributed in the hope that it will be useful, 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | ;; GNU General Public License for more details. 17 | 18 | ;; You should have received a copy of the GNU General Public License 19 | ;; along with this program. If not, see . 20 | 21 | ;;; Commentary: 22 | 23 | ;; Bind a key to `mf/mirror-region-in-multifile`, let's say `C-!`. Now 24 | ;; mark a part of the buffer and press it. A new \*multifile\* buffer pops 25 | ;; up. Mark some other part of another file, and press `C-!` again. This 26 | ;; is added to the \*multifile\*. 27 | 28 | ;; You can now edit the \*multifile\* buffer, and watch the original files change. 29 | ;; Or you can edit the original files and watch the \*multifile\* buffer change. 30 | 31 | ;; **Warning** This API and functionality is highly volatile. 32 | 33 | ;;; Code: 34 | 35 | (require 'dash) 36 | 37 | (defun mf/mirror-region-in-multifile (beg end &optional multifile-buffer) 38 | (interactive (list (region-beginning) (region-end) 39 | (when current-prefix-arg 40 | (read-buffer "Mirror into buffer: " "*multifile*")))) 41 | (deactivate-mark) 42 | (let ((buffer (current-buffer)) 43 | (mode major-mode)) 44 | (switch-to-buffer-other-window (or multifile-buffer "*multifile*")) 45 | (funcall mode) 46 | (multifiles-minor-mode 1) 47 | (mf--add-mirror buffer beg end) 48 | (switch-to-buffer-other-window buffer))) 49 | 50 | (defvar multifiles-minor-mode-map nil 51 | "Keymap for multifiles minor mode.") 52 | 53 | (unless multifiles-minor-mode-map 54 | (setq multifiles-minor-mode-map (make-sparse-keymap))) 55 | 56 | (define-key multifiles-minor-mode-map (vector 'remap 'save-buffer) 'mf/save-original-buffers) 57 | 58 | (defun mf/save-original-buffers () 59 | (interactive) 60 | (when (yes-or-no-p "Are you sure you want to save all original files?") 61 | (--each (mf--original-buffers) 62 | (with-current-buffer it 63 | (when buffer-file-name 64 | (save-buffer)))))) 65 | 66 | (defun mf--original-buffers () 67 | (->> (overlays-in (point-min) (point-max)) 68 | (--filter (equal 'mf-mirror (overlay-get it 'type))) 69 | (--map (overlay-buffer (overlay-get it 'twin))) 70 | (-distinct))) 71 | 72 | (define-minor-mode multifiles-minor-mode 73 | "A minor mode for the *multifile* buffer." 74 | nil "" multifiles-minor-mode-map) 75 | 76 | (defun mf--add-mirror (buffer beg end) 77 | (let (contents original-overlay mirror-overlay) 78 | (mf--add-hook-if-necessary) 79 | (with-current-buffer buffer 80 | (mf--add-hook-if-necessary) 81 | (setq contents (buffer-substring beg end)) 82 | (setq original-overlay (create-original-overlay beg end))) 83 | (mf---insert-contents) 84 | (setq mirror-overlay (create-mirror-overlay beg end)) 85 | (overlay-put mirror-overlay 'twin original-overlay) 86 | (overlay-put original-overlay 'twin mirror-overlay))) 87 | 88 | (defun mf---insert-contents () 89 | (end-of-buffer) 90 | (newline) 91 | (setq beg (point)) 92 | (insert contents) 93 | (setq end (point)) 94 | (newline 2)) 95 | 96 | (defun mf--any-overlays-in-buffer () 97 | (--any? (memq (overlay-get it 'type) '(mf-original mf-mirror)) 98 | (overlays-in (point-min) (point-max)))) 99 | 100 | (defun mf--add-hook-if-necessary () 101 | (unless (mf--any-overlays-in-buffer) 102 | (add-hook 'post-command-hook 'mf--update-twins))) 103 | 104 | (defun mf--remove-hook-if-necessary () 105 | (unless (mf--any-overlays-in-buffer) 106 | (remove-hook 'post-command-hook 'mf--update-twins))) 107 | 108 | (defun create-original-overlay (beg end) 109 | (let ((o (make-overlay beg end nil nil t))) 110 | (overlay-put o 'type 'mf-original) 111 | (overlay-put o 'modification-hooks '(mf--on-modification)) 112 | (overlay-put o 'insert-in-front-hooks '(mf--on-modification)) 113 | (overlay-put o 'insert-behind-hooks '(mf--on-modification)) 114 | o)) 115 | 116 | (defun create-mirror-overlay (beg end) 117 | (let ((o (make-overlay beg end nil nil t))) 118 | (overlay-put o 'type 'mf-mirror) 119 | (overlay-put o 'line-prefix mf--mirror-indicator) 120 | (overlay-put o 'modification-hooks '(mf--on-modification)) 121 | (overlay-put o 'insert-in-front-hooks '(mf--on-modification)) 122 | (overlay-put o 'insert-behind-hooks '(mf--on-modification)) 123 | o)) 124 | 125 | (defvar mf--changed-overlays nil) 126 | (make-variable-buffer-local 'mf--changed-overlays) 127 | 128 | (defun mf--on-modification (o after? beg end &optional delete-length) 129 | (when (not after?) 130 | (when (mf---removed-entire-overlay) 131 | (mf--remove-mirror o))) 132 | 133 | (when (and after? (not (null (overlay-start o)))) 134 | (add-to-list 'mf--changed-overlays o))) 135 | 136 | (defun mf---removed-entire-overlay () 137 | (and (<= beg (overlay-start o)) 138 | (>= end (overlay-end o)))) 139 | 140 | (defun mf--update-twins () 141 | (when mf--changed-overlays 142 | (-each mf--changed-overlays 'mf--update-twin) 143 | (setq mf--changed-overlays nil))) 144 | 145 | (defun mf--remove-mirror (o) 146 | (let* ((twin (overlay-get o 'twin)) 147 | (original (if (mf--is-original o) o twin)) 148 | (mirror (if (mf--is-original o) twin o)) 149 | (mirror-beg (overlay-start mirror)) 150 | (mirror-end (overlay-end mirror))) 151 | (with-current-buffer (overlay-buffer mirror) 152 | (save-excursion 153 | (delete-overlay mirror) 154 | (delete-region mirror-beg mirror-end) 155 | (goto-char mirror-beg) 156 | (delete-blank-lines) 157 | (mf--remove-hook-if-necessary))) 158 | (delete-overlay original) 159 | (mf--remove-hook-if-necessary))) 160 | 161 | (defun mf--is-original (o) 162 | (equal 'mf-original (overlay-get o 'type))) 163 | 164 | (defun mf--update-twin (o) 165 | (let* ((beg (overlay-start o)) 166 | (end (overlay-end o)) 167 | (contents (buffer-substring beg end)) 168 | (twin (overlay-get o 'twin)) 169 | (buffer (overlay-buffer twin)) 170 | (beg (overlay-start twin)) 171 | (end (overlay-end twin))) 172 | (with-current-buffer buffer 173 | (save-excursion 174 | (goto-char beg) 175 | (insert contents) 176 | (delete-char (- end beg)) 177 | )))) 178 | 179 | (defvar mf--mirror-indicator "| ") 180 | (add-text-properties 181 | 0 1 182 | `(face (:foreground ,(format "#%02x%02x%02x" 128 128 128) 183 | :background ,(format "#%02x%02x%02x" 128 128 128))) 184 | mf--mirror-indicator) 185 | 186 | (provide 'multifiles) 187 | 188 | ;;; multifiles.el ends here 189 | -------------------------------------------------------------------------------- /util/ert.el: -------------------------------------------------------------------------------- 1 | ;;; ert.el --- Emacs Lisp Regression Testing 2 | 3 | ;; Copyright (C) 2007, 2008, 2010 Free Software Foundation, Inc. 4 | 5 | ;; Author: Christian M. Ohler 6 | ;; Keywords: lisp, tools 7 | 8 | ;; This file is NOT part of GNU Emacs. 9 | 10 | ;; This program is free software: you can redistribute it and/or 11 | ;; modify it under the terms of the GNU General Public License as 12 | ;; published by the Free Software Foundation, either version 3 of the 13 | ;; License, or (at your option) any later version. 14 | ;; 15 | ;; This program is distributed in the hope that it will be useful, but 16 | ;; WITHOUT ANY WARRANTY; without even the implied warranty of 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 18 | ;; General Public License for more details. 19 | ;; 20 | ;; You should have received a copy of the GNU General Public License 21 | ;; along with this program. If not, see `http://www.gnu.org/licenses/'. 22 | 23 | ;;; Commentary: 24 | 25 | ;; ERT is a tool for automated testing in Emacs Lisp. Its main 26 | ;; features are facilities for defining and running test cases and 27 | ;; reporting the results as well as for debugging test failures 28 | ;; interactively. 29 | ;; 30 | ;; The main entry points are `ert-deftest', which is similar to 31 | ;; `defun' but defines a test, and `ert-run-tests-interactively', 32 | ;; which runs tests and offers an interactive interface for inspecting 33 | ;; results and debugging. There is also 34 | ;; `ert-run-tests-batch-and-exit' for non-interactive use. 35 | ;; 36 | ;; The body of `ert-deftest' forms resembles a function body, but the 37 | ;; additional operators `should', `should-not' and `should-error' are 38 | ;; available. `should' is similar to cl's `assert', but signals a 39 | ;; different error when its condition is violated that is caught and 40 | ;; processed by ERT. In addition, it analyzes its argument form and 41 | ;; records information that helps debugging (`assert' tries to do 42 | ;; something similar when its second argument SHOW-ARGS is true, but 43 | ;; `should' is more sophisticated). For information on `should-not' 44 | ;; and `should-error', see their docstrings. 45 | ;; 46 | ;; See ERT's info manual as well as the docstrings for more details. 47 | ;; To compile the manual, run `makeinfo ert.texinfo' in the ERT 48 | ;; directory, then C-u M-x info ert.info in Emacs to view it. 49 | ;; 50 | ;; To see some examples of tests written in ERT, see its self-tests in 51 | ;; ert-tests.el. Some of these are tricky due to the bootstrapping 52 | ;; problem of writing tests for a testing tool, others test simple 53 | ;; functions and are straightforward. 54 | 55 | ;;; Code: 56 | 57 | (eval-when-compile 58 | (require 'cl)) 59 | (require 'button) 60 | (require 'debug) 61 | (require 'easymenu) 62 | (require 'ewoc) 63 | (require 'find-func) 64 | (require 'help) 65 | 66 | 67 | ;;; UI customization options. 68 | 69 | (defgroup ert () 70 | "ERT, the Emacs Lisp regression testing tool." 71 | :prefix "ert-" 72 | :group 'lisp) 73 | 74 | (defface ert-test-result-expected '((((class color) (background light)) 75 | :background "green1") 76 | (((class color) (background dark)) 77 | :background "green3")) 78 | "Face used for expected results in the ERT results buffer." 79 | :group 'ert) 80 | 81 | (defface ert-test-result-unexpected '((((class color) (background light)) 82 | :background "red1") 83 | (((class color) (background dark)) 84 | :background "red3")) 85 | "Face used for unexpected results in the ERT results buffer." 86 | :group 'ert) 87 | 88 | 89 | ;;; Copies/reimplementations of cl functions. 90 | 91 | (defun ert--cl-do-remf (plist tag) 92 | "Copy of `cl-do-remf'. Modify PLIST by removing TAG." 93 | (let ((p (cdr plist))) 94 | (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p)))) 95 | (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t)))) 96 | 97 | (defun ert--remprop (sym tag) 98 | "Copy of `cl-remprop'. Modify SYM's plist by removing TAG." 99 | (let ((plist (symbol-plist sym))) 100 | (if (and plist (eq tag (car plist))) 101 | (progn (setplist sym (cdr (cdr plist))) t) 102 | (ert--cl-do-remf plist tag)))) 103 | 104 | (defun ert--remove-if-not (ert-pred ert-list) 105 | "A reimplementation of `remove-if-not'. 106 | 107 | ERT-PRED is a predicate, ERT-LIST is the input list." 108 | (loop for ert-x in ert-list 109 | if (funcall ert-pred ert-x) 110 | collect ert-x)) 111 | 112 | (defun ert--intersection (a b) 113 | "A reimplementation of `intersection'. Intersect the sets A and B. 114 | 115 | Elements are compared using `eql'." 116 | (loop for x in a 117 | if (memql x b) 118 | collect x)) 119 | 120 | (defun ert--set-difference (a b) 121 | "A reimplementation of `set-difference'. Subtract the set B from the set A. 122 | 123 | Elements are compared using `eql'." 124 | (loop for x in a 125 | unless (memql x b) 126 | collect x)) 127 | 128 | (defun ert--set-difference-eq (a b) 129 | "A reimplementation of `set-difference'. Subtract the set B from the set A. 130 | 131 | Elements are compared using `eq'." 132 | (loop for x in a 133 | unless (memq x b) 134 | collect x)) 135 | 136 | (defun ert--union (a b) 137 | "A reimplementation of `union'. Compute the union of the sets A and B. 138 | 139 | Elements are compared using `eql'." 140 | (append a (ert--set-difference b a))) 141 | 142 | (eval-and-compile 143 | (defvar ert--gensym-counter 0)) 144 | 145 | (eval-and-compile 146 | (defun ert--gensym (&optional prefix) 147 | "Only allows string PREFIX, not compatible with CL." 148 | (unless prefix (setq prefix "G")) 149 | (make-symbol (format "%s%s" 150 | prefix 151 | (prog1 ert--gensym-counter 152 | (incf ert--gensym-counter)))))) 153 | 154 | (defun ert--coerce-to-vector (x) 155 | "Coerce X to a vector." 156 | (when (char-table-p x) (error "Not supported")) 157 | (if (vectorp x) 158 | x 159 | (vconcat x))) 160 | 161 | (defun* ert--remove* (x list &key key test) 162 | "Does not support all the keywords of remove*." 163 | (unless key (setq key #'identity)) 164 | (unless test (setq test #'eql)) 165 | (loop for y in list 166 | unless (funcall test x (funcall key y)) 167 | collect y)) 168 | 169 | (defun ert--string-position (c s) 170 | "Return the position of the first occurrence of C in S, or nil if none." 171 | (loop for i from 0 172 | for x across s 173 | when (eql x c) return i)) 174 | 175 | (defun ert--mismatch (a b) 176 | "Return index of first element that differs between A and B. 177 | 178 | Like `mismatch'. Uses `equal' for comparison." 179 | (cond ((or (listp a) (listp b)) 180 | (ert--mismatch (ert--coerce-to-vector a) 181 | (ert--coerce-to-vector b))) 182 | ((> (length a) (length b)) 183 | (ert--mismatch b a)) 184 | (t 185 | (let ((la (length a)) 186 | (lb (length b))) 187 | (assert (arrayp a) t) 188 | (assert (arrayp b) t) 189 | (assert (<= la lb) t) 190 | (loop for i below la 191 | when (not (equal (aref a i) (aref b i))) return i 192 | finally (return (if (/= la lb) 193 | la 194 | (assert (equal a b) t) 195 | nil))))))) 196 | 197 | (defun ert--subseq (seq start &optional end) 198 | "Return a subsequence of SEQ from START to END." 199 | (when (char-table-p seq) (error "Not supported")) 200 | (let ((vector (substring (ert--coerce-to-vector seq) start end))) 201 | (etypecase seq 202 | (vector vector) 203 | (string (concat vector)) 204 | (list (append vector nil)) 205 | (bool-vector (loop with result = (make-bool-vector (length vector) nil) 206 | for i below (length vector) do 207 | (setf (aref result i) (aref vector i)) 208 | finally (return result))) 209 | (char-table (assert nil))))) 210 | 211 | (defun ert-equal-including-properties (a b) 212 | "Return t if A and B have similar structure and contents. 213 | 214 | This is like `equal-including-properties' except that it compares 215 | the property values of text properties structurally (by 216 | recursing) rather than with `eq'. Perhaps this is what 217 | `equal-including-properties' should do in the first place; see 218 | Emacs bug 6581 at URL `http://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'." 219 | ;; This implementation is inefficient. Rather than making it 220 | ;; efficient, let's hope bug 6581 gets fixed so that we can delete 221 | ;; it altogether. 222 | (not (ert--explain-not-equal-including-properties a b))) 223 | 224 | 225 | ;;; Defining and locating tests. 226 | 227 | ;; The data structure that represents a test case. 228 | (defstruct ert-test 229 | (name nil) 230 | (documentation nil) 231 | (body (assert nil)) 232 | (most-recent-result nil) 233 | (expected-result-type ':passed) 234 | (tags '())) 235 | 236 | (defun ert-test-boundp (symbol) 237 | "Return non-nil if SYMBOL names a test." 238 | (and (get symbol 'ert--test) t)) 239 | 240 | (defun ert-get-test (symbol) 241 | "If SYMBOL names a test, return that. Signal an error otherwise." 242 | (unless (ert-test-boundp symbol) (error "No test named `%S'" symbol)) 243 | (get symbol 'ert--test)) 244 | 245 | (defun ert-set-test (symbol definition) 246 | "Make SYMBOL name the test DEFINITION, and return DEFINITION." 247 | (when (eq symbol 'nil) 248 | ;; We disallow nil since `ert-test-at-point' and related functions 249 | ;; want to return a test name, but also need an out-of-band value 250 | ;; on failure. Nil is the most natural out-of-band value; using 0 251 | ;; or "" or signalling an error would be too awkward. 252 | ;; 253 | ;; Note that nil is still a valid value for the `name' slot in 254 | ;; ert-test objects. It designates an anonymous test. 255 | (error "Attempt to define a test named nil")) 256 | (put symbol 'ert--test definition) 257 | definition) 258 | 259 | (defun ert-make-test-unbound (symbol) 260 | "Make SYMBOL name no test. Return SYMBOL." 261 | (ert--remprop symbol 'ert--test) 262 | symbol) 263 | 264 | (defun ert--parse-keys-and-body (keys-and-body) 265 | "Split KEYS-AND-BODY into keyword-and-value pairs and the remaining body. 266 | 267 | KEYS-AND-BODY should have the form of a property list, with the 268 | exception that only keywords are permitted as keys and that the 269 | tail -- the body -- is a list of forms that does not start with a 270 | keyword. 271 | 272 | Returns a two-element list containing the keys-and-values plist 273 | and the body." 274 | (let ((extracted-key-accu '()) 275 | (remaining keys-and-body)) 276 | (while (and (consp remaining) (keywordp (first remaining))) 277 | (let ((keyword (pop remaining))) 278 | (unless (consp remaining) 279 | (error "Value expected after keyword %S in %S" 280 | keyword keys-and-body)) 281 | (when (assoc keyword extracted-key-accu) 282 | (warn "Keyword %S appears more than once in %S" keyword 283 | keys-and-body)) 284 | (push (cons keyword (pop remaining)) extracted-key-accu))) 285 | (setq extracted-key-accu (nreverse extracted-key-accu)) 286 | (list (loop for (key . value) in extracted-key-accu 287 | collect key 288 | collect value) 289 | remaining))) 290 | 291 | ;;;###autoload 292 | (defmacro* ert-deftest (name () &body docstring-keys-and-body) 293 | "Define NAME (a symbol) as a test. 294 | 295 | BODY is evaluated as a `progn' when the test is run. It should 296 | signal a condition on failure or just return if the test passes. 297 | 298 | `should', `should-not' and `should-error' are useful for 299 | assertions in BODY. 300 | 301 | Use `ert' to run tests interactively. 302 | 303 | Tests that are expected to fail can be marked as such 304 | using :expected-result. See `ert-test-result-type-p' for a 305 | description of valid values for RESULT-TYPE. 306 | 307 | \(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \ 308 | \[:tags '(TAG...)] BODY...)" 309 | (declare (debug (&define :name test 310 | name sexp [&optional stringp] 311 | [&rest keywordp sexp] def-body)) 312 | (doc-string 3) 313 | (indent 2)) 314 | (let ((documentation nil) 315 | (documentation-supplied-p nil)) 316 | (when (stringp (first docstring-keys-and-body)) 317 | (setq documentation (pop docstring-keys-and-body) 318 | documentation-supplied-p t)) 319 | (destructuring-bind ((&key (expected-result nil expected-result-supplied-p) 320 | (tags nil tags-supplied-p)) 321 | body) 322 | (ert--parse-keys-and-body docstring-keys-and-body) 323 | `(progn 324 | (ert-set-test ',name 325 | (make-ert-test 326 | :name ',name 327 | ,@(when documentation-supplied-p 328 | `(:documentation ,documentation)) 329 | ,@(when expected-result-supplied-p 330 | `(:expected-result-type ,expected-result)) 331 | ,@(when tags-supplied-p 332 | `(:tags ,tags)) 333 | :body (lambda () ,@body))) 334 | ;; This hack allows `symbol-file' to associate `ert-deftest' 335 | ;; forms with files, and therefore enables `find-function' to 336 | ;; work with tests. However, it leads to warnings in 337 | ;; `unload-feature', which doesn't know how to undefine tests 338 | ;; and has no mechanism for extension. 339 | (push '(ert-deftest . ,name) current-load-list) 340 | ',name)))) 341 | 342 | ;; We use these `put' forms in addition to the (declare (indent)) in 343 | ;; the defmacro form since the `declare' alone does not lead to 344 | ;; correct indentation before the .el/.elc file is loaded. 345 | ;; Autoloading these `put' forms solves this. 346 | ;;;###autoload 347 | (progn 348 | ;; TODO(ohler): Figure out what these mean and make sure they are correct. 349 | (put 'ert-deftest 'lisp-indent-function 2) 350 | (put 'ert-info 'lisp-indent-function 1)) 351 | 352 | (defvar ert--find-test-regexp 353 | (concat "^\\s-*(ert-deftest" 354 | find-function-space-re 355 | "%s\\(\\s-\\|$\\)") 356 | "The regexp the `find-function' mechanisms use for finding test definitions.") 357 | 358 | 359 | (put 'ert-test-failed 'error-conditions '(error ert-test-failed)) 360 | (put 'ert-test-failed 'error-message "Test failed") 361 | 362 | (defun ert-pass () 363 | "Terminate the current test and mark it passed. Does not return." 364 | (throw 'ert--pass nil)) 365 | 366 | (defun ert-fail (data) 367 | "Terminate the current test and mark it failed. Does not return. 368 | DATA is displayed to the user and should state the reason of the failure." 369 | (signal 'ert-test-failed (list data))) 370 | 371 | 372 | ;;; The `should' macros. 373 | 374 | (defvar ert--should-execution-observer nil) 375 | 376 | (defun ert--signal-should-execution (form-description) 377 | "Tell the current `should' form observer (if any) about FORM-DESCRIPTION." 378 | (when ert--should-execution-observer 379 | (funcall ert--should-execution-observer form-description))) 380 | 381 | (defun ert--special-operator-p (thing) 382 | "Return non-nil if THING is a symbol naming a special operator." 383 | (and (symbolp thing) 384 | (let ((definition (indirect-function thing t))) 385 | (and (subrp definition) 386 | (eql (cdr (subr-arity definition)) 'unevalled))))) 387 | 388 | (defun ert--expand-should-1 (whole form inner-expander) 389 | "Helper function for the `should' macro and its variants." 390 | (let ((form 391 | ;; If `cl-macroexpand' isn't bound, the code that we're 392 | ;; compiling doesn't depend on cl and thus doesn't need an 393 | ;; environment arg for `macroexpand'. 394 | (if (fboundp 'cl-macroexpand) 395 | ;; Suppress warning about run-time call to cl funtion: we 396 | ;; only call it if it's fboundp. 397 | (with-no-warnings 398 | (cl-macroexpand form (and (boundp 'cl-macro-environment) 399 | cl-macro-environment))) 400 | (macroexpand form)))) 401 | (cond 402 | ((or (atom form) (ert--special-operator-p (car form))) 403 | (let ((value (ert--gensym "value-"))) 404 | `(let ((,value (ert--gensym "ert-form-evaluation-aborted-"))) 405 | ,(funcall inner-expander 406 | `(setq ,value ,form) 407 | `(list ',whole :form ',form :value ,value) 408 | value) 409 | ,value))) 410 | (t 411 | (let ((fn-name (car form)) 412 | (arg-forms (cdr form))) 413 | (assert (or (symbolp fn-name) 414 | (and (consp fn-name) 415 | (eql (car fn-name) 'lambda) 416 | (listp (cdr fn-name))))) 417 | (let ((fn (ert--gensym "fn-")) 418 | (args (ert--gensym "args-")) 419 | (value (ert--gensym "value-")) 420 | (default-value (ert--gensym "ert-form-evaluation-aborted-"))) 421 | `(let ((,fn (function ,fn-name)) 422 | (,args (list ,@arg-forms))) 423 | (let ((,value ',default-value)) 424 | ,(funcall inner-expander 425 | `(setq ,value (apply ,fn ,args)) 426 | `(nconc (list ',whole) 427 | (list :form `(,,fn ,@,args)) 428 | (unless (eql ,value ',default-value) 429 | (list :value ,value)) 430 | (let ((-explainer- 431 | (and (symbolp ',fn-name) 432 | (get ',fn-name 'ert-explainer)))) 433 | (when -explainer- 434 | (list :explanation 435 | (apply -explainer- ,args))))) 436 | value) 437 | ,value)))))))) 438 | 439 | (defun ert--expand-should (whole form inner-expander) 440 | "Helper function for the `should' macro and its variants. 441 | 442 | Analyzes FORM and returns an expression that has the same 443 | semantics under evaluation but records additional debugging 444 | information. 445 | 446 | INNER-EXPANDER should be a function and is called with two 447 | arguments: INNER-FORM and FORM-DESCRIPTION-FORM, where INNER-FORM 448 | is an expression equivalent to FORM, and FORM-DESCRIPTION-FORM is 449 | an expression that returns a description of FORM. INNER-EXPANDER 450 | should return code that calls INNER-FORM and performs the checks 451 | and error signalling specific to the particular variant of 452 | `should'. The code that INNER-EXPANDER returns must not call 453 | FORM-DESCRIPTION-FORM before it has called INNER-FORM." 454 | (lexical-let ((inner-expander inner-expander)) 455 | (ert--expand-should-1 456 | whole form 457 | (lambda (inner-form form-description-form value-var) 458 | (let ((form-description (ert--gensym "form-description-"))) 459 | `(let (,form-description) 460 | ,(funcall inner-expander 461 | `(unwind-protect 462 | ,inner-form 463 | (setq ,form-description ,form-description-form) 464 | (ert--signal-should-execution ,form-description)) 465 | `,form-description 466 | value-var))))))) 467 | 468 | (defmacro* should (form) 469 | "Evaluate FORM. If it returns nil, abort the current test as failed. 470 | 471 | Returns the value of FORM." 472 | (ert--expand-should `(should ,form) form 473 | (lambda (inner-form form-description-form value-var) 474 | `(unless ,inner-form 475 | (ert-fail ,form-description-form))))) 476 | 477 | (defmacro* should-not (form) 478 | "Evaluate FORM. If it returns non-nil, abort the current test as failed. 479 | 480 | Returns nil." 481 | (ert--expand-should `(should-not ,form) form 482 | (lambda (inner-form form-description-form value-var) 483 | `(unless (not ,inner-form) 484 | (ert-fail ,form-description-form))))) 485 | 486 | (defun ert--should-error-handle-error (form-description-fn 487 | condition type exclude-subtypes) 488 | "Helper function for `should-error'. 489 | 490 | Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES, 491 | and aborts the current test as failed if it doesn't." 492 | (let ((signalled-conditions (get (car condition) 'error-conditions)) 493 | (handled-conditions (etypecase type 494 | (list type) 495 | (symbol (list type))))) 496 | (assert signalled-conditions) 497 | (unless (ert--intersection signalled-conditions handled-conditions) 498 | (ert-fail (append 499 | (funcall form-description-fn) 500 | (list 501 | :condition condition 502 | :fail-reason (concat "the error signalled did not" 503 | " have the expected type"))))) 504 | (when exclude-subtypes 505 | (unless (member (car condition) handled-conditions) 506 | (ert-fail (append 507 | (funcall form-description-fn) 508 | (list 509 | :condition condition 510 | :fail-reason (concat "the error signalled was a subtype" 511 | " of the expected type")))))))) 512 | 513 | ;; FIXME: The expansion will evaluate the keyword args (if any) in 514 | ;; nonstandard order. 515 | (defmacro* should-error (form &rest keys &key type exclude-subtypes) 516 | "Evaluate FORM and check that it signals an error. 517 | 518 | The error signalled needs to match TYPE. TYPE should be a list 519 | of condition names. (It can also be a non-nil symbol, which is 520 | equivalent to a singleton list containing that symbol.) If 521 | EXCLUDE-SUBTYPES is nil, the error matches TYPE if one of its 522 | condition names is an element of TYPE. If EXCLUDE-SUBTYPES is 523 | non-nil, the error matches TYPE if it is an element of TYPE. 524 | 525 | If the error matches, returns (ERROR-SYMBOL . DATA) from the 526 | error. If not, or if no error was signalled, abort the test as 527 | failed." 528 | (unless type (setq type ''error)) 529 | (ert--expand-should 530 | `(should-error ,form ,@keys) 531 | form 532 | (lambda (inner-form form-description-form value-var) 533 | (let ((errorp (ert--gensym "errorp")) 534 | (form-description-fn (ert--gensym "form-description-fn-"))) 535 | `(let ((,errorp nil) 536 | (,form-description-fn (lambda () ,form-description-form))) 537 | (condition-case -condition- 538 | ,inner-form 539 | ;; We can't use ,type here because we want to evaluate it. 540 | (error 541 | (setq ,errorp t) 542 | (ert--should-error-handle-error ,form-description-fn 543 | -condition- 544 | ,type ,exclude-subtypes) 545 | (setq ,value-var -condition-))) 546 | (unless ,errorp 547 | (ert-fail (append 548 | (funcall ,form-description-fn) 549 | (list 550 | :fail-reason "did not signal an error"))))))))) 551 | 552 | 553 | ;;; Explanation of `should' failures. 554 | 555 | ;; TODO(ohler): Rework explanations so that they are displayed in a 556 | ;; similar way to `ert-info' messages; in particular, allow text 557 | ;; buttons in explanations that give more detail or open an ediff 558 | ;; buffer. Perhaps explanations should be reported through `ert-info' 559 | ;; rather than as part of the condition. 560 | 561 | (defun ert--proper-list-p (x) 562 | "Return non-nil if X is a proper list, nil otherwise." 563 | (loop 564 | for firstp = t then nil 565 | for fast = x then (cddr fast) 566 | for slow = x then (cdr slow) do 567 | (when (null fast) (return t)) 568 | (when (not (consp fast)) (return nil)) 569 | (when (null (cdr fast)) (return t)) 570 | (when (not (consp (cdr fast))) (return nil)) 571 | (when (and (not firstp) (eq fast slow)) (return nil)))) 572 | 573 | (defun ert--explain-format-atom (x) 574 | "Format the atom X for `ert--explain-not-equal'." 575 | (typecase x 576 | (fixnum (list x (format "#x%x" x) (format "?%c" x))) 577 | (t x))) 578 | 579 | (defun ert--explain-not-equal (a b) 580 | "Explainer function for `equal'. 581 | 582 | Returns a programmer-readable explanation of why A and B are not 583 | `equal', or nil if they are." 584 | (if (not (equal (type-of a) (type-of b))) 585 | `(different-types ,a ,b) 586 | (etypecase a 587 | (cons 588 | (let ((a-proper-p (ert--proper-list-p a)) 589 | (b-proper-p (ert--proper-list-p b))) 590 | (if (not (eql (not a-proper-p) (not b-proper-p))) 591 | `(one-list-proper-one-improper ,a ,b) 592 | (if a-proper-p 593 | (if (not (equal (length a) (length b))) 594 | `(proper-lists-of-different-length ,(length a) ,(length b) 595 | ,a ,b 596 | first-mismatch-at 597 | ,(ert--mismatch a b)) 598 | (loop for i from 0 599 | for ai in a 600 | for bi in b 601 | for xi = (ert--explain-not-equal ai bi) 602 | do (when xi (return `(list-elt ,i ,xi))) 603 | finally (assert (equal a b) t))) 604 | (let ((car-x (ert--explain-not-equal (car a) (car b)))) 605 | (if car-x 606 | `(car ,car-x) 607 | (let ((cdr-x (ert--explain-not-equal (cdr a) (cdr b)))) 608 | (if cdr-x 609 | `(cdr ,cdr-x) 610 | (assert (equal a b) t) 611 | nil)))))))) 612 | (array (if (not (equal (length a) (length b))) 613 | `(arrays-of-different-length ,(length a) ,(length b) 614 | ,a ,b 615 | ,@(unless (char-table-p a) 616 | `(first-mismatch-at 617 | ,(ert--mismatch a b)))) 618 | (loop for i from 0 619 | for ai across a 620 | for bi across b 621 | for xi = (ert--explain-not-equal ai bi) 622 | do (when xi (return `(array-elt ,i ,xi))) 623 | finally (assert (equal a b) t)))) 624 | (atom (if (not (equal a b)) 625 | (if (and (symbolp a) (symbolp b) (string= a b)) 626 | `(different-symbols-with-the-same-name ,a ,b) 627 | `(different-atoms ,(ert--explain-format-atom a) 628 | ,(ert--explain-format-atom b))) 629 | nil))))) 630 | (put 'equal 'ert-explainer 'ert--explain-not-equal) 631 | 632 | (defun ert--significant-plist-keys (plist) 633 | "Return the keys of PLIST that have non-null values, in order." 634 | (assert (zerop (mod (length plist) 2)) t) 635 | (loop for (key value . rest) on plist by #'cddr 636 | unless (or (null value) (memq key accu)) collect key into accu 637 | finally (return accu))) 638 | 639 | (defun ert--plist-difference-explanation (a b) 640 | "Return a programmer-readable explanation of why A and B are different plists. 641 | 642 | Returns nil if they are equivalent, i.e., have the same value for 643 | each key, where absent values are treated as nil. The order of 644 | key/value pairs in each list does not matter." 645 | (assert (zerop (mod (length a) 2)) t) 646 | (assert (zerop (mod (length b) 2)) t) 647 | ;; Normalizing the plists would be another way to do this but it 648 | ;; requires a total ordering on all lisp objects (since any object 649 | ;; is valid as a text property key). Perhaps defining such an 650 | ;; ordering is useful in other contexts, too, but it's a lot of 651 | ;; work, so let's punt on it for now. 652 | (let* ((keys-a (ert--significant-plist-keys a)) 653 | (keys-b (ert--significant-plist-keys b)) 654 | (keys-in-a-not-in-b (ert--set-difference-eq keys-a keys-b)) 655 | (keys-in-b-not-in-a (ert--set-difference-eq keys-b keys-a))) 656 | (flet ((explain-with-key (key) 657 | (let ((value-a (plist-get a key)) 658 | (value-b (plist-get b key))) 659 | (assert (not (equal value-a value-b)) t) 660 | `(different-properties-for-key 661 | ,key ,(ert--explain-not-equal-including-properties value-a 662 | value-b))))) 663 | (cond (keys-in-a-not-in-b 664 | (explain-with-key (first keys-in-a-not-in-b))) 665 | (keys-in-b-not-in-a 666 | (explain-with-key (first keys-in-b-not-in-a))) 667 | (t 668 | (loop for key in keys-a 669 | when (not (equal (plist-get a key) (plist-get b key))) 670 | return (explain-with-key key))))))) 671 | 672 | (defun ert--abbreviate-string (s len suffixp) 673 | "Shorten string S to at most LEN chars. 674 | 675 | If SUFFIXP is non-nil, returns a suffix of S, otherwise a prefix." 676 | (let ((n (length s))) 677 | (cond ((< n len) 678 | s) 679 | (suffixp 680 | (substring s (- n len))) 681 | (t 682 | (substring s 0 len))))) 683 | 684 | (defun ert--explain-not-equal-including-properties (a b) 685 | "Explainer function for `ert-equal-including-properties'. 686 | 687 | Returns a programmer-readable explanation of why A and B are not 688 | `ert-equal-including-properties', or nil if they are." 689 | (if (not (equal a b)) 690 | (ert--explain-not-equal a b) 691 | (assert (stringp a) t) 692 | (assert (stringp b) t) 693 | (assert (eql (length a) (length b)) t) 694 | (loop for i from 0 to (length a) 695 | for props-a = (text-properties-at i a) 696 | for props-b = (text-properties-at i b) 697 | for difference = (ert--plist-difference-explanation props-a props-b) 698 | do (when difference 699 | (return `(char ,i ,(substring-no-properties a i (1+ i)) 700 | ,difference 701 | context-before 702 | ,(ert--abbreviate-string 703 | (substring-no-properties a 0 i) 704 | 10 t) 705 | context-after 706 | ,(ert--abbreviate-string 707 | (substring-no-properties a (1+ i)) 708 | 10 nil)))) 709 | ;; TODO(ohler): Get `equal-including-properties' fixed in 710 | ;; Emacs, delete `ert-equal-including-properties', and 711 | ;; re-enable this assertion. 712 | ;;finally (assert (equal-including-properties a b) t) 713 | ))) 714 | (put 'ert-equal-including-properties 715 | 'ert-explainer 716 | 'ert--explain-not-equal-including-properties) 717 | 718 | 719 | ;;; Implementation of `ert-info'. 720 | 721 | ;; TODO(ohler): The name `info' clashes with 722 | ;; `ert--test-execution-info'. One or both should be renamed. 723 | (defvar ert--infos '() 724 | "The stack of `ert-info' infos that currently apply. 725 | 726 | Bound dynamically. This is a list of (PREFIX . MESSAGE) pairs.") 727 | 728 | (defmacro* ert-info ((message-form &key ((:prefix prefix-form) "Info: ")) 729 | &body body) 730 | "Evaluate MESSAGE-FORM and BODY, and report the message if BODY fails. 731 | 732 | To be used within ERT tests. MESSAGE-FORM should evaluate to a 733 | string that will be displayed together with the test result if 734 | the test fails. PREFIX-FORM should evaluate to a string as well 735 | and is displayed in front of the value of MESSAGE-FORM." 736 | (declare (debug ((form &rest [sexp form]) body)) 737 | (indent 1)) 738 | `(let ((ert--infos (cons (cons ,prefix-form ,message-form) ert--infos))) 739 | ,@body)) 740 | 741 | 742 | 743 | ;;; Facilities for running a single test. 744 | 745 | (defvar ert-debug-on-error nil 746 | "Non-nil means enter debugger when a test fails or terminates with an error.") 747 | 748 | ;; The data structures that represent the result of running a test. 749 | (defstruct ert-test-result 750 | (messages nil) 751 | (should-forms nil) 752 | ) 753 | (defstruct (ert-test-passed (:include ert-test-result))) 754 | (defstruct (ert-test-result-with-condition (:include ert-test-result)) 755 | (condition (assert nil)) 756 | (backtrace (assert nil)) 757 | (infos (assert nil))) 758 | (defstruct (ert-test-quit (:include ert-test-result-with-condition))) 759 | (defstruct (ert-test-failed (:include ert-test-result-with-condition))) 760 | (defstruct (ert-test-aborted-with-non-local-exit (:include ert-test-result))) 761 | 762 | 763 | (defun ert--record-backtrace () 764 | "Record the current backtrace (as a list) and return it." 765 | ;; Since the backtrace is stored in the result object, result 766 | ;; objects must only be printed with appropriate limits 767 | ;; (`print-level' and `print-length') in place. For interactive 768 | ;; use, the cost of ensuring this possibly outweighs the advantage 769 | ;; of storing the backtrace for 770 | ;; `ert-results-pop-to-backtrace-for-test-at-point' given that we 771 | ;; already have `ert-results-rerun-test-debugging-errors-at-point'. 772 | ;; For batch use, however, printing the backtrace may be useful. 773 | (loop 774 | ;; 6 is the number of frames our own debugger adds (when 775 | ;; compiled; more when interpreted). FIXME: Need to describe a 776 | ;; procedure for determining this constant. 777 | for i from 6 778 | for frame = (backtrace-frame i) 779 | while frame 780 | collect frame)) 781 | 782 | (defun ert--print-backtrace (backtrace) 783 | "Format the backtrace BACKTRACE to the current buffer." 784 | ;; This is essentially a reimplementation of Fbacktrace 785 | ;; (src/eval.c), but for a saved backtrace, not the current one. 786 | (let ((print-escape-newlines t) 787 | (print-level 8) 788 | (print-length 50)) 789 | (dolist (frame backtrace) 790 | (ecase (first frame) 791 | ((nil) 792 | ;; Special operator. 793 | (destructuring-bind (special-operator &rest arg-forms) 794 | (cdr frame) 795 | (insert 796 | (format " %S\n" (list* special-operator arg-forms))))) 797 | ((t) 798 | ;; Function call. 799 | (destructuring-bind (fn &rest args) (cdr frame) 800 | (insert (format " %S(" fn)) 801 | (loop for firstp = t then nil 802 | for arg in args do 803 | (unless firstp 804 | (insert " ")) 805 | (insert (format "%S" arg))) 806 | (insert ")\n"))))))) 807 | 808 | ;; A container for the state of the execution of a single test and 809 | ;; environment data needed during its execution. 810 | (defstruct ert--test-execution-info 811 | (test (assert nil)) 812 | (result (assert nil)) 813 | ;; A thunk that may be called when RESULT has been set to its final 814 | ;; value and test execution should be terminated. Should not 815 | ;; return. 816 | (exit-continuation (assert nil)) 817 | ;; The binding of `debugger' outside of the execution of the test. 818 | next-debugger 819 | ;; The binding of `ert-debug-on-error' that is in effect for the 820 | ;; execution of the current test. We store it to avoid being 821 | ;; affected by any new bindings the test itself may establish. (I 822 | ;; don't remember whether this feature is important.) 823 | ert-debug-on-error) 824 | 825 | (defun ert--run-test-debugger (info debugger-args) 826 | "During a test run, `debugger' is bound to a closure that calls this function. 827 | 828 | This function records failures and errors and either terminates 829 | the test silently or calls the interactive debugger, as 830 | appropriate. 831 | 832 | INFO is the ert--test-execution-info corresponding to this test 833 | run. DEBUGGER-ARGS are the arguments to `debugger'." 834 | (destructuring-bind (first-debugger-arg &rest more-debugger-args) 835 | debugger-args 836 | (ecase first-debugger-arg 837 | ((lambda debug t exit nil) 838 | (apply (ert--test-execution-info-next-debugger info) debugger-args)) 839 | (error 840 | (let* ((condition (first more-debugger-args)) 841 | (type (case (car condition) 842 | ((quit) 'quit) 843 | (otherwise 'failed))) 844 | (backtrace (ert--record-backtrace)) 845 | (infos (reverse ert--infos))) 846 | (setf (ert--test-execution-info-result info) 847 | (ecase type 848 | (quit 849 | (make-ert-test-quit :condition condition 850 | :backtrace backtrace 851 | :infos infos)) 852 | (failed 853 | (make-ert-test-failed :condition condition 854 | :backtrace backtrace 855 | :infos infos)))) 856 | ;; Work around Emacs' heuristic (in eval.c) for detecting 857 | ;; errors in the debugger. 858 | (incf num-nonmacro-input-events) 859 | ;; FIXME: We should probably implement more fine-grained 860 | ;; control a la non-t `debug-on-error' here. 861 | (cond 862 | ((ert--test-execution-info-ert-debug-on-error info) 863 | (apply (ert--test-execution-info-next-debugger info) debugger-args)) 864 | (t)) 865 | (funcall (ert--test-execution-info-exit-continuation info))))))) 866 | 867 | (defun ert--run-test-internal (ert-test-execution-info) 868 | "Low-level function to run a test according to ERT-TEST-EXECUTION-INFO. 869 | 870 | This mainly sets up debugger-related bindings." 871 | (lexical-let ((info ert-test-execution-info)) 872 | (setf (ert--test-execution-info-next-debugger info) debugger 873 | (ert--test-execution-info-ert-debug-on-error info) ert-debug-on-error) 874 | (catch 'ert--pass 875 | ;; For now, each test gets its own temp buffer and its own 876 | ;; window excursion, just to be safe. If this turns out to be 877 | ;; too expensive, we can remove it. 878 | (with-temp-buffer 879 | (save-window-excursion 880 | (let ((debugger (lambda (&rest debugger-args) 881 | (ert--run-test-debugger info debugger-args))) 882 | (debug-on-error t) 883 | (debug-on-quit t) 884 | ;; FIXME: Do we need to store the old binding of this 885 | ;; and consider it in `ert--run-test-debugger'? 886 | (debug-ignored-errors nil) 887 | (ert--infos '())) 888 | (funcall (ert-test-body (ert--test-execution-info-test info)))))) 889 | (ert-pass)) 890 | (setf (ert--test-execution-info-result info) (make-ert-test-passed))) 891 | nil) 892 | 893 | (defun ert--force-message-log-buffer-truncation () 894 | "Immediately truncate *Messages* buffer according to `message-log-max'. 895 | 896 | This can be useful after reducing the value of `message-log-max'." 897 | (with-current-buffer (get-buffer-create "*Messages*") 898 | ;; This is a reimplementation of this part of message_dolog() in xdisp.c: 899 | ;; if (NATNUMP (Vmessage_log_max)) 900 | ;; { 901 | ;; scan_newline (Z, Z_BYTE, BEG, BEG_BYTE, 902 | ;; -XFASTINT (Vmessage_log_max) - 1, 0); 903 | ;; del_range_both (BEG, BEG_BYTE, PT, PT_BYTE, 0); 904 | ;; } 905 | (when (and (integerp message-log-max) (>= message-log-max 0)) 906 | (let ((begin (point-min)) 907 | (end (save-excursion 908 | (goto-char (point-max)) 909 | (forward-line (- message-log-max)) 910 | (point)))) 911 | (delete-region begin end))))) 912 | 913 | (defvar ert--running-tests nil 914 | "List of tests that are currently in execution. 915 | 916 | This list is empty while no test is running, has one element 917 | while a test is running, two elements while a test run from 918 | inside a test is running, etc. The list is in order of nesting, 919 | innermost test first. 920 | 921 | The elements are of type `ert-test'.") 922 | 923 | (defun ert-run-test (ert-test) 924 | "Run ERT-TEST. 925 | 926 | Returns the result and stores it in ERT-TEST's `most-recent-result' slot." 927 | (setf (ert-test-most-recent-result ert-test) nil) 928 | (block error 929 | (lexical-let ((begin-marker 930 | (with-current-buffer (get-buffer-create "*Messages*") 931 | (set-marker (make-marker) (point-max))))) 932 | (unwind-protect 933 | (lexical-let ((info (make-ert--test-execution-info 934 | :test ert-test 935 | :result 936 | (make-ert-test-aborted-with-non-local-exit) 937 | :exit-continuation (lambda () 938 | (return-from error nil)))) 939 | (should-form-accu (list))) 940 | (unwind-protect 941 | (let ((ert--should-execution-observer 942 | (lambda (form-description) 943 | (push form-description should-form-accu))) 944 | (message-log-max t) 945 | (ert--running-tests (cons ert-test ert--running-tests))) 946 | (ert--run-test-internal info)) 947 | (let ((result (ert--test-execution-info-result info))) 948 | (setf (ert-test-result-messages result) 949 | (with-current-buffer (get-buffer-create "*Messages*") 950 | (buffer-substring begin-marker (point-max)))) 951 | (ert--force-message-log-buffer-truncation) 952 | (setq should-form-accu (nreverse should-form-accu)) 953 | (setf (ert-test-result-should-forms result) 954 | should-form-accu) 955 | (setf (ert-test-most-recent-result ert-test) result)))) 956 | (set-marker begin-marker nil)))) 957 | (ert-test-most-recent-result ert-test)) 958 | 959 | (defun ert-running-test () 960 | "Return the top-level test currently executing." 961 | (car (last ert--running-tests))) 962 | 963 | 964 | ;;; Test selectors. 965 | 966 | (defun ert-test-result-type-p (result result-type) 967 | "Return non-nil if RESULT matches type RESULT-TYPE. 968 | 969 | Valid result types: 970 | 971 | nil -- Never matches. 972 | t -- Always matches. 973 | :failed, :passed -- Matches corresponding results. 974 | \(and TYPES...\) -- Matches if all TYPES match. 975 | \(or TYPES...\) -- Matches if some TYPES match. 976 | \(not TYPE\) -- Matches if TYPE does not match. 977 | \(satisfies PREDICATE\) -- Matches if PREDICATE returns true when called with 978 | RESULT." 979 | ;; It would be easy to add `member' and `eql' types etc., but I 980 | ;; haven't bothered yet. 981 | (etypecase result-type 982 | ((member nil) nil) 983 | ((member t) t) 984 | ((member :failed) (ert-test-failed-p result)) 985 | ((member :passed) (ert-test-passed-p result)) 986 | (cons 987 | (destructuring-bind (operator &rest operands) result-type 988 | (ecase operator 989 | (and 990 | (case (length operands) 991 | (0 t) 992 | (t 993 | (and (ert-test-result-type-p result (first operands)) 994 | (ert-test-result-type-p result `(and ,@(rest operands))))))) 995 | (or 996 | (case (length operands) 997 | (0 nil) 998 | (t 999 | (or (ert-test-result-type-p result (first operands)) 1000 | (ert-test-result-type-p result `(or ,@(rest operands))))))) 1001 | (not 1002 | (assert (eql (length operands) 1)) 1003 | (not (ert-test-result-type-p result (first operands)))) 1004 | (satisfies 1005 | (assert (eql (length operands) 1)) 1006 | (funcall (first operands) result))))))) 1007 | 1008 | (defun ert-test-result-expected-p (test result) 1009 | "Return non-nil if TEST's expected result type matches RESULT." 1010 | (ert-test-result-type-p result (ert-test-expected-result-type test))) 1011 | 1012 | (defun ert-select-tests (selector universe) 1013 | "Return the tests that match SELECTOR. 1014 | 1015 | UNIVERSE specifies the set of tests to select from; it should be 1016 | a list of tests, or t, which refers to all tests named by symbols 1017 | in `obarray'. 1018 | 1019 | Returns the set of tests as a list. 1020 | 1021 | Valid selectors: 1022 | 1023 | nil -- Selects the empty set. 1024 | t -- Selects UNIVERSE. 1025 | :new -- Selects all tests that have not been run yet. 1026 | :failed, :passed -- Select tests according to their most recent result. 1027 | :expected, :unexpected -- Select tests according to their most recent result. 1028 | a string -- Selects all tests that have a name that matches the string, 1029 | a regexp. 1030 | a test -- Selects that test. 1031 | a symbol -- Selects the test that the symbol names, errors if none. 1032 | \(member TESTS...\) -- Selects TESTS, a list of tests or symbols naming tests. 1033 | \(eql TEST\) -- Selects TEST, a test or a symbol naming a test. 1034 | \(and SELECTORS...\) -- Selects the tests that match all SELECTORS. 1035 | \(or SELECTORS...\) -- Selects the tests that match any SELECTOR. 1036 | \(not SELECTOR\) -- Selects all tests that do not match SELECTOR. 1037 | \(tag TAG) -- Selects all tests that have TAG on their tags list. 1038 | \(satisfies PREDICATE\) -- Selects all tests that satisfy PREDICATE. 1039 | 1040 | Only selectors that require a superset of tests, such 1041 | as (satisfies ...), strings, :new, etc. make use of UNIVERSE. 1042 | Selectors that do not, such as \(member ...\), just return the 1043 | set implied by them without checking whether it is really 1044 | contained in UNIVERSE." 1045 | ;; This code needs to match the etypecase in 1046 | ;; `ert-insert-human-readable-selector'. 1047 | (etypecase selector 1048 | ((member nil) nil) 1049 | ((member t) (etypecase universe 1050 | (list universe) 1051 | ((member t) (ert-select-tests "" universe)))) 1052 | ((member :new) (ert-select-tests 1053 | `(satisfies ,(lambda (test) 1054 | (null (ert-test-most-recent-result test)))) 1055 | universe)) 1056 | ((member :failed) (ert-select-tests 1057 | `(satisfies ,(lambda (test) 1058 | (ert-test-result-type-p 1059 | (ert-test-most-recent-result test) 1060 | ':failed))) 1061 | universe)) 1062 | ((member :passed) (ert-select-tests 1063 | `(satisfies ,(lambda (test) 1064 | (ert-test-result-type-p 1065 | (ert-test-most-recent-result test) 1066 | ':passed))) 1067 | universe)) 1068 | ((member :expected) (ert-select-tests 1069 | `(satisfies 1070 | ,(lambda (test) 1071 | (ert-test-result-expected-p 1072 | test 1073 | (ert-test-most-recent-result test)))) 1074 | universe)) 1075 | ((member :unexpected) (ert-select-tests `(not :expected) universe)) 1076 | (string 1077 | (etypecase universe 1078 | ((member t) (mapcar #'ert-get-test 1079 | (apropos-internal selector #'ert-test-boundp))) 1080 | (list (ert--remove-if-not (lambda (test) 1081 | (and (ert-test-name test) 1082 | (string-match selector 1083 | (ert-test-name test)))) 1084 | universe)))) 1085 | (ert-test (list selector)) 1086 | (symbol 1087 | (assert (ert-test-boundp selector)) 1088 | (list (ert-get-test selector))) 1089 | (cons 1090 | (destructuring-bind (operator &rest operands) selector 1091 | (ecase operator 1092 | (member 1093 | (mapcar (lambda (purported-test) 1094 | (etypecase purported-test 1095 | (symbol (assert (ert-test-boundp purported-test)) 1096 | (ert-get-test purported-test)) 1097 | (ert-test purported-test))) 1098 | operands)) 1099 | (eql 1100 | (assert (eql (length operands) 1)) 1101 | (ert-select-tests `(member ,@operands) universe)) 1102 | (and 1103 | ;; Do these definitions of AND, NOT and OR satisfy de 1104 | ;; Morgan's laws? Should they? 1105 | (case (length operands) 1106 | (0 (ert-select-tests 't universe)) 1107 | (t (ert-select-tests `(and ,@(rest operands)) 1108 | (ert-select-tests (first operands) 1109 | universe))))) 1110 | (not 1111 | (assert (eql (length operands) 1)) 1112 | (let ((all-tests (ert-select-tests 't universe))) 1113 | (ert--set-difference all-tests 1114 | (ert-select-tests (first operands) 1115 | all-tests)))) 1116 | (or 1117 | (case (length operands) 1118 | (0 (ert-select-tests 'nil universe)) 1119 | (t (ert--union (ert-select-tests (first operands) universe) 1120 | (ert-select-tests `(or ,@(rest operands)) 1121 | universe))))) 1122 | (tag 1123 | (assert (eql (length operands) 1)) 1124 | (let ((tag (first operands))) 1125 | (ert-select-tests `(satisfies 1126 | ,(lambda (test) 1127 | (member tag (ert-test-tags test)))) 1128 | universe))) 1129 | (satisfies 1130 | (assert (eql (length operands) 1)) 1131 | (ert--remove-if-not (first operands) 1132 | (ert-select-tests 't universe)))))))) 1133 | 1134 | (defun ert--insert-human-readable-selector (selector) 1135 | "Insert a human-readable presentation of SELECTOR into the current buffer." 1136 | ;; This is needed to avoid printing the (huge) contents of the 1137 | ;; `backtrace' slot of the result objects in the 1138 | ;; `most-recent-result' slots of test case objects in (eql ...) or 1139 | ;; (member ...) selectors. 1140 | (labels ((rec (selector) 1141 | ;; This code needs to match the etypecase in `ert-select-tests'. 1142 | (etypecase selector 1143 | ((or (member nil t 1144 | :new :failed :passed 1145 | :expected :unexpected) 1146 | string 1147 | symbol) 1148 | selector) 1149 | (ert-test 1150 | (if (ert-test-name selector) 1151 | (make-symbol (format "<%S>" (ert-test-name selector))) 1152 | (make-symbol ""))) 1153 | (cons 1154 | (destructuring-bind (operator &rest operands) selector 1155 | (ecase operator 1156 | ((member eql and not or) 1157 | `(,operator ,@(mapcar #'rec operands))) 1158 | ((member tag satisfies) 1159 | selector))))))) 1160 | (insert (format "%S" (rec selector))))) 1161 | 1162 | 1163 | ;;; Facilities for running a whole set of tests. 1164 | 1165 | ;; The data structure that contains the set of tests being executed 1166 | ;; during one particular test run, their results, the state of the 1167 | ;; execution, and some statistics. 1168 | ;; 1169 | ;; The data about results and expected results of tests may seem 1170 | ;; redundant here, since the test objects also carry such information. 1171 | ;; However, the information in the test objects may be more recent, it 1172 | ;; may correspond to a different test run. We need the information 1173 | ;; that corresponds to this run in order to be able to update the 1174 | ;; statistics correctly when a test is re-run interactively and has a 1175 | ;; different result than before. 1176 | (defstruct ert--stats 1177 | (selector (assert nil)) 1178 | ;; The tests, in order. 1179 | (tests (assert nil) :type vector) 1180 | ;; A map of test names (or the test objects themselves for unnamed 1181 | ;; tests) to indices into the `tests' vector. 1182 | (test-map (assert nil) :type hash-table) 1183 | ;; The results of the tests during this run, in order. 1184 | (test-results (assert nil) :type vector) 1185 | ;; The start times of the tests, in order, as reported by 1186 | ;; `current-time'. 1187 | (test-start-times (assert nil) :type vector) 1188 | ;; The end times of the tests, in order, as reported by 1189 | ;; `current-time'. 1190 | (test-end-times (assert nil) :type vector) 1191 | (passed-expected 0) 1192 | (passed-unexpected 0) 1193 | (failed-expected 0) 1194 | (failed-unexpected 0) 1195 | (start-time nil) 1196 | (end-time nil) 1197 | (aborted-p nil) 1198 | (current-test nil) 1199 | ;; The time at or after which the next redisplay should occur, as a 1200 | ;; float. 1201 | (next-redisplay 0.0)) 1202 | 1203 | (defun ert-stats-completed-expected (stats) 1204 | "Return the number of tests in STATS that had expected results." 1205 | (+ (ert--stats-passed-expected stats) 1206 | (ert--stats-failed-expected stats))) 1207 | 1208 | (defun ert-stats-completed-unexpected (stats) 1209 | "Return the number of tests in STATS that had unexpected results." 1210 | (+ (ert--stats-passed-unexpected stats) 1211 | (ert--stats-failed-unexpected stats))) 1212 | 1213 | (defun ert-stats-completed (stats) 1214 | "Number of tests in STATS that have run so far." 1215 | (+ (ert-stats-completed-expected stats) 1216 | (ert-stats-completed-unexpected stats))) 1217 | 1218 | (defun ert-stats-total (stats) 1219 | "Number of tests in STATS, regardless of whether they have run yet." 1220 | (length (ert--stats-tests stats))) 1221 | 1222 | ;; The stats object of the current run, dynamically bound. This is 1223 | ;; used for the mode line progress indicator. 1224 | (defvar ert--current-run-stats nil) 1225 | 1226 | (defun ert--stats-test-key (test) 1227 | "Return the key used for TEST in the test map of ert--stats objects. 1228 | 1229 | Returns the name of TEST if it has one, or TEST itself otherwise." 1230 | (or (ert-test-name test) test)) 1231 | 1232 | (defun ert--stats-set-test-and-result (stats pos test result) 1233 | "Change STATS by replacing the test at position POS with TEST and RESULT. 1234 | 1235 | Also changes the counters in STATS to match." 1236 | (let* ((tests (ert--stats-tests stats)) 1237 | (results (ert--stats-test-results stats)) 1238 | (old-test (aref tests pos)) 1239 | (map (ert--stats-test-map stats))) 1240 | (flet ((update (d) 1241 | (if (ert-test-result-expected-p (aref tests pos) 1242 | (aref results pos)) 1243 | (etypecase (aref results pos) 1244 | (ert-test-passed (incf (ert--stats-passed-expected stats) d)) 1245 | (ert-test-failed (incf (ert--stats-failed-expected stats) d)) 1246 | (null) 1247 | (ert-test-aborted-with-non-local-exit)) 1248 | (etypecase (aref results pos) 1249 | (ert-test-passed (incf (ert--stats-passed-unexpected stats) d)) 1250 | (ert-test-failed (incf (ert--stats-failed-unexpected stats) d)) 1251 | (null) 1252 | (ert-test-aborted-with-non-local-exit))))) 1253 | ;; Adjust counters to remove the result that is currently in stats. 1254 | (update -1) 1255 | ;; Put new test and result into stats. 1256 | (setf (aref tests pos) test 1257 | (aref results pos) result) 1258 | (remhash (ert--stats-test-key old-test) map) 1259 | (setf (gethash (ert--stats-test-key test) map) pos) 1260 | ;; Adjust counters to match new result. 1261 | (update +1) 1262 | nil))) 1263 | 1264 | (defun ert--make-stats (tests selector) 1265 | "Create a new `ert--stats' object for running TESTS. 1266 | 1267 | SELECTOR is the selector that was used to select TESTS." 1268 | (setq tests (ert--coerce-to-vector tests)) 1269 | (let ((map (make-hash-table :size (length tests)))) 1270 | (loop for i from 0 1271 | for test across tests 1272 | for key = (ert--stats-test-key test) do 1273 | (assert (not (gethash key map))) 1274 | (setf (gethash key map) i)) 1275 | (make-ert--stats :selector selector 1276 | :tests tests 1277 | :test-map map 1278 | :test-results (make-vector (length tests) nil) 1279 | :test-start-times (make-vector (length tests) nil) 1280 | :test-end-times (make-vector (length tests) nil)))) 1281 | 1282 | (defun ert-run-or-rerun-test (stats test listener) 1283 | ;; checkdoc-order: nil 1284 | "Run the single test TEST and record the result using STATS and LISTENER." 1285 | (let ((ert--current-run-stats stats) 1286 | (pos (ert--stats-test-pos stats test))) 1287 | (ert--stats-set-test-and-result stats pos test nil) 1288 | ;; Call listener after setting/before resetting 1289 | ;; (ert--stats-current-test stats); the listener might refresh the 1290 | ;; mode line display, and if the value is not set yet/any more 1291 | ;; during this refresh, the mode line will flicker unnecessarily. 1292 | (setf (ert--stats-current-test stats) test) 1293 | (funcall listener 'test-started stats test) 1294 | (setf (ert-test-most-recent-result test) nil) 1295 | (setf (aref (ert--stats-test-start-times stats) pos) (current-time)) 1296 | (unwind-protect 1297 | (ert-run-test test) 1298 | (setf (aref (ert--stats-test-end-times stats) pos) (current-time)) 1299 | (let ((result (ert-test-most-recent-result test))) 1300 | (ert--stats-set-test-and-result stats pos test result) 1301 | (funcall listener 'test-ended stats test result)) 1302 | (setf (ert--stats-current-test stats) nil)))) 1303 | 1304 | (defun ert-run-tests (selector listener) 1305 | "Run the tests specified by SELECTOR, sending progress updates to LISTENER." 1306 | (let* ((tests (ert-select-tests selector t)) 1307 | (stats (ert--make-stats tests selector))) 1308 | (setf (ert--stats-start-time stats) (current-time)) 1309 | (funcall listener 'run-started stats) 1310 | (let ((abortedp t)) 1311 | (unwind-protect 1312 | (let ((ert--current-run-stats stats)) 1313 | (force-mode-line-update) 1314 | (unwind-protect 1315 | (progn 1316 | (loop for test in tests do 1317 | (ert-run-or-rerun-test stats test listener)) 1318 | (setq abortedp nil)) 1319 | (setf (ert--stats-aborted-p stats) abortedp) 1320 | (setf (ert--stats-end-time stats) (current-time)) 1321 | (funcall listener 'run-ended stats abortedp))) 1322 | (force-mode-line-update)) 1323 | stats))) 1324 | 1325 | (defun ert--stats-test-pos (stats test) 1326 | ;; checkdoc-order: nil 1327 | "Return the position (index) of TEST in the run represented by STATS." 1328 | (gethash (ert--stats-test-key test) (ert--stats-test-map stats))) 1329 | 1330 | 1331 | ;;; Formatting functions shared across UIs. 1332 | 1333 | (defun ert--format-time-iso8601 (time) 1334 | "Format TIME in the variant of ISO 8601 used for timestamps in ERT." 1335 | (format-time-string "%Y-%m-%d %T%z" time)) 1336 | 1337 | (defun ert-char-for-test-result (result expectedp) 1338 | "Return a character that represents the test result RESULT. 1339 | 1340 | EXPECTEDP specifies whether the result was expected." 1341 | (let ((s (etypecase result 1342 | (ert-test-passed ".P") 1343 | (ert-test-failed "fF") 1344 | (null "--") 1345 | (ert-test-aborted-with-non-local-exit "aA")))) 1346 | (elt s (if expectedp 0 1)))) 1347 | 1348 | (defun ert-string-for-test-result (result expectedp) 1349 | "Return a string that represents the test result RESULT. 1350 | 1351 | EXPECTEDP specifies whether the result was expected." 1352 | (let ((s (etypecase result 1353 | (ert-test-passed '("passed" "PASSED")) 1354 | (ert-test-failed '("failed" "FAILED")) 1355 | (null '("unknown" "UNKNOWN")) 1356 | (ert-test-aborted-with-non-local-exit '("aborted" "ABORTED"))))) 1357 | (elt s (if expectedp 0 1)))) 1358 | 1359 | (defun ert--pp-with-indentation-and-newline (object) 1360 | "Pretty-print OBJECT, indenting it to the current column of point. 1361 | Ensures a final newline is inserted." 1362 | (let ((begin (point))) 1363 | (pp object (current-buffer)) 1364 | (unless (bolp) (insert "\n")) 1365 | (save-excursion 1366 | (goto-char begin) 1367 | (indent-sexp)))) 1368 | 1369 | (defun ert--insert-infos (result) 1370 | "Insert `ert-info' infos from RESULT into current buffer. 1371 | 1372 | RESULT must be an `ert-test-result-with-condition'." 1373 | (check-type result ert-test-result-with-condition) 1374 | (dolist (info (ert-test-result-with-condition-infos result)) 1375 | (destructuring-bind (prefix . message) info 1376 | (let ((begin (point)) 1377 | (indentation (make-string (+ (length prefix) 4) ?\s)) 1378 | (end nil)) 1379 | (unwind-protect 1380 | (progn 1381 | (insert message "\n") 1382 | (setq end (copy-marker (point))) 1383 | (goto-char begin) 1384 | (insert " " prefix) 1385 | (forward-line 1) 1386 | (while (< (point) end) 1387 | (insert indentation) 1388 | (forward-line 1))) 1389 | (when end (set-marker end nil))))))) 1390 | 1391 | 1392 | ;;; Running tests in batch mode. 1393 | 1394 | (defvar ert-batch-backtrace-right-margin 70 1395 | "*The maximum line length for printing backtraces in `ert-run-tests-batch'.") 1396 | 1397 | ;;;###autoload 1398 | (defun ert-run-tests-batch (&optional selector) 1399 | "Run the tests specified by SELECTOR, printing results to the terminal. 1400 | 1401 | SELECTOR works as described in `ert-select-tests', except if 1402 | SELECTOR is nil, in which case all tests rather than none will be 1403 | run; this makes the command line \"emacs -batch -l my-tests.el -f 1404 | ert-run-tests-batch-and-exit\" useful. 1405 | 1406 | Returns the stats object." 1407 | (unless selector (setq selector 't)) 1408 | (ert-run-tests 1409 | selector 1410 | (lambda (event-type &rest event-args) 1411 | (ecase event-type 1412 | (run-started 1413 | (destructuring-bind (stats) event-args 1414 | (message "Running %s tests (%s)" 1415 | (length (ert--stats-tests stats)) 1416 | (ert--format-time-iso8601 (ert--stats-start-time stats))))) 1417 | (run-ended 1418 | (destructuring-bind (stats abortedp) event-args 1419 | (let ((unexpected (ert-stats-completed-unexpected stats)) 1420 | (expected-failures (ert--stats-failed-expected stats))) 1421 | (message "\n%sRan %s tests, %s results as expected%s (%s)%s\n" 1422 | (if (not abortedp) 1423 | "" 1424 | "Aborted: ") 1425 | (ert-stats-total stats) 1426 | (ert-stats-completed-expected stats) 1427 | (if (zerop unexpected) 1428 | "" 1429 | (format ", %s unexpected" unexpected)) 1430 | (ert--format-time-iso8601 (ert--stats-end-time stats)) 1431 | (if (zerop expected-failures) 1432 | "" 1433 | (format "\n%s expected failures" expected-failures))) 1434 | (unless (zerop unexpected) 1435 | (message "%s unexpected results:" unexpected) 1436 | (loop for test across (ert--stats-tests stats) 1437 | for result = (ert-test-most-recent-result test) do 1438 | (when (not (ert-test-result-expected-p test result)) 1439 | (message "%9s %S" 1440 | (ert-string-for-test-result result nil) 1441 | (ert-test-name test)))) 1442 | (message "%s" ""))))) 1443 | (test-started 1444 | ) 1445 | (test-ended 1446 | (destructuring-bind (stats test result) event-args 1447 | (unless (ert-test-result-expected-p test result) 1448 | (etypecase result 1449 | (ert-test-passed 1450 | (message "Test %S passed unexpectedly" (ert-test-name test))) 1451 | (ert-test-result-with-condition 1452 | (message "Test %S backtrace:" (ert-test-name test)) 1453 | (with-temp-buffer 1454 | (ert--print-backtrace (ert-test-result-with-condition-backtrace 1455 | result)) 1456 | (goto-char (point-min)) 1457 | (while (not (eobp)) 1458 | (let ((start (point)) 1459 | (end (progn (end-of-line) (point)))) 1460 | (setq end (min end 1461 | (+ start ert-batch-backtrace-right-margin))) 1462 | (message "%s" (buffer-substring-no-properties 1463 | start end))) 1464 | (forward-line 1))) 1465 | (with-temp-buffer 1466 | (ert--insert-infos result) 1467 | (insert " ") 1468 | (let ((print-escape-newlines t) 1469 | (print-level 5) 1470 | (print-length 10)) 1471 | (let ((begin (point))) 1472 | (ert--pp-with-indentation-and-newline 1473 | (ert-test-result-with-condition-condition result)))) 1474 | (goto-char (1- (point-max))) 1475 | (assert (looking-at "\n")) 1476 | (delete-char 1) 1477 | (message "Test %S condition:" (ert-test-name test)) 1478 | (message "%s" (buffer-string)))) 1479 | (ert-test-aborted-with-non-local-exit 1480 | (message "Test %S aborted with non-local exit" 1481 | (ert-test-name test))))) 1482 | (let* ((max (prin1-to-string (length (ert--stats-tests stats)))) 1483 | (format-string (concat "%9s %" 1484 | (prin1-to-string (length max)) 1485 | "s/" max " %S"))) 1486 | (message format-string 1487 | (ert-string-for-test-result result 1488 | (ert-test-result-expected-p 1489 | test result)) 1490 | (1+ (ert--stats-test-pos stats test)) 1491 | (ert-test-name test))))))))) 1492 | 1493 | ;;;###autoload 1494 | (defun ert-run-tests-batch-and-exit (&optional selector) 1495 | "Like `ert-run-tests-batch', but exits Emacs when done. 1496 | 1497 | The exit status will be 0 if all test results were as expected, 1 1498 | on unexpected results, or 2 if the framework detected an error 1499 | outside of the tests (e.g. invalid SELECTOR or bug in the code 1500 | that runs the tests)." 1501 | (unwind-protect 1502 | (let ((stats (ert-run-tests-batch selector))) 1503 | (kill-emacs (if (zerop (ert-stats-completed-unexpected stats)) 0 1))) 1504 | (unwind-protect 1505 | (progn 1506 | (message "Error running tests") 1507 | (backtrace)) 1508 | (kill-emacs 2)))) 1509 | 1510 | 1511 | ;;; Utility functions for load/unload actions. 1512 | 1513 | (defun ert--activate-font-lock-keywords () 1514 | "Activate font-lock keywords for some of ERT's symbols." 1515 | (font-lock-add-keywords 1516 | nil 1517 | '(("(\\(\\\\s *\\(\\sw+\\)?" 1518 | (1 font-lock-keyword-face nil t) 1519 | (2 font-lock-function-name-face nil t))))) 1520 | 1521 | (defun* ert--remove-from-list (list-var element &key key test) 1522 | "Remove ELEMENT from the value of LIST-VAR if present. 1523 | 1524 | This can be used as an inverse of `add-to-list'." 1525 | (unless key (setq key #'identity)) 1526 | (unless test (setq test #'equal)) 1527 | (setf (symbol-value list-var) 1528 | (ert--remove* element 1529 | (symbol-value list-var) 1530 | :key key 1531 | :test test))) 1532 | 1533 | 1534 | ;;; Some basic interactive functions. 1535 | 1536 | (defun ert-read-test-name (prompt &optional default history 1537 | add-default-to-prompt) 1538 | "Read the name of a test and return it as a symbol. 1539 | 1540 | Prompt with PROMPT. If DEFAULT is a valid test name, use it as a 1541 | default. HISTORY is the history to use; see `completing-read'. 1542 | If ADD-DEFAULT-TO-PROMPT is non-nil, PROMPT will be modified to 1543 | include the default, if any. 1544 | 1545 | Signals an error if no test name was read." 1546 | (etypecase default 1547 | (string (let ((symbol (intern-soft default))) 1548 | (unless (and symbol (ert-test-boundp symbol)) 1549 | (setq default nil)))) 1550 | (symbol (setq default 1551 | (if (ert-test-boundp default) 1552 | (symbol-name default) 1553 | nil))) 1554 | (ert-test (setq default (ert-test-name default)))) 1555 | (when add-default-to-prompt 1556 | (setq prompt (if (null default) 1557 | (format "%s: " prompt) 1558 | (format "%s (default %s): " prompt default)))) 1559 | (let ((input (completing-read prompt obarray #'ert-test-boundp 1560 | t nil history default nil))) 1561 | ;; completing-read returns an empty string if default was nil and 1562 | ;; the user just hit enter. 1563 | (let ((sym (intern-soft input))) 1564 | (if (ert-test-boundp sym) 1565 | sym 1566 | (error "Input does not name a test"))))) 1567 | 1568 | (defun ert-read-test-name-at-point (prompt) 1569 | "Read the name of a test and return it as a symbol. 1570 | As a default, use the symbol at point, or the test at point if in 1571 | the ERT results buffer. Prompt with PROMPT, augmented with the 1572 | default (if any)." 1573 | (ert-read-test-name prompt (ert-test-at-point) nil t)) 1574 | 1575 | (defun ert-find-test-other-window (test-name) 1576 | "Find, in another window, the definition of TEST-NAME." 1577 | (interactive (list (ert-read-test-name-at-point "Find test definition: "))) 1578 | (find-function-do-it test-name 'ert-deftest 'switch-to-buffer-other-window)) 1579 | 1580 | (defun ert-delete-test (test-name) 1581 | "Make the test TEST-NAME unbound. 1582 | 1583 | Nothing more than an interactive interface to `ert-make-test-unbound'." 1584 | (interactive (list (ert-read-test-name-at-point "Delete test"))) 1585 | (ert-make-test-unbound test-name)) 1586 | 1587 | (defun ert-delete-all-tests () 1588 | "Make all symbols in `obarray' name no test." 1589 | (interactive) 1590 | (when (interactive-p) 1591 | (unless (y-or-n-p "Delete all tests? ") 1592 | (error "Aborted"))) 1593 | ;; We can't use `ert-select-tests' here since that gives us only 1594 | ;; test objects, and going from them back to the test name symbols 1595 | ;; can fail if the `ert-test' defstruct has been redefined. 1596 | (mapc #'ert-make-test-unbound (apropos-internal "" #'ert-test-boundp)) 1597 | t) 1598 | 1599 | 1600 | ;;; Display of test progress and results. 1601 | 1602 | ;; An entry in the results buffer ewoc. There is one entry per test. 1603 | (defstruct ert--ewoc-entry 1604 | (test (assert nil)) 1605 | ;; If the result of this test was expected, its ewoc entry is hidden 1606 | ;; initially. 1607 | (hidden-p (assert nil)) 1608 | ;; An ewoc entry may be collapsed to hide details such as the error 1609 | ;; condition. 1610 | ;; 1611 | ;; I'm not sure the ability to expand and collapse entries is still 1612 | ;; a useful feature. 1613 | (expanded-p t) 1614 | ;; By default, the ewoc entry presents the error condition with 1615 | ;; certain limits on how much to print (`print-level', 1616 | ;; `print-length'). The user can interactively switch to a set of 1617 | ;; higher limits. 1618 | (extended-printer-limits-p nil)) 1619 | 1620 | ;; Variables local to the results buffer. 1621 | 1622 | ;; The ewoc. 1623 | (defvar ert--results-ewoc) 1624 | ;; The stats object. 1625 | (defvar ert--results-stats) 1626 | ;; A string with one character per test. Each character represents 1627 | ;; the result of the corresponding test. The string is displayed near 1628 | ;; the top of the buffer and serves as a progress bar. 1629 | (defvar ert--results-progress-bar-string) 1630 | ;; The position where the progress bar button begins. 1631 | (defvar ert--results-progress-bar-button-begin) 1632 | ;; The test result listener that updates the buffer when tests are run. 1633 | (defvar ert--results-listener) 1634 | 1635 | (defun ert-insert-test-name-button (test-name) 1636 | "Insert a button that links to TEST-NAME." 1637 | (insert-text-button (format "%S" test-name) 1638 | :type 'ert--test-name-button 1639 | 'ert-test-name test-name)) 1640 | 1641 | (defun ert--results-format-expected-unexpected (expected unexpected) 1642 | "Return a string indicating EXPECTED expected results, UNEXPECTED unexpected." 1643 | (if (zerop unexpected) 1644 | (format "%s" expected) 1645 | (format "%s (%s unexpected)" (+ expected unexpected) unexpected))) 1646 | 1647 | (defun ert--results-update-ewoc-hf (ewoc stats) 1648 | "Update the header and footer of EWOC to show certain information from STATS. 1649 | 1650 | Also sets `ert--results-progress-bar-button-begin'." 1651 | (let ((run-count (ert-stats-completed stats)) 1652 | (results-buffer (current-buffer)) 1653 | ;; Need to save buffer-local value. 1654 | (font-lock font-lock-mode)) 1655 | (ewoc-set-hf 1656 | ewoc 1657 | ;; header 1658 | (with-temp-buffer 1659 | (insert "Selector: ") 1660 | (ert--insert-human-readable-selector (ert--stats-selector stats)) 1661 | (insert "\n") 1662 | (insert 1663 | (format (concat "Passed: %s\n" 1664 | "Failed: %s\n" 1665 | "Total: %s/%s\n\n") 1666 | (ert--results-format-expected-unexpected 1667 | (ert--stats-passed-expected stats) 1668 | (ert--stats-passed-unexpected stats)) 1669 | (ert--results-format-expected-unexpected 1670 | (ert--stats-failed-expected stats) 1671 | (ert--stats-failed-unexpected stats)) 1672 | run-count 1673 | (ert-stats-total stats))) 1674 | (insert 1675 | (format "Started at: %s\n" 1676 | (ert--format-time-iso8601 (ert--stats-start-time stats)))) 1677 | ;; FIXME: This is ugly. Need to properly define invariants of 1678 | ;; the `stats' data structure. 1679 | (let ((state (cond ((ert--stats-aborted-p stats) 'aborted) 1680 | ((ert--stats-current-test stats) 'running) 1681 | ((ert--stats-end-time stats) 'finished) 1682 | (t 'preparing)))) 1683 | (ecase state 1684 | (preparing 1685 | (insert "")) 1686 | (aborted 1687 | (cond ((ert--stats-current-test stats) 1688 | (insert "Aborted during test: ") 1689 | (ert-insert-test-name-button 1690 | (ert-test-name (ert--stats-current-test stats)))) 1691 | (t 1692 | (insert "Aborted.")))) 1693 | (running 1694 | (assert (ert--stats-current-test stats)) 1695 | (insert "Running test: ") 1696 | (ert-insert-test-name-button (ert-test-name 1697 | (ert--stats-current-test stats)))) 1698 | (finished 1699 | (assert (not (ert--stats-current-test stats))) 1700 | (insert "Finished."))) 1701 | (insert "\n") 1702 | (if (ert--stats-end-time stats) 1703 | (insert 1704 | (format "%s%s\n" 1705 | (if (ert--stats-aborted-p stats) 1706 | "Aborted at: " 1707 | "Finished at: ") 1708 | (ert--format-time-iso8601 (ert--stats-end-time stats)))) 1709 | (insert "\n")) 1710 | (insert "\n")) 1711 | (let ((progress-bar-string (with-current-buffer results-buffer 1712 | ert--results-progress-bar-string))) 1713 | (let ((progress-bar-button-begin 1714 | (insert-text-button progress-bar-string 1715 | :type 'ert--results-progress-bar-button 1716 | 'face (or (and font-lock 1717 | (ert-face-for-stats stats)) 1718 | 'button)))) 1719 | ;; The header gets copied verbatim to the results buffer, 1720 | ;; and all positions remain the same, so 1721 | ;; `progress-bar-button-begin' will be the right position 1722 | ;; even in the results buffer. 1723 | (with-current-buffer results-buffer 1724 | (set (make-local-variable 'ert--results-progress-bar-button-begin) 1725 | progress-bar-button-begin)))) 1726 | (insert "\n\n") 1727 | (buffer-string)) 1728 | ;; footer 1729 | ;; 1730 | ;; We actually want an empty footer, but that would trigger a bug 1731 | ;; in ewoc, sometimes clearing the entire buffer. (It's possible 1732 | ;; that this bug has been fixed since this has been tested; we 1733 | ;; should test it again.) 1734 | "\n"))) 1735 | 1736 | 1737 | (defvar ert-test-run-redisplay-interval-secs .1 1738 | "How many seconds ERT should wait between redisplays while running tests. 1739 | 1740 | While running tests, ERT shows the current progress, and this variable 1741 | determines how frequently the progress display is updated.") 1742 | 1743 | (defun ert--results-update-stats-display (ewoc stats) 1744 | "Update EWOC and the mode line to show data from STATS." 1745 | ;; TODO(ohler): investigate using `make-progress-reporter'. 1746 | (ert--results-update-ewoc-hf ewoc stats) 1747 | (force-mode-line-update) 1748 | (redisplay t) 1749 | (setf (ert--stats-next-redisplay stats) 1750 | (+ (float-time) ert-test-run-redisplay-interval-secs))) 1751 | 1752 | (defun ert--results-update-stats-display-maybe (ewoc stats) 1753 | "Call `ert--results-update-stats-display' if not called recently. 1754 | 1755 | EWOC and STATS are arguments for `ert--results-update-stats-display'." 1756 | (when (>= (float-time) (ert--stats-next-redisplay stats)) 1757 | (ert--results-update-stats-display ewoc stats))) 1758 | 1759 | (defun ert--tests-running-mode-line-indicator () 1760 | "Return a string for the mode line that shows the test run progress." 1761 | (let* ((stats ert--current-run-stats) 1762 | (tests-total (ert-stats-total stats)) 1763 | (tests-completed (ert-stats-completed stats))) 1764 | (if (>= tests-completed tests-total) 1765 | (format " ERT(%s/%s,finished)" tests-completed tests-total) 1766 | (format " ERT(%s/%s):%s" 1767 | (1+ tests-completed) 1768 | tests-total 1769 | (if (null (ert--stats-current-test stats)) 1770 | "?" 1771 | (format "%S" 1772 | (ert-test-name (ert--stats-current-test stats)))))))) 1773 | 1774 | (defun ert--make-xrefs-region (begin end) 1775 | "Attach cross-references to function names between BEGIN and END. 1776 | 1777 | BEGIN and END specify a region in the current buffer." 1778 | (save-excursion 1779 | (save-restriction 1780 | (narrow-to-region begin (point)) 1781 | ;; Inhibit optimization in `debugger-make-xrefs' that would 1782 | ;; sometimes insert unrelated backtrace info into our buffer. 1783 | (let ((debugger-previous-backtrace nil)) 1784 | (debugger-make-xrefs))))) 1785 | 1786 | (defun ert--string-first-line (s) 1787 | "Return the first line of S, or S if it contains no newlines. 1788 | 1789 | The return value does not include the line terminator." 1790 | (substring s 0 (ert--string-position ?\n s))) 1791 | 1792 | (defun ert-face-for-test-result (expectedp) 1793 | "Return a face that shows whether a test result was expected or unexpected. 1794 | 1795 | If EXPECTEDP is nil, returns the face for unexpected results; if 1796 | non-nil, returns the face for expected results.." 1797 | (if expectedp 'ert-test-result-expected 'ert-test-result-unexpected)) 1798 | 1799 | (defun ert-face-for-stats (stats) 1800 | "Return a face that represents STATS." 1801 | (cond ((ert--stats-aborted-p stats) 'nil) 1802 | ((plusp (ert-stats-completed-unexpected stats)) 1803 | (ert-face-for-test-result nil)) 1804 | ((eql (ert-stats-completed-expected stats) (ert-stats-total stats)) 1805 | (ert-face-for-test-result t)) 1806 | (t 'nil))) 1807 | 1808 | (defun ert--print-test-for-ewoc (entry) 1809 | "The ewoc print function for ewoc test entries. ENTRY is the entry to print." 1810 | (let* ((test (ert--ewoc-entry-test entry)) 1811 | (stats ert--results-stats) 1812 | (result (let ((pos (ert--stats-test-pos stats test))) 1813 | (assert pos) 1814 | (aref (ert--stats-test-results stats) pos))) 1815 | (hiddenp (ert--ewoc-entry-hidden-p entry)) 1816 | (expandedp (ert--ewoc-entry-expanded-p entry)) 1817 | (extended-printer-limits-p (ert--ewoc-entry-extended-printer-limits-p 1818 | entry))) 1819 | (cond (hiddenp) 1820 | (t 1821 | (let ((expectedp (ert-test-result-expected-p test result))) 1822 | (insert-text-button (format "%c" (ert-char-for-test-result 1823 | result expectedp)) 1824 | :type 'ert--results-expand-collapse-button 1825 | 'face (or (and font-lock-mode 1826 | (ert-face-for-test-result 1827 | expectedp)) 1828 | 'button))) 1829 | (insert " ") 1830 | (ert-insert-test-name-button (ert-test-name test)) 1831 | (insert "\n") 1832 | (when (and expandedp (not (eql result 'nil))) 1833 | (when (ert-test-documentation test) 1834 | (insert " " 1835 | (propertize 1836 | (ert--string-first-line (ert-test-documentation test)) 1837 | 'font-lock-face 'font-lock-doc-face) 1838 | "\n")) 1839 | (etypecase result 1840 | (ert-test-passed 1841 | (if (ert-test-result-expected-p test result) 1842 | (insert " passed\n") 1843 | (insert " passed unexpectedly\n")) 1844 | (insert "")) 1845 | (ert-test-result-with-condition 1846 | (ert--insert-infos result) 1847 | (let ((print-escape-newlines t) 1848 | (print-level (if extended-printer-limits-p 12 6)) 1849 | (print-length (if extended-printer-limits-p 100 10))) 1850 | (insert " ") 1851 | (let ((begin (point))) 1852 | (ert--pp-with-indentation-and-newline 1853 | (ert-test-result-with-condition-condition result)) 1854 | (ert--make-xrefs-region begin (point))))) 1855 | (ert-test-aborted-with-non-local-exit 1856 | (insert " aborted\n"))) 1857 | (insert "\n"))))) 1858 | nil) 1859 | 1860 | (defun ert--results-font-lock-function (enabledp) 1861 | "Redraw the ERT results buffer after font-lock-mode was switched on or off. 1862 | 1863 | ENABLEDP is true if font-lock-mode is switched on, false 1864 | otherwise." 1865 | (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) 1866 | (ewoc-refresh ert--results-ewoc) 1867 | (font-lock-default-function enabledp)) 1868 | 1869 | (defun ert--setup-results-buffer (stats listener buffer-name) 1870 | "Set up a test results buffer. 1871 | 1872 | STATS is the stats object; LISTENER is the results listener; 1873 | BUFFER-NAME, if non-nil, is the buffer name to use." 1874 | (unless buffer-name (setq buffer-name "*ert*")) 1875 | (let ((buffer (get-buffer-create buffer-name))) 1876 | (with-current-buffer buffer 1877 | (setq buffer-read-only t) 1878 | (let ((inhibit-read-only t)) 1879 | (buffer-disable-undo) 1880 | (erase-buffer) 1881 | (ert-results-mode) 1882 | ;; Erase buffer again in case switching out of the previous 1883 | ;; mode inserted anything. (This happens e.g. when switching 1884 | ;; from ert-results-mode to ert-results-mode when 1885 | ;; font-lock-mode turns itself off in change-major-mode-hook.) 1886 | (erase-buffer) 1887 | (set (make-local-variable 'font-lock-function) 1888 | 'ert--results-font-lock-function) 1889 | (let ((ewoc (ewoc-create 'ert--print-test-for-ewoc nil nil t))) 1890 | (set (make-local-variable 'ert--results-ewoc) ewoc) 1891 | (set (make-local-variable 'ert--results-stats) stats) 1892 | (set (make-local-variable 'ert--results-progress-bar-string) 1893 | (make-string (ert-stats-total stats) 1894 | (ert-char-for-test-result nil t))) 1895 | (set (make-local-variable 'ert--results-listener) listener) 1896 | (loop for test across (ert--stats-tests stats) do 1897 | (ewoc-enter-last ewoc 1898 | (make-ert--ewoc-entry :test test :hidden-p t))) 1899 | (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) 1900 | (goto-char (1- (point-max))) 1901 | buffer))))) 1902 | 1903 | 1904 | (defvar ert--selector-history nil 1905 | "List of recent test selectors read from terminal.") 1906 | 1907 | ;; Should OUTPUT-BUFFER-NAME and MESSAGE-FN really be arguments here? 1908 | ;; They are needed only for our automated self-tests at the moment. 1909 | ;; Or should there be some other mechanism? 1910 | ;;;###autoload 1911 | (defun ert-run-tests-interactively (selector 1912 | &optional output-buffer-name message-fn) 1913 | "Run the tests specified by SELECTOR and display the results in a buffer. 1914 | 1915 | SELECTOR works as described in `ert-select-tests'. 1916 | OUTPUT-BUFFER-NAME and MESSAGE-FN should normally be nil; they 1917 | are used for automated self-tests and specify which buffer to use 1918 | and how to display message." 1919 | (interactive 1920 | (list (let ((default (if ert--selector-history 1921 | ;; Can't use `first' here as this form is 1922 | ;; not compiled, and `first' is not 1923 | ;; defined without cl. 1924 | (car ert--selector-history) 1925 | "t"))) 1926 | (read-from-minibuffer (if (null default) 1927 | "Run tests: " 1928 | (format "Run tests (default %s): " default)) 1929 | nil nil t 'ert--selector-history 1930 | default nil)) 1931 | nil)) 1932 | (unless message-fn (setq message-fn 'message)) 1933 | (lexical-let ((output-buffer-name output-buffer-name) 1934 | buffer 1935 | listener 1936 | (message-fn message-fn)) 1937 | (setq listener 1938 | (lambda (event-type &rest event-args) 1939 | (ecase event-type 1940 | (run-started 1941 | (destructuring-bind (stats) event-args 1942 | (setq buffer (ert--setup-results-buffer stats 1943 | listener 1944 | output-buffer-name)) 1945 | (pop-to-buffer buffer))) 1946 | (run-ended 1947 | (destructuring-bind (stats abortedp) event-args 1948 | (funcall message-fn 1949 | "%sRan %s tests, %s results were as expected%s" 1950 | (if (not abortedp) 1951 | "" 1952 | "Aborted: ") 1953 | (ert-stats-total stats) 1954 | (ert-stats-completed-expected stats) 1955 | (let ((unexpected 1956 | (ert-stats-completed-unexpected stats))) 1957 | (if (zerop unexpected) 1958 | "" 1959 | (format ", %s unexpected" unexpected)))) 1960 | (ert--results-update-stats-display (with-current-buffer buffer 1961 | ert--results-ewoc) 1962 | stats))) 1963 | (test-started 1964 | (destructuring-bind (stats test) event-args 1965 | (with-current-buffer buffer 1966 | (let* ((ewoc ert--results-ewoc) 1967 | (pos (ert--stats-test-pos stats test)) 1968 | (node (ewoc-nth ewoc pos))) 1969 | (assert node) 1970 | (setf (ert--ewoc-entry-test (ewoc-data node)) test) 1971 | (aset ert--results-progress-bar-string pos 1972 | (ert-char-for-test-result nil t)) 1973 | (ert--results-update-stats-display-maybe ewoc stats) 1974 | (ewoc-invalidate ewoc node))))) 1975 | (test-ended 1976 | (destructuring-bind (stats test result) event-args 1977 | (with-current-buffer buffer 1978 | (let* ((ewoc ert--results-ewoc) 1979 | (pos (ert--stats-test-pos stats test)) 1980 | (node (ewoc-nth ewoc pos))) 1981 | (when (ert--ewoc-entry-hidden-p (ewoc-data node)) 1982 | (setf (ert--ewoc-entry-hidden-p (ewoc-data node)) 1983 | (ert-test-result-expected-p test result))) 1984 | (aset ert--results-progress-bar-string pos 1985 | (ert-char-for-test-result result 1986 | (ert-test-result-expected-p 1987 | test result))) 1988 | (ert--results-update-stats-display-maybe ewoc stats) 1989 | (ewoc-invalidate ewoc node)))))))) 1990 | (ert-run-tests 1991 | selector 1992 | listener))) 1993 | ;;;###autoload 1994 | (defalias 'ert 'ert-run-tests-interactively) 1995 | 1996 | 1997 | ;;; Simple view mode for auxiliary information like stack traces or 1998 | ;;; messages. Mainly binds "q" for quit. 1999 | 2000 | (define-derived-mode ert-simple-view-mode fundamental-mode "ERT-View" 2001 | "Major mode for viewing auxiliary information in ERT.") 2002 | 2003 | (loop for (key binding) in 2004 | '(("q" quit-window) 2005 | ) 2006 | do 2007 | (define-key ert-simple-view-mode-map key binding)) 2008 | 2009 | 2010 | ;;; Commands and button actions for the results buffer. 2011 | 2012 | (define-derived-mode ert-results-mode fundamental-mode "ERT-Results" 2013 | "Major mode for viewing results of ERT test runs.") 2014 | 2015 | (loop for (key binding) in 2016 | '(;; Stuff that's not in the menu. 2017 | ("\t" forward-button) 2018 | ([backtab] backward-button) 2019 | ("j" ert-results-jump-between-summary-and-result) 2020 | ("q" quit-window) 2021 | ("L" ert-results-toggle-printer-limits-for-test-at-point) 2022 | ("n" ert-results-next-test) 2023 | ("p" ert-results-previous-test) 2024 | ;; Stuff that is in the menu. 2025 | ("R" ert-results-rerun-all-tests) 2026 | ("r" ert-results-rerun-test-at-point) 2027 | ("d" ert-results-rerun-test-at-point-debugging-errors) 2028 | ("." ert-results-find-test-at-point-other-window) 2029 | ("b" ert-results-pop-to-backtrace-for-test-at-point) 2030 | ("m" ert-results-pop-to-messages-for-test-at-point) 2031 | ("l" ert-results-pop-to-should-forms-for-test-at-point) 2032 | ("h" ert-results-describe-test-at-point) 2033 | ("D" ert-delete-test) 2034 | ("T" ert-results-pop-to-timings) 2035 | ) 2036 | do 2037 | (define-key ert-results-mode-map key binding)) 2038 | 2039 | (easy-menu-define ert-results-mode-menu ert-results-mode-map 2040 | "Menu for `ert-results-mode'." 2041 | '("ERT Results" 2042 | ["Re-run all tests" ert-results-rerun-all-tests] 2043 | "--" 2044 | ["Re-run test" ert-results-rerun-test-at-point] 2045 | ["Debug test" ert-results-rerun-test-at-point-debugging-errors] 2046 | ["Show test definition" ert-results-find-test-at-point-other-window] 2047 | "--" 2048 | ["Show backtrace" ert-results-pop-to-backtrace-for-test-at-point] 2049 | ["Show messages" ert-results-pop-to-messages-for-test-at-point] 2050 | ["Show `should' forms" ert-results-pop-to-should-forms-for-test-at-point] 2051 | ["Describe test" ert-results-describe-test-at-point] 2052 | "--" 2053 | ["Delete test" ert-delete-test] 2054 | "--" 2055 | ["Show execution time of each test" ert-results-pop-to-timings] 2056 | )) 2057 | 2058 | (define-button-type 'ert--results-progress-bar-button 2059 | 'action #'ert--results-progress-bar-button-action 2060 | 'help-echo "mouse-2, RET: Reveal test result") 2061 | 2062 | (define-button-type 'ert--test-name-button 2063 | 'action #'ert--test-name-button-action 2064 | 'help-echo "mouse-2, RET: Find test definition") 2065 | 2066 | (define-button-type 'ert--results-expand-collapse-button 2067 | 'action #'ert--results-expand-collapse-button-action 2068 | 'help-echo "mouse-2, RET: Expand/collapse test result") 2069 | 2070 | (defun ert--results-test-node-or-null-at-point () 2071 | "If point is on a valid ewoc node, return it; return nil otherwise. 2072 | 2073 | To be used in the ERT results buffer." 2074 | (let* ((ewoc ert--results-ewoc) 2075 | (node (ewoc-locate ewoc))) 2076 | ;; `ewoc-locate' will return an arbitrary node when point is on 2077 | ;; header or footer, or when all nodes are invisible. So we need 2078 | ;; to validate its return value here. 2079 | ;; 2080 | ;; Update: I'm seeing nil being returned in some cases now, 2081 | ;; perhaps this has been changed? 2082 | (if (and node 2083 | (>= (point) (ewoc-location node)) 2084 | (not (ert--ewoc-entry-hidden-p (ewoc-data node)))) 2085 | node 2086 | nil))) 2087 | 2088 | (defun ert--results-test-node-at-point () 2089 | "If point is on a valid ewoc node, return it; signal an error otherwise. 2090 | 2091 | To be used in the ERT results buffer." 2092 | (or (ert--results-test-node-or-null-at-point) 2093 | (error "No test at point"))) 2094 | 2095 | (defun ert-results-next-test () 2096 | "Move point to the next test. 2097 | 2098 | To be used in the ERT results buffer." 2099 | (interactive) 2100 | (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-next 2101 | "No tests below")) 2102 | 2103 | (defun ert-results-previous-test () 2104 | "Move point to the previous test. 2105 | 2106 | To be used in the ERT results buffer." 2107 | (interactive) 2108 | (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-prev 2109 | "No tests above")) 2110 | 2111 | (defun ert--results-move (node ewoc-fn error-message) 2112 | "Move point from NODE to the previous or next node. 2113 | 2114 | EWOC-FN specifies the direction and should be either `ewoc-prev' 2115 | or `ewoc-next'. If there are no more nodes in that direction, an 2116 | error is signalled with the message ERROR-MESSAGE." 2117 | (loop 2118 | (setq node (funcall ewoc-fn ert--results-ewoc node)) 2119 | (when (null node) 2120 | (error "%s" error-message)) 2121 | (unless (ert--ewoc-entry-hidden-p (ewoc-data node)) 2122 | (goto-char (ewoc-location node)) 2123 | (return)))) 2124 | 2125 | (defun ert--results-expand-collapse-button-action (button) 2126 | "Expand or collapse the test node BUTTON belongs to." 2127 | (let* ((ewoc ert--results-ewoc) 2128 | (node (save-excursion 2129 | (goto-char (ert--button-action-position)) 2130 | (ert--results-test-node-at-point))) 2131 | (entry (ewoc-data node))) 2132 | (setf (ert--ewoc-entry-expanded-p entry) 2133 | (not (ert--ewoc-entry-expanded-p entry))) 2134 | (ewoc-invalidate ewoc node))) 2135 | 2136 | (defun ert-results-find-test-at-point-other-window () 2137 | "Find the definition of the test at point in another window. 2138 | 2139 | To be used in the ERT results buffer." 2140 | (interactive) 2141 | (let ((name (ert-test-at-point))) 2142 | (unless name 2143 | (error "No test at point")) 2144 | (ert-find-test-other-window name))) 2145 | 2146 | (defun ert--test-name-button-action (button) 2147 | "Find the definition of the test BUTTON belongs to, in another window." 2148 | (let ((name (button-get button 'ert-test-name))) 2149 | (ert-find-test-other-window name))) 2150 | 2151 | (defun ert--ewoc-position (ewoc node) 2152 | ;; checkdoc-order: nil 2153 | "Return the position of NODE in EWOC, or nil if NODE is not in EWOC." 2154 | (loop for i from 0 2155 | for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here) 2156 | do (when (eql node node-here) 2157 | (return i)) 2158 | finally (return nil))) 2159 | 2160 | (defun ert-results-jump-between-summary-and-result () 2161 | "Jump back and forth between the test run summary and individual test results. 2162 | 2163 | From an ewoc node, jumps to the character that represents the 2164 | same test in the progress bar, and vice versa. 2165 | 2166 | To be used in the ERT results buffer." 2167 | ;; Maybe this command isn't actually needed much, but if it is, it 2168 | ;; seems like an indication that the UI design is not optimal. If 2169 | ;; jumping back and forth between a summary at the top of the buffer 2170 | ;; and the error log in the remainder of the buffer is useful, then 2171 | ;; the summary apparently needs to be easily accessible from the 2172 | ;; error log, and perhaps it would be better to have it in a 2173 | ;; separate buffer to keep it visible. 2174 | (interactive) 2175 | (let ((ewoc ert--results-ewoc) 2176 | (progress-bar-begin ert--results-progress-bar-button-begin)) 2177 | (cond ((ert--results-test-node-or-null-at-point) 2178 | (let* ((node (ert--results-test-node-at-point)) 2179 | (pos (ert--ewoc-position ewoc node))) 2180 | (goto-char (+ progress-bar-begin pos)))) 2181 | ((and (<= progress-bar-begin (point)) 2182 | (< (point) (button-end (button-at progress-bar-begin)))) 2183 | (let* ((node (ewoc-nth ewoc (- (point) progress-bar-begin))) 2184 | (entry (ewoc-data node))) 2185 | (when (ert--ewoc-entry-hidden-p entry) 2186 | (setf (ert--ewoc-entry-hidden-p entry) nil) 2187 | (ewoc-invalidate ewoc node)) 2188 | (ewoc-goto-node ewoc node))) 2189 | (t 2190 | (goto-char progress-bar-begin))))) 2191 | 2192 | (defun ert-test-at-point () 2193 | "Return the name of the test at point as a symbol, or nil if none." 2194 | (or (and (eql major-mode 'ert-results-mode) 2195 | (let ((test (ert--results-test-at-point-no-redefinition))) 2196 | (and test (ert-test-name test)))) 2197 | (let* ((thing (thing-at-point 'symbol)) 2198 | (sym (intern-soft thing))) 2199 | (and (ert-test-boundp sym) 2200 | sym)))) 2201 | 2202 | (defun ert--results-test-at-point-no-redefinition () 2203 | "Return the test at point, or nil. 2204 | 2205 | To be used in the ERT results buffer." 2206 | (assert (eql major-mode 'ert-results-mode)) 2207 | (if (ert--results-test-node-or-null-at-point) 2208 | (let* ((node (ert--results-test-node-at-point)) 2209 | (test (ert--ewoc-entry-test (ewoc-data node)))) 2210 | test) 2211 | (let ((progress-bar-begin ert--results-progress-bar-button-begin)) 2212 | (when (and (<= progress-bar-begin (point)) 2213 | (< (point) (button-end (button-at progress-bar-begin)))) 2214 | (let* ((test-index (- (point) progress-bar-begin)) 2215 | (test (aref (ert--stats-tests ert--results-stats) 2216 | test-index))) 2217 | test))))) 2218 | 2219 | (defun ert--results-test-at-point-allow-redefinition () 2220 | "Look up the test at point, and check whether it has been redefined. 2221 | 2222 | To be used in the ERT results buffer. 2223 | 2224 | Returns a list of two elements: the test (or nil) and a symbol 2225 | specifying whether the test has been redefined. 2226 | 2227 | If a new test has been defined with the same name as the test at 2228 | point, replaces the test at point with the new test, and returns 2229 | the new test and the symbol `redefined'. 2230 | 2231 | If the test has been deleted, returns the old test and the symbol 2232 | `deleted'. 2233 | 2234 | If the test is still current, returns the test and the symbol nil. 2235 | 2236 | If there is no test at point, returns a list with two nils." 2237 | (let ((test (ert--results-test-at-point-no-redefinition))) 2238 | (cond ((null test) 2239 | `(nil nil)) 2240 | ((null (ert-test-name test)) 2241 | `(,test nil)) 2242 | (t 2243 | (let* ((name (ert-test-name test)) 2244 | (new-test (and (ert-test-boundp name) 2245 | (ert-get-test name)))) 2246 | (cond ((eql test new-test) 2247 | `(,test nil)) 2248 | ((null new-test) 2249 | `(,test deleted)) 2250 | (t 2251 | (ert--results-update-after-test-redefinition 2252 | (ert--stats-test-pos ert--results-stats test) 2253 | new-test) 2254 | `(,new-test redefined)))))))) 2255 | 2256 | (defun ert--results-update-after-test-redefinition (pos new-test) 2257 | "Update results buffer after the test at pos POS has been redefined. 2258 | 2259 | Also updates the stats object. NEW-TEST is the new test 2260 | definition." 2261 | (let* ((stats ert--results-stats) 2262 | (ewoc ert--results-ewoc) 2263 | (node (ewoc-nth ewoc pos)) 2264 | (entry (ewoc-data node))) 2265 | (ert--stats-set-test-and-result stats pos new-test nil) 2266 | (setf (ert--ewoc-entry-test entry) new-test 2267 | (aref ert--results-progress-bar-string pos) (ert-char-for-test-result 2268 | nil t)) 2269 | (ewoc-invalidate ewoc node)) 2270 | nil) 2271 | 2272 | (defun ert--button-action-position () 2273 | "The buffer position where the last button action was triggered." 2274 | (cond ((integerp last-command-event) 2275 | (point)) 2276 | ((eventp last-command-event) 2277 | (posn-point (event-start last-command-event))) 2278 | (t (assert nil)))) 2279 | 2280 | (defun ert--results-progress-bar-button-action (button) 2281 | "Jump to details for the test represented by the character clicked in BUTTON." 2282 | (goto-char (ert--button-action-position)) 2283 | (ert-results-jump-between-summary-and-result)) 2284 | 2285 | (defun ert-results-rerun-all-tests () 2286 | "Re-run all tests, using the same selector. 2287 | 2288 | To be used in the ERT results buffer." 2289 | (interactive) 2290 | (assert (eql major-mode 'ert-results-mode)) 2291 | (let ((selector (ert--stats-selector ert--results-stats))) 2292 | (ert-run-tests-interactively selector (buffer-name)))) 2293 | 2294 | (defun ert-results-rerun-test-at-point () 2295 | "Re-run the test at point. 2296 | 2297 | To be used in the ERT results buffer." 2298 | (interactive) 2299 | (destructuring-bind (test redefinition-state) 2300 | (ert--results-test-at-point-allow-redefinition) 2301 | (when (null test) 2302 | (error "No test at point")) 2303 | (let* ((stats ert--results-stats) 2304 | (progress-message (format "Running %stest %S" 2305 | (ecase redefinition-state 2306 | ((nil) "") 2307 | (redefined "new definition of ") 2308 | (deleted "deleted ")) 2309 | (ert-test-name test)))) 2310 | ;; Need to save and restore point manually here: When point is on 2311 | ;; the first visible ewoc entry while the header is updated, point 2312 | ;; moves to the top of the buffer. This is undesirable, and a 2313 | ;; simple `save-excursion' doesn't prevent it. 2314 | (let ((point (point))) 2315 | (unwind-protect 2316 | (unwind-protect 2317 | (progn 2318 | (message "%s..." progress-message) 2319 | (ert-run-or-rerun-test stats test 2320 | ert--results-listener)) 2321 | (ert--results-update-stats-display ert--results-ewoc stats) 2322 | (message "%s...%s" 2323 | progress-message 2324 | (let ((result (ert-test-most-recent-result test))) 2325 | (ert-string-for-test-result 2326 | result (ert-test-result-expected-p test result))))) 2327 | (goto-char point)))))) 2328 | 2329 | (defun ert-results-rerun-test-at-point-debugging-errors () 2330 | "Re-run the test at point with `ert-debug-on-error' bound to t. 2331 | 2332 | To be used in the ERT results buffer." 2333 | (interactive) 2334 | (let ((ert-debug-on-error t)) 2335 | (ert-results-rerun-test-at-point))) 2336 | 2337 | (defun ert-results-pop-to-backtrace-for-test-at-point () 2338 | "Display the backtrace for the test at point. 2339 | 2340 | To be used in the ERT results buffer." 2341 | (interactive) 2342 | (let* ((test (ert--results-test-at-point-no-redefinition)) 2343 | (stats ert--results-stats) 2344 | (pos (ert--stats-test-pos stats test)) 2345 | (result (aref (ert--stats-test-results stats) pos))) 2346 | (etypecase result 2347 | (ert-test-passed (error "Test passed, no backtrace available")) 2348 | (ert-test-result-with-condition 2349 | (let ((backtrace (ert-test-result-with-condition-backtrace result)) 2350 | (buffer (get-buffer-create "*ERT Backtrace*"))) 2351 | (pop-to-buffer buffer) 2352 | (setq buffer-read-only t) 2353 | (let ((inhibit-read-only t)) 2354 | (buffer-disable-undo) 2355 | (erase-buffer) 2356 | (ert-simple-view-mode) 2357 | ;; Use unibyte because `debugger-setup-buffer' also does so. 2358 | (set-buffer-multibyte nil) 2359 | (setq truncate-lines t) 2360 | (ert--print-backtrace backtrace) 2361 | (debugger-make-xrefs) 2362 | (goto-char (point-min)) 2363 | (insert "Backtrace for test `") 2364 | (ert-insert-test-name-button (ert-test-name test)) 2365 | (insert "':\n"))))))) 2366 | 2367 | (defun ert-results-pop-to-messages-for-test-at-point () 2368 | "Display the part of the *Messages* buffer generated during the test at point. 2369 | 2370 | To be used in the ERT results buffer." 2371 | (interactive) 2372 | (let* ((test (ert--results-test-at-point-no-redefinition)) 2373 | (stats ert--results-stats) 2374 | (pos (ert--stats-test-pos stats test)) 2375 | (result (aref (ert--stats-test-results stats) pos))) 2376 | (let ((buffer (get-buffer-create "*ERT Messages*"))) 2377 | (pop-to-buffer buffer) 2378 | (setq buffer-read-only t) 2379 | (let ((inhibit-read-only t)) 2380 | (buffer-disable-undo) 2381 | (erase-buffer) 2382 | (ert-simple-view-mode) 2383 | (insert (ert-test-result-messages result)) 2384 | (goto-char (point-min)) 2385 | (insert "Messages for test `") 2386 | (ert-insert-test-name-button (ert-test-name test)) 2387 | (insert "':\n"))))) 2388 | 2389 | (defun ert-results-pop-to-should-forms-for-test-at-point () 2390 | "Display the list of `should' forms executed during the test at point. 2391 | 2392 | To be used in the ERT results buffer." 2393 | (interactive) 2394 | (let* ((test (ert--results-test-at-point-no-redefinition)) 2395 | (stats ert--results-stats) 2396 | (pos (ert--stats-test-pos stats test)) 2397 | (result (aref (ert--stats-test-results stats) pos))) 2398 | (let ((buffer (get-buffer-create "*ERT list of should forms*"))) 2399 | (pop-to-buffer buffer) 2400 | (setq buffer-read-only t) 2401 | (let ((inhibit-read-only t)) 2402 | (buffer-disable-undo) 2403 | (erase-buffer) 2404 | (ert-simple-view-mode) 2405 | (if (null (ert-test-result-should-forms result)) 2406 | (insert "\n(No should forms during this test.)\n") 2407 | (loop for form-description in (ert-test-result-should-forms result) 2408 | for i from 1 do 2409 | (insert "\n") 2410 | (insert (format "%s: " i)) 2411 | (let ((begin (point))) 2412 | (ert--pp-with-indentation-and-newline form-description) 2413 | (ert--make-xrefs-region begin (point))))) 2414 | (goto-char (point-min)) 2415 | (insert "`should' forms executed during test `") 2416 | (ert-insert-test-name-button (ert-test-name test)) 2417 | (insert "':\n") 2418 | (insert "\n") 2419 | (insert (concat "(Values are shallow copies and may have " 2420 | "looked different during the test if they\n" 2421 | "have been modified destructively.)\n")) 2422 | (forward-line 1))))) 2423 | 2424 | (defun ert-results-toggle-printer-limits-for-test-at-point () 2425 | "Toggle how much of the condition to print for the test at point. 2426 | 2427 | To be used in the ERT results buffer." 2428 | (interactive) 2429 | (let* ((ewoc ert--results-ewoc) 2430 | (node (ert--results-test-node-at-point)) 2431 | (entry (ewoc-data node))) 2432 | (setf (ert--ewoc-entry-extended-printer-limits-p entry) 2433 | (not (ert--ewoc-entry-extended-printer-limits-p entry))) 2434 | (ewoc-invalidate ewoc node))) 2435 | 2436 | (defun ert-results-pop-to-timings () 2437 | "Display test timings for the last run. 2438 | 2439 | To be used in the ERT results buffer." 2440 | (interactive) 2441 | (let* ((stats ert--results-stats) 2442 | (start-times (ert--stats-test-start-times stats)) 2443 | (end-times (ert--stats-test-end-times stats)) 2444 | (buffer (get-buffer-create "*ERT timings*")) 2445 | (data (loop for test across (ert--stats-tests stats) 2446 | for start-time across (ert--stats-test-start-times stats) 2447 | for end-time across (ert--stats-test-end-times stats) 2448 | collect (list test 2449 | (float-time (subtract-time end-time 2450 | start-time)))))) 2451 | (setq data (sort data (lambda (a b) 2452 | (> (second a) (second b))))) 2453 | (pop-to-buffer buffer) 2454 | (setq buffer-read-only t) 2455 | (let ((inhibit-read-only t)) 2456 | (buffer-disable-undo) 2457 | (erase-buffer) 2458 | (ert-simple-view-mode) 2459 | (if (null data) 2460 | (insert "(No data)\n") 2461 | (insert (format "%-3s %8s %8s\n" "" "time" "cumul")) 2462 | (loop for (test time) in data 2463 | for cumul-time = time then (+ cumul-time time) 2464 | for i from 1 do 2465 | (let ((begin (point))) 2466 | (insert (format "%3s: %8.3f %8.3f " i time cumul-time)) 2467 | (ert-insert-test-name-button (ert-test-name test)) 2468 | (insert "\n")))) 2469 | (goto-char (point-min)) 2470 | (insert "Tests by run time (seconds):\n\n") 2471 | (forward-line 1)))) 2472 | 2473 | ;;;###autoload 2474 | (defun ert-describe-test (test-or-test-name) 2475 | "Display the documentation for TEST-OR-TEST-NAME (a symbol or ert-test)." 2476 | (interactive (list (ert-read-test-name-at-point "Describe test"))) 2477 | (when (< emacs-major-version 24) 2478 | (error "Requires Emacs 24")) 2479 | (let (test-name 2480 | test-definition) 2481 | (etypecase test-or-test-name 2482 | (symbol (setq test-name test-or-test-name 2483 | test-definition (ert-get-test test-or-test-name))) 2484 | (ert-test (setq test-name (ert-test-name test-or-test-name) 2485 | test-definition test-or-test-name))) 2486 | (help-setup-xref (list #'ert-describe-test test-or-test-name) 2487 | (called-interactively-p 'interactive)) 2488 | (save-excursion 2489 | (with-help-window (help-buffer) 2490 | (with-current-buffer (help-buffer) 2491 | (insert (if test-name (format "%S" test-name) "")) 2492 | (insert " is a test") 2493 | (let ((file-name (and test-name 2494 | (symbol-file test-name 'ert-deftest)))) 2495 | (when file-name 2496 | (insert " defined in `" (file-name-nondirectory file-name) "'") 2497 | (save-excursion 2498 | (re-search-backward "`\\([^`']+\\)'" nil t) 2499 | (help-xref-button 1 'help-function-def test-name file-name))) 2500 | (insert ".") 2501 | (fill-region-as-paragraph (point-min) (point)) 2502 | (insert "\n\n") 2503 | (unless (and (ert-test-boundp test-name) 2504 | (eql (ert-get-test test-name) test-definition)) 2505 | (let ((begin (point))) 2506 | (insert "Note: This test has been redefined or deleted, " 2507 | "this documentation refers to an old definition.") 2508 | (fill-region-as-paragraph begin (point))) 2509 | (insert "\n\n")) 2510 | (insert (or (ert-test-documentation test-definition) 2511 | "It is not documented.") 2512 | "\n"))))))) 2513 | 2514 | (defun ert-results-describe-test-at-point () 2515 | "Display the documentation of the test at point. 2516 | 2517 | To be used in the ERT results buffer." 2518 | (interactive) 2519 | (ert-describe-test (ert--results-test-at-point-no-redefinition))) 2520 | 2521 | 2522 | ;;; Actions on load/unload. 2523 | 2524 | (add-to-list 'find-function-regexp-alist '(ert-deftest . ert--find-test-regexp)) 2525 | (add-to-list 'minor-mode-alist '(ert--current-run-stats 2526 | (:eval 2527 | (ert--tests-running-mode-line-indicator)))) 2528 | (add-to-list 'emacs-lisp-mode-hook 'ert--activate-font-lock-keywords) 2529 | 2530 | (defun ert--unload-function () 2531 | "Unload function to undo the side-effects of loading ert.el." 2532 | (ert--remove-from-list 'find-function-regexp-alist 'ert-deftest :key #'car) 2533 | (ert--remove-from-list 'minor-mode-alist 'ert--current-run-stats :key #'car) 2534 | (ert--remove-from-list 'emacs-lisp-mode-hook 2535 | 'ert--activate-font-lock-keywords) 2536 | nil) 2537 | 2538 | (defvar ert-unload-hook '()) 2539 | (add-hook 'ert-unload-hook 'ert--unload-function) 2540 | 2541 | 2542 | (provide 'ert) 2543 | 2544 | ;;; ert.el ends here 2545 | --------------------------------------------------------------------------------