code.delx.au - gnu-emacs/blob - test/lisp/emacs-lisp/ert-x-tests.el

   1 ;;; ert-x-tests.el --- Tests for ert-x.el
   2
   3 ;; Copyright (C) 2008, 2010-2016 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-lib))
  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          (skipped-test (make-ert-test :name 'skipped-test
 115                                       :body (lambda () (ert-skip
 116                                                         "skip message"))))
 117          (ert-debug-on-error nil)
 118          (buffer-name (generate-new-buffer-name "*ert-test-run-tests*"))
 119          (messages nil)
 120          (mock-message-fn
 121           (lambda (format-string &rest args)
 122             (push (apply #'format format-string args) messages))))
 123     (cl-flet ((expected-string (with-font-lock-p)
 124                 (ert-propertized-string
 125                  "Selector: (member <passing-test> <failing-test> "
 126                  "<skipped-test>)\n"
 127                  "Passed:  1\n"
 128                  "Failed:  1 (1 unexpected)\n"
 129                  "Skipped: 1\n"
 130                  "Total:   3/3\n\n"
 131                  "Started at:\n"
 132                  "Finished.\n"
 133                  "Finished at:\n\n"
 134                  `(category ,(button-category-symbol
 135                               'ert--results-progress-bar-button)
 136                             button (t)
 137                             face ,(if with-font-lock-p
 138                                       'ert-test-result-unexpected
 139                                     'button))
 140                  ".Fs" nil "\n\n"
 141                  `(category ,(button-category-symbol
 142                               'ert--results-expand-collapse-button)
 143                             button (t)
 144                             face ,(if with-font-lock-p
 145                                       'ert-test-result-unexpected
 146                                     'button))
 147                  "F" nil " "
 148                  `(category ,(button-category-symbol
 149                               'ert--test-name-button)
 150                             button (t)
 151                             ert-test-name failing-test)
 152                  "failing-test"
 153                  nil "\n    Info: " '(a b) "foo\n"
 154                  nil "          " '(a b) "bar"
 155                  nil "\n    (ert-test-failed \"failure message\")\n\n\n"
 156                  )))
 157       (save-window-excursion
 158         (unwind-protect
 159             (let ((case-fold-search nil))
 160               (ert-run-tests-interactively
 161                `(member ,passing-test ,failing-test ,skipped-test) buffer-name
 162                mock-message-fn)
 163               (should (equal messages `(,(concat
 164                                           "Ran 3 tests, 1 results were "
 165                                           "as expected, 1 unexpected, "
 166                                           "1 skipped"))))
 167               (with-current-buffer buffer-name
 168                 (font-lock-mode 0)
 169                 (should (ert-equal-including-properties
 170                          (ert-filter-string (buffer-string)
 171                                             '("Started at:\\(.*\\)$" 1)
 172                                             '("Finished at:\\(.*\\)$" 1))
 173                          (expected-string nil)))
 174                 ;; `font-lock-mode' only works if interactive, so
 175                 ;; pretend we are.
 176                 (let ((noninteractive nil))
 177                   (font-lock-mode 1))
 178                 (should (ert-equal-including-properties
 179                          (ert-filter-string (buffer-string)
 180                                             '("Started at:\\(.*\\)$" 1)
 181                                             '("Finished at:\\(.*\\)$" 1))
 182                          (expected-string t)))))
 183           (when (get-buffer buffer-name)
 184             (kill-buffer buffer-name)))))))
 185
 186 (ert-deftest ert-test-describe-test ()
 187   "Tests `ert-describe-test'."
 188   (save-window-excursion
 189     (ert-with-buffer-renamed ("*Help*")
 190       (if (< emacs-major-version 24)
 191           (should (equal (should-error (ert-describe-test 'ert-describe-test))
 192                          '(error "Requires Emacs 24")))
 193         (ert-describe-test 'ert-test-describe-test)
 194         (with-current-buffer "*Help*"
 195           (let ((case-fold-search nil))
 196             (should (string-match (concat
 197                                    "\\`ert-test-describe-test is a test"
 198                                    " defined in"
 199                                    " ['`‘]ert-x-tests.elc?['’]\\.\n\n"
 200                                    "Tests ['`‘]ert-describe-test['’]\\.\n\\'")
 201                                   (buffer-string)))))))))
 202
 203 (ert-deftest ert-test-message-log-truncation ()
 204   :tags '(:causes-redisplay)
 205   (let ((test (make-ert-test
 206                :body (lambda ()
 207                        ;; Emacs would combine messages if we
 208                        ;; generate the same message multiple
 209                        ;; times.
 210                        (message "a")
 211                        (message "b")
 212                        (message "c")
 213                        (message "d")))))
 214     (let (result)
 215       (ert-with-buffer-renamed ("*Messages*")
 216         (let ((message-log-max 2))
 217           (setq result (ert-run-test test)))
 218         (should (equal (with-current-buffer "*Messages*"
 219                          (buffer-string))
 220                        "c\nd\n")))
 221       (should (equal (ert-test-result-messages result) "a\nb\nc\nd\n")))))
 222
 223 (ert-deftest ert-test-builtin-message-log-flushing ()
 224   "This test attempts to demonstrate that there is no way to
 225 force immediate truncation of the *Messages* buffer from Lisp
 226 \(and hence justifies the existence of
 227 `ert--force-message-log-buffer-truncation'): The only way that
 228 came to my mind was \(message \"\"), which doesn't have the
 229 desired effect."
 230   :tags '(:causes-redisplay)
 231   (ert-with-buffer-renamed ("*Messages*")
 232     (with-current-buffer "*Messages*"
 233       (should (equal (buffer-string) ""))
 234       ;; We used to get sporadic failures in this test that involved
 235       ;; a spurious newline at the beginning of the buffer, before
 236       ;; the first message.  Below, we print a message and erase the
 237       ;; buffer since this seems to eliminate the sporadic failures.
 238       (message "foo")
 239       (erase-buffer)
 240       (should (equal (buffer-string) ""))
 241       (let ((message-log-max 2))
 242         (let ((message-log-max t))
 243           (cl-loop for i below 4 do
 244                    (message "%s" i))
 245           (should (equal (buffer-string) "0\n1\n2\n3\n")))
 246         (should (equal (buffer-string) "0\n1\n2\n3\n"))
 247         (message "")
 248         (should (equal (buffer-string) "0\n1\n2\n3\n"))
 249         (message "Test message")
 250         (should (equal (buffer-string) "3\nTest message\n"))))))
 251
 252 (ert-deftest ert-test-force-message-log-buffer-truncation ()
 253   :tags '(:causes-redisplay)
 254   (cl-labels ((body ()
 255                 (cl-loop for i below 3 do
 256                          (message "%s" i)))
 257               ;; Uses the implicit messages buffer truncation implemented
 258               ;; in Emacs' C core.
 259               (c (x)
 260                 (ert-with-buffer-renamed ("*Messages*")
 261                   (let ((message-log-max x))
 262                     (body))
 263                   (with-current-buffer "*Messages*"
 264                     (buffer-string))))
 265               ;; Uses our lisp reimplementation.
 266               (lisp (x)
 267                 (ert-with-buffer-renamed ("*Messages*")
 268                   (let ((message-log-max t))
 269                     (body))
 270                   (let ((message-log-max x))
 271                     (ert--force-message-log-buffer-truncation))
 272                   (with-current-buffer "*Messages*"
 273                     (buffer-string)))))
 274     (cl-loop for x in '(0 1 2 3 4 t) do
 275              (should (equal (c x) (lisp x))))))
 276
 277
 278 (defun ert--dummy-id (a)
 279   "Identity function.  Used for tests only."
 280   a)
 281
 282 (ert-deftest ert-with-function-mocked ()
 283   (let ((mock-id  (lambda (_) 21)))
 284     (should (eq 42 (ert--dummy-id 42)))
 285
 286     (ert-with-function-mocked ert--dummy-id nil
 287        (fset 'ert--dummy-id mock-id)
 288        (should (eq 21 (ert--dummy-id 42))))
 289     (should (eq 42 (ert--dummy-id 42)))
 290
 291     (ert-with-function-mocked ert--dummy-id mock-id
 292        (should (eq 21 (ert--dummy-id 42))))
 293     (should (eq 42 (ert--dummy-id 42)))
 294
 295     (should
 296      (catch 'exit
 297        (ert-with-function-mocked ert--dummy-id mock-id
 298          (should (eq 21 (ert--dummy-id 42))))
 299          (throw 'exit t)))
 300     (should (eq 42 (ert--dummy-id 42)))
 301
 302     (should
 303      (string= "Foo"
 304               (condition-case err
 305                   (progn
 306                     (ert-with-function-mocked ert--dummy-id mock-id
 307                       (should (eq 21 (ert--dummy-id 42))))
 308                     (user-error "Foo"))
 309                 (user-error (cadr err)))))
 310     (should (eq 42 (ert--dummy-id 42)))
 311
 312     (should
 313      (string= "`ert--dummy-id' unexpectedly called."
 314               (condition-case err
 315                   (ert-with-function-mocked ert--dummy-id nil
 316                     (ert--dummy-id 42))
 317                 (ert-test-failed (cadr err)))))
 318     (should (eq 42 (ert--dummy-id 42)))))
 319
 320
 321 (provide 'ert-x-tests)
 322
 323 ;;; ert-x-tests.el ends here