Commit | Line | Data |
---|---|---|
d221e780 CO |
1 | ;;; ert-x.el --- Staging area for experimental extensions to ERT |
2 | ||
acaf905b | 3 | ;; Copyright (C) 2008, 2010-2012 Free Software Foundation, Inc. |
d221e780 CO |
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) | |
f160676e GM |
170 | (and (boundp 'deferred-action-list) |
171 | deferred-action-list | |
172 | (run-hooks 'deferred-action-function)) | |
d221e780 CO |
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 |