Commit | Line | Data |
---|---|---|
15c9d04e | 1 | ;;; ert-x.el --- Staging area for experimental extensions to ERT -*- lexical-binding: t -*- |
d221e780 | 2 | |
ba318903 | 3 | ;; Copyright (C) 2008, 2010-2014 Free Software Foundation, Inc. |
d221e780 CO |
4 | |
5 | ;; Author: Lennart Borgman (lennart O borgman A gmail O com) | |
389c3aa7 | 6 | ;; Christian Ohler <ohler@gnu.org> |
d221e780 CO |
7 | |
8 | ;; This file is part of GNU Emacs. | |
9 | ||
74bfe42a GM |
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 | ||
d221e780 | 20 | ;; You should have received a copy of the GNU General Public License |
74bfe42a | 21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
d221e780 CO |
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 | ||
15c9d04e | 31 | (eval-when-compile (require 'cl-lib)) |
d221e780 CO |
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 | ||
15c9d04e SM |
92 | (cl-defmacro ert-with-test-buffer ((&key ((:name name-form))) |
93 | &body body) | |
d221e780 CO |
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)) | |
15c9d04e | 118 | (maphash (lambda (buffer _dummy) |
d221e780 CO |
119 | (when (or (not (buffer-live-p buffer)) |
120 | (kill-buffer buffer)) | |
15c9d04e | 121 | (cl-incf count))) |
d221e780 CO |
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." | |
15c9d04e SM |
151 | (cl-assert (listp command) t) |
152 | (cl-assert (commandp (car command)) t) | |
153 | (cl-assert (not unread-command-events) t) | |
d221e780 CO |
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) | |
f160676e GM |
169 | (and (boundp 'deferred-action-list) |
170 | deferred-action-list | |
171 | (run-hooks 'deferred-action-function)) | |
d221e780 CO |
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)) | |
15c9d04e | 177 | (cl-assert (not unread-command-events) t) |
d221e780 CO |
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) | |
15c9d04e | 200 | (cl-destructuring-bind (regexp subexp) (if (listp x) x `(,x nil)) |
d221e780 CO |
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 | |
15c9d04e SM |
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)))) | |
d221e780 CO |
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*." | |
15c9d04e SM |
247 | (let ((new-buffer-name (generate-new-buffer-name |
248 | (format "%s orig buffer" buffer-name)))) | |
d221e780 CO |
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 | ||
15c9d04e | 260 | (cl-defmacro ert-with-buffer-renamed ((buffer-name-form) &body body) |
d221e780 CO |
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 |