lisp/emacs-lisp/ert-x.el

   1 ;;; ert-x.el --- Staging area for experimental extensions to ERT  -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2008, 2010-2013 Free Software Foundation, Inc.
   4
   5 ;; Author: Lennart Borgman (lennart O borgman A gmail O com)
   6 ;;         Christian Ohler <ohler@gnu.org>
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; This file includes some extra helper functions to use while writing
  26 ;; automated tests with ERT.  These have been proposed as extensions
  27 ;; to ERT but are not mature yet and likely to change.
  28
  29 ;;; Code:
  30
  31 (eval-when-compile (require 'cl-lib))
  32 (require 'ert)
  33
  34
  35 ;;; Test buffers.
  36
  37 (defun ert--text-button (string &rest properties)
  38   "Return a string containing STRING as a text button with PROPERTIES.
  39
  40 See `make-text-button'."
  41   (with-temp-buffer
  42     (insert string)
  43     (apply #'make-text-button (point-min) (point-max) properties)
  44     (buffer-string)))
  45
  46 (defun ert--format-test-buffer-name (base-name)
  47   "Compute a test buffer name based on BASE-NAME.
  48
  49 Helper function for `ert--test-buffers'."
  50   (format "*Test buffer (%s)%s*"
  51           (or (and (ert-running-test)
  52                    (ert-test-name (ert-running-test)))
  53               "<anonymous test>")
  54           (if base-name
  55               (format ": %s" base-name)
  56             "")))
  57
  58 (defvar ert--test-buffers (make-hash-table :weakness t)
  59   "Table of all test buffers.  Keys are the buffer objects, values are t.
  60
  61 The main use of this table is for `ert-kill-all-test-buffers'.
  62 Not all buffers in this table are necessarily live, but all live
  63 test buffers are in this table.")
  64
  65 (define-button-type 'ert--test-buffer-button
  66   'action #'ert--test-buffer-button-action
  67   'help-echo "mouse-2, RET: Pop to test buffer")
  68
  69 (defun ert--test-buffer-button-action (button)
  70   "Pop to the test buffer that BUTTON is associated with."
  71   (pop-to-buffer (button-get button 'ert--test-buffer)))
  72
  73 (defun ert--call-with-test-buffer (ert--base-name ert--thunk)
  74   "Helper function for `ert-with-test-buffer'.
  75
  76 Create a test buffer with a name based on ERT--BASE-NAME and run
  77 ERT--THUNK with that buffer as current."
  78   (let* ((ert--buffer (generate-new-buffer
  79                        (ert--format-test-buffer-name ert--base-name)))
  80          (ert--button (ert--text-button (buffer-name ert--buffer)
  81                                         :type 'ert--test-buffer-button
  82                                         'ert--test-buffer ert--buffer)))
  83     (puthash ert--buffer 't ert--test-buffers)
  84     ;; We don't use `unwind-protect' here since we want to kill the
  85     ;; buffer only on success.
  86     (prog1 (with-current-buffer ert--buffer
  87              (ert-info (ert--button :prefix "Buffer: ")
  88                (funcall ert--thunk)))
  89       (kill-buffer ert--buffer)
  90       (remhash ert--buffer ert--test-buffers))))
  91
  92 (cl-defmacro ert-with-test-buffer ((&key ((:name name-form)))
  93                                    &body body)
  94   "Create a test buffer and run BODY in that buffer.
  95
  96 To be used in ERT tests.  If BODY finishes successfully, the test
  97 buffer is killed; if there is an error, the test buffer is kept
  98 around on error for further inspection.  Its name is derived from
  99 the name of the test and the result of NAME-FORM."
 100   (declare (debug ((form) body))
 101            (indent 1))
 102   `(ert--call-with-test-buffer ,name-form (lambda () ,@body)))
 103
 104 ;; We use these `put' forms in addition to the (declare (indent)) in
 105 ;; the defmacro form since the `declare' alone does not lead to
 106 ;; correct indentation before the .el/.elc file is loaded.
 107 ;; Autoloading these `put' forms solves this.
 108 ;;;###autoload
 109 (progn
 110   ;; TODO(ohler): Figure out what these mean and make sure they are correct.
 111   (put 'ert-with-test-buffer 'lisp-indent-function 1))
 112
 113 ;;;###autoload
 114 (defun ert-kill-all-test-buffers ()
 115   "Kill all test buffers that are still live."
 116   (interactive)
 117   (let ((count 0))
 118     (maphash (lambda (buffer _dummy)
 119                (when (or (not (buffer-live-p buffer))
 120                          (kill-buffer buffer))
 121                  (cl-incf count)))
 122              ert--test-buffers)
 123     (message "%s out of %s test buffers killed"
 124              count (hash-table-count ert--test-buffers)))
 125   ;; It could be that some test buffers were actually kept alive
 126   ;; (e.g., due to `kill-buffer-query-functions').  I'm not sure what
 127   ;; to do about this.  For now, let's just forget them.
 128   (clrhash ert--test-buffers)
 129   nil)
 130
 131
 132 ;;; Simulate commands.
 133
 134 (defun ert-simulate-command (command)
 135   ;; FIXME: add unread-events
 136   "Simulate calling COMMAND the way the Emacs command loop would call it.
 137
 138 This effectively executes
 139
 140   \(apply (car COMMAND) (cdr COMMAND)\)
 141
 142 and returns the same value, but additionally runs hooks like
 143 `pre-command-hook' and `post-command-hook', and sets variables
 144 like `this-command' and `last-command'.
 145
 146 COMMAND should be a list where the car is the command symbol and
 147 the rest are arguments to the command.
 148
 149 NOTE: Since the command is not called by `call-interactively'
 150 test for `called-interactively' in the command will fail."
 151   (cl-assert (listp command) t)
 152   (cl-assert (commandp (car command)) t)
 153   (cl-assert (not unread-command-events) t)
 154   (let (return-value)
 155     ;; For the order of things here see command_loop_1 in keyboard.c.
 156     ;;
 157     ;; The command loop will reset the command-related variables so
 158     ;; there is no reason to let-bind them. They are set here,
 159     ;; however, to be able to test several commands in a row and how
 160     ;; they affect each other.
 161     (setq deactivate-mark nil
 162           this-original-command (car command)
 163           ;; remap through active keymaps
 164           this-command (or (command-remapping this-original-command)
 165                            this-original-command))
 166     (run-hooks 'pre-command-hook)
 167     (setq return-value (apply (car command) (cdr command)))
 168     (run-hooks 'post-command-hook)
 169     (and (boundp 'deferred-action-list)
 170          deferred-action-list
 171          (run-hooks 'deferred-action-function))
 172     (setq real-last-command (car command)
 173           last-command this-command)
 174     (when (boundp 'last-repeatable-command)
 175       (setq last-repeatable-command real-last-command))
 176     (when (and deactivate-mark transient-mark-mode) (deactivate-mark))
 177     (cl-assert (not unread-command-events) t)
 178     return-value))
 179
 180 (defun ert-run-idle-timers ()
 181   "Run all idle timers (from `timer-idle-list')."
 182   (dolist (timer (copy-sequence timer-idle-list))
 183     (timer-event-handler timer)))
 184
 185
 186 ;;; Miscellaneous utilities.
 187
 188 (defun ert-filter-string (s &rest regexps)
 189   "Return a copy of S with all matches of REGEXPS removed.
 190
 191 Elements of REGEXPS may also be two-element lists \(REGEXP
 192 SUBEXP\), where SUBEXP is the number of a subexpression in
 193 REGEXP.  In that case, only that subexpression will be removed
 194 rather than the entire match."
 195   ;; Use a temporary buffer since replace-match copies strings, which
 196   ;; would lead to N^2 runtime.
 197   (with-temp-buffer
 198     (insert s)
 199     (dolist (x regexps)
 200       (cl-destructuring-bind (regexp subexp) (if (listp x) x `(,x nil))
 201         (goto-char (point-min))
 202         (while (re-search-forward regexp nil t)
 203           (replace-match "" t t nil subexp))))
 204     (buffer-string)))
 205
 206
 207 (defun ert-propertized-string (&rest args)
 208   "Return a string with properties as specified by ARGS.
 209
 210 ARGS is a list of strings and plists.  The strings in ARGS are
 211 concatenated to produce an output string.  In the output string,
 212 each string from ARGS will be have the preceding plist as its
 213 property list, or no properties if there is no plist before it.
 214
 215 As a simple example,
 216
 217 \(ert-propertized-string \"foo \" '(face italic) \"bar\" \" baz\" nil \
 218 \" quux\"\)
 219
 220 would return the string \"foo bar baz quux\" where the substring
 221 \"bar baz\" has a `face' property with the value `italic'.
 222
 223 None of the ARGS are modified, but the return value may share
 224 structure with the plists in ARGS."
 225   (with-temp-buffer
 226     (cl-loop with current-plist = nil
 227              for x in args do
 228              (cl-etypecase x
 229                (string (let ((begin (point)))
 230                          (insert x)
 231                          (set-text-properties begin (point) current-plist)))
 232                (list (unless (zerop (mod (length x) 2))
 233                        (error "Odd number of args in plist: %S" x))
 234                      (setq current-plist x))))
 235     (buffer-string)))
 236
 237
 238 (defun ert-call-with-buffer-renamed (buffer-name thunk)
 239   "Protect the buffer named BUFFER-NAME from side-effects and run THUNK.
 240
 241 Renames the buffer BUFFER-NAME to a new temporary name, creates a
 242 new buffer named BUFFER-NAME, executes THUNK, kills the new
 243 buffer, and renames the original buffer back to BUFFER-NAME.
 244
 245 This is useful if THUNK has undesirable side-effects on an Emacs
 246 buffer with a fixed name such as *Messages*."
 247   (let ((new-buffer-name (generate-new-buffer-name
 248                           (format "%s orig buffer" buffer-name))))
 249     (with-current-buffer (get-buffer-create buffer-name)
 250       (rename-buffer new-buffer-name))
 251     (unwind-protect
 252         (progn
 253           (get-buffer-create buffer-name)
 254           (funcall thunk))
 255       (when (get-buffer buffer-name)
 256         (kill-buffer buffer-name))
 257       (with-current-buffer new-buffer-name
 258         (rename-buffer buffer-name)))))
 259
 260 (cl-defmacro ert-with-buffer-renamed ((buffer-name-form) &body body)
 261   "Protect the buffer named BUFFER-NAME from side-effects and run BODY.
 262
 263 See `ert-call-with-buffer-renamed' for details."
 264   (declare (indent 1))
 265   `(ert-call-with-buffer-renamed ,buffer-name-form (lambda () ,@body)))
 266
 267
 268 (defun ert-buffer-string-reindented (&optional buffer)
 269   "Return the contents of BUFFER after reindentation.
 270
 271 BUFFER defaults to current buffer.  Does not modify BUFFER."
 272   (with-current-buffer (or buffer (current-buffer))
 273     (let ((clone nil))
 274       (unwind-protect
 275           (progn
 276             ;; `clone-buffer' doesn't work if `buffer-file-name' is non-nil.
 277             (let ((buffer-file-name nil))
 278               (setq clone (clone-buffer)))
 279             (with-current-buffer clone
 280               (let ((inhibit-read-only t))
 281                 (indent-region (point-min) (point-max)))
 282               (buffer-string)))
 283         (when clone
 284           (let ((kill-buffer-query-functions nil))
 285             (kill-buffer clone)))))))
 286
 287
 288 (provide 'ert-x)
 289
 290 ;;; ert-x.el ends here