| 1 | ;;; ert-x-tests.el --- Tests for ert-x.el |
| 2 | |
| 3 | ;; Copyright (C) 2008, 2010-2012 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: Phil Hagelberg |
| 6 | ;; Christian Ohler <ohler@gnu.org> |
| 7 | |
| 8 | ;; This file is 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 | ;; This file is part of ERT, the Emacs Lisp Regression Testing tool. |
| 26 | ;; See ert.el or the texinfo manual for more details. |
| 27 | |
| 28 | ;;; Code: |
| 29 | |
| 30 | (eval-when-compile |
| 31 | (require 'cl)) |
| 32 | (require 'ert) |
| 33 | (require 'ert-x) |
| 34 | |
| 35 | ;;; Utilities |
| 36 | |
| 37 | (ert-deftest ert-test-buffer-string-reindented () |
| 38 | (ert-with-test-buffer (:name "well-indented") |
| 39 | (insert (concat "(hello (world\n" |
| 40 | " 'elisp)\n")) |
| 41 | (emacs-lisp-mode) |
| 42 | (should (equal (ert-buffer-string-reindented) (buffer-string)))) |
| 43 | (ert-with-test-buffer (:name "badly-indented") |
| 44 | (insert (concat "(hello\n" |
| 45 | " world)")) |
| 46 | (emacs-lisp-mode) |
| 47 | (should-not (equal (ert-buffer-string-reindented) (buffer-string))))) |
| 48 | |
| 49 | (defun ert--hash-table-to-alist (table) |
| 50 | (let ((accu nil)) |
| 51 | (maphash (lambda (key value) |
| 52 | (push (cons key value) accu)) |
| 53 | table) |
| 54 | (nreverse accu))) |
| 55 | |
| 56 | (ert-deftest ert-test-test-buffers () |
| 57 | (let (buffer-1 |
| 58 | buffer-2) |
| 59 | (let ((test-1 |
| 60 | (make-ert-test |
| 61 | :name 'test-1 |
| 62 | :body (lambda () |
| 63 | (ert-with-test-buffer (:name "foo") |
| 64 | (should (string-match |
| 65 | "[*]Test buffer (ert-test-test-buffers): foo[*]" |
| 66 | (buffer-name))) |
| 67 | (setq buffer-1 (current-buffer)))))) |
| 68 | (test-2 |
| 69 | (make-ert-test |
| 70 | :name 'test-2 |
| 71 | :body (lambda () |
| 72 | (ert-with-test-buffer (:name "bar") |
| 73 | (should (string-match |
| 74 | "[*]Test buffer (ert-test-test-buffers): bar[*]" |
| 75 | (buffer-name))) |
| 76 | (setq buffer-2 (current-buffer)) |
| 77 | (ert-fail "fail for test")))))) |
| 78 | (let ((ert--test-buffers (make-hash-table :weakness t))) |
| 79 | (ert-run-tests `(member ,test-1 ,test-2) #'ignore) |
| 80 | (should (equal (ert--hash-table-to-alist ert--test-buffers) |
| 81 | `((,buffer-2 . t)))) |
| 82 | (should-not (buffer-live-p buffer-1)) |
| 83 | (should (buffer-live-p buffer-2)))))) |
| 84 | |
| 85 | |
| 86 | (ert-deftest ert-filter-string () |
| 87 | (should (equal (ert-filter-string "foo bar baz" "quux") |
| 88 | "foo bar baz")) |
| 89 | (should (equal (ert-filter-string "foo bar baz" "bar") |
| 90 | "foo baz"))) |
| 91 | |
| 92 | (ert-deftest ert-propertized-string () |
| 93 | (should (ert-equal-including-properties |
| 94 | (ert-propertized-string "a" '(a b) "b" '(c t) "cd") |
| 95 | #("abcd" 1 2 (a b) 2 4 (c t)))) |
| 96 | (should (ert-equal-including-properties |
| 97 | (ert-propertized-string "foo " '(face italic) "bar" " baz" nil |
| 98 | " quux") |
| 99 | #("foo bar baz quux" 4 11 (face italic))))) |
| 100 | |
| 101 | |
| 102 | ;;; Tests for ERT itself that require test features from ert-x.el. |
| 103 | |
| 104 | (ert-deftest ert-test-run-tests-interactively-2 () |
| 105 | :tags '(:causes-redisplay) |
| 106 | (let ((passing-test (make-ert-test :name 'passing-test |
| 107 | :body (lambda () (ert-pass)))) |
| 108 | (failing-test (make-ert-test :name 'failing-test |
| 109 | :body (lambda () |
| 110 | (ert-info ((propertize "foo\nbar" |
| 111 | 'a 'b)) |
| 112 | (ert-fail |
| 113 | "failure message")))))) |
| 114 | (let ((ert-debug-on-error nil)) |
| 115 | (let* ((buffer-name (generate-new-buffer-name "*ert-test-run-tests*")) |
| 116 | (messages nil) |
| 117 | (mock-message-fn |
| 118 | (lambda (format-string &rest args) |
| 119 | (push (apply #'format format-string args) messages)))) |
| 120 | (flet ((expected-string (with-font-lock-p) |
| 121 | (ert-propertized-string |
| 122 | "Selector: (member <passing-test> <failing-test>)\n" |
| 123 | "Passed: 1\n" |
| 124 | "Failed: 1 (1 unexpected)\n" |
| 125 | "Total: 2/2\n\n" |
| 126 | "Started at:\n" |
| 127 | "Finished.\n" |
| 128 | "Finished at:\n\n" |
| 129 | `(category ,(button-category-symbol |
| 130 | 'ert--results-progress-bar-button) |
| 131 | button (t) |
| 132 | face ,(if with-font-lock-p |
| 133 | 'ert-test-result-unexpected |
| 134 | 'button)) |
| 135 | ".F" nil "\n\n" |
| 136 | `(category ,(button-category-symbol |
| 137 | 'ert--results-expand-collapse-button) |
| 138 | button (t) |
| 139 | face ,(if with-font-lock-p |
| 140 | 'ert-test-result-unexpected |
| 141 | 'button)) |
| 142 | "F" nil " " |
| 143 | `(category ,(button-category-symbol |
| 144 | 'ert--test-name-button) |
| 145 | button (t) |
| 146 | ert-test-name failing-test) |
| 147 | "failing-test" |
| 148 | nil "\n Info: " '(a b) "foo\n" |
| 149 | nil " " '(a b) "bar" |
| 150 | nil "\n (ert-test-failed \"failure message\")\n\n\n" |
| 151 | ))) |
| 152 | (save-window-excursion |
| 153 | (unwind-protect |
| 154 | (let ((case-fold-search nil)) |
| 155 | (ert-run-tests-interactively |
| 156 | `(member ,passing-test ,failing-test) buffer-name |
| 157 | mock-message-fn) |
| 158 | (should (equal messages `(,(concat |
| 159 | "Ran 2 tests, 1 results were " |
| 160 | "as expected, 1 unexpected")))) |
| 161 | (with-current-buffer buffer-name |
| 162 | (font-lock-mode 0) |
| 163 | (should (ert-equal-including-properties |
| 164 | (ert-filter-string (buffer-string) |
| 165 | '("Started at:\\(.*\\)$" 1) |
| 166 | '("Finished at:\\(.*\\)$" 1)) |
| 167 | (expected-string nil))) |
| 168 | ;; `font-lock-mode' only works if interactive, so |
| 169 | ;; pretend we are. |
| 170 | (let ((noninteractive nil)) |
| 171 | (font-lock-mode 1)) |
| 172 | (should (ert-equal-including-properties |
| 173 | (ert-filter-string (buffer-string) |
| 174 | '("Started at:\\(.*\\)$" 1) |
| 175 | '("Finished at:\\(.*\\)$" 1)) |
| 176 | (expected-string t))))) |
| 177 | (when (get-buffer buffer-name) |
| 178 | (kill-buffer buffer-name))))))))) |
| 179 | |
| 180 | (ert-deftest ert-test-describe-test () |
| 181 | "Tests `ert-describe-test'." |
| 182 | (save-window-excursion |
| 183 | (ert-with-buffer-renamed ("*Help*") |
| 184 | (if (< emacs-major-version 24) |
| 185 | (should (equal (should-error (ert-describe-test 'ert-describe-test)) |
| 186 | '(error "Requires Emacs 24"))) |
| 187 | (ert-describe-test 'ert-test-describe-test) |
| 188 | (with-current-buffer "*Help*" |
| 189 | (let ((case-fold-search nil)) |
| 190 | (should (string-match (concat |
| 191 | "\\`ert-test-describe-test is a test" |
| 192 | " defined in `ert-x-tests.elc?'\\.\n\n" |
| 193 | "Tests `ert-describe-test'\\.\n\\'") |
| 194 | (buffer-string))))))))) |
| 195 | |
| 196 | (ert-deftest ert-test-message-log-truncation () |
| 197 | :tags '(:causes-redisplay) |
| 198 | (let ((test (make-ert-test |
| 199 | :body (lambda () |
| 200 | ;; Emacs would combine messages if we |
| 201 | ;; generate the same message multiple |
| 202 | ;; times. |
| 203 | (message "a") |
| 204 | (message "b") |
| 205 | (message "c") |
| 206 | (message "d"))))) |
| 207 | (let (result) |
| 208 | (ert-with-buffer-renamed ("*Messages*") |
| 209 | (let ((message-log-max 2)) |
| 210 | (setq result (ert-run-test test))) |
| 211 | (should (equal (with-current-buffer "*Messages*" |
| 212 | (buffer-string)) |
| 213 | "c\nd\n"))) |
| 214 | (should (equal (ert-test-result-messages result) "a\nb\nc\nd\n"))))) |
| 215 | |
| 216 | (ert-deftest ert-test-builtin-message-log-flushing () |
| 217 | "This test attempts to demonstrate that there is no way to |
| 218 | force immediate truncation of the *Messages* buffer from Lisp |
| 219 | \(and hence justifies the existence of |
| 220 | `ert--force-message-log-buffer-truncation'\): The only way that |
| 221 | came to my mind was \(message \"\"\), which doesn't have the |
| 222 | desired effect." |
| 223 | :tags '(:causes-redisplay) |
| 224 | (ert-with-buffer-renamed ("*Messages*") |
| 225 | (with-current-buffer "*Messages*" |
| 226 | (should (equal (buffer-string) "")) |
| 227 | ;; We used to get sporadic failures in this test that involved |
| 228 | ;; a spurious newline at the beginning of the buffer, before |
| 229 | ;; the first message. Below, we print a message and erase the |
| 230 | ;; buffer since this seems to eliminate the sporadic failures. |
| 231 | (message "foo") |
| 232 | (erase-buffer) |
| 233 | (should (equal (buffer-string) "")) |
| 234 | (let ((message-log-max 2)) |
| 235 | (let ((message-log-max t)) |
| 236 | (loop for i below 4 do |
| 237 | (message "%s" i)) |
| 238 | (should (equal (buffer-string) "0\n1\n2\n3\n"))) |
| 239 | (should (equal (buffer-string) "0\n1\n2\n3\n")) |
| 240 | (message "") |
| 241 | (should (equal (buffer-string) "0\n1\n2\n3\n")) |
| 242 | (message "Test message") |
| 243 | (should (equal (buffer-string) "3\nTest message\n")))))) |
| 244 | |
| 245 | (ert-deftest ert-test-force-message-log-buffer-truncation () |
| 246 | :tags '(:causes-redisplay) |
| 247 | (labels ((body () |
| 248 | (loop for i below 3 do |
| 249 | (message "%s" i))) |
| 250 | ;; Uses the implicit messages buffer truncation implemented |
| 251 | ;; in Emacs' C core. |
| 252 | (c (x) |
| 253 | (ert-with-buffer-renamed ("*Messages*") |
| 254 | (let ((message-log-max x)) |
| 255 | (body)) |
| 256 | (with-current-buffer "*Messages*" |
| 257 | (buffer-string)))) |
| 258 | ;; Uses our lisp reimplementation. |
| 259 | (lisp (x) |
| 260 | (ert-with-buffer-renamed ("*Messages*") |
| 261 | (let ((message-log-max t)) |
| 262 | (body)) |
| 263 | (let ((message-log-max x)) |
| 264 | (ert--force-message-log-buffer-truncation)) |
| 265 | (with-current-buffer "*Messages*" |
| 266 | (buffer-string))))) |
| 267 | (loop for x in '(0 1 2 3 4 t) do |
| 268 | (should (equal (c x) (lisp x)))))) |
| 269 | |
| 270 | |
| 271 | (provide 'ert-x-tests) |
| 272 | |
| 273 | ;;; ert-x-tests.el ends here |