lisp/emacs-lisp/ert-x.el

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