lisp/emacs-lisp/ert-x.el

   1 ;;; ert-x.el --- Staging area for experimental extensions to ERT
   2
   3 ;; Copyright (C) 2008, 2010-2011 Free Software Foundation, Inc.
   4
   5 ;; Author: Lennart Borgman (lennart O borgman A gmail O com)
   6 ;; Author: 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 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     (when 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     (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       (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     (loop with current-plist = nil
 227           for x in args do
 228           (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   (lexical-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 (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