1 ;;; async-test --- async.el-related tests
3 ;; Copyright (C) 2012 John Wiegley
5 ;; Author: John Wiegley <jwiegley@gmail.com>
6 ;; Created: 10 Jul 2012
9 ;; X-URL: https://github.com/jwiegley/emacs-async
11 ;; This program is free software; you can redistribute it and/or
12 ;; modify it under the terms of the GNU General Public License as
13 ;; published by the Free Software Foundation; either version 2, or (at
14 ;; your option) any later version.
16 ;; This program is distributed in the hope that it will be useful, but
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19 ;; General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
28 ;; Contains tests for all the async modules.
32 (add-to-list 'load-path (file-name-directory (or load-file-name (buffer-file-name))))
39 (defun async-test-1 ()
41 (message "Starting async-test-1...")
43 ;; What to do in the child process
45 (message "This is a test")
49 ;; What to do when it finishes
51 (message "Async process done, result should be 222: %s" result)))
52 (message "Starting async-test-1...done"))
54 (defun async-test-2 ()
56 (message "Starting async-test-2...")
57 (let ((proc (async-start
58 ;; What to do in the child process
60 (message "This is a test")
63 (message "I'm going to do some work here")
65 (message "Async process done, result should be 222: %s"
68 (defun async-test-3 ()
70 (message "Starting async-test-3...")
72 ;; What to do in the child process
74 (message "This is a test")
76 (error "Error in child process")
79 ;; What to do when it finishes
81 (message "Async process done, result should be 222: %s" result)))
82 (message "Starting async-test-1...done"))
84 (defun async-test-4 ()
86 (message "Starting async-test-4...")
87 (async-start-process "sleep" "sleep"
88 ;; What to do when it finishes
90 (message "Sleep done, exit code was %d"
91 (process-exit-status proc)))
93 (message "Starting async-test-4...done"))
95 (defun async-test-5 ()
97 (message "Starting async-test-5...")
100 ;; What to do in the child process
102 (message "This is a test, sending message")
103 (async-send :hello "world")
104 ;; wait for a message
105 (let ((msg (async-receive)))
106 (message "Child got message: %s"
107 (plist-get msg :goodbye)))
111 ;; What to do when it finishes
113 (if (async-message-p result)
114 (message "Got hello from child process: %s"
115 (plist-get result :hello))
116 (message "Async process done, result should be 222: %s"
118 (async-send proc :goodbye "everyone"))
119 (message "Starting async-test-5...done"))
121 (defun async-test-6 ()
123 (message "Starting async-test-6...")
125 ;; What to do in the child process
127 ,(async-inject-variables "\\`user-mail-address\\'")
128 (format "user-mail-address = %s" user-mail-address))
130 ;; What to do when it finishes
132 (message "Async process done: %s" result))))
134 (defsubst async-file-contents (file)
135 "Return the contents of FILE, as a string."
137 (insert-file-contents file)
140 (defun* async-do-copy-file-test (ok-if-already-exists
141 keep-time preserve-uid-gid
142 preserve-selinux-context
143 &key use-native-commands
145 (let* ((temp-file (make-temp-file "async-do-copy-file-test"))
146 (temp-file2 (concat temp-file ".target")))
150 (insert "async-do-copy-file-test")
151 (write-region (point-min) (point-max) temp-file))
153 (let* ((async-file-use-native-commands use-native-commands)
154 (future (if synchronously
155 (copy-file temp-file temp-file2
159 preserve-selinux-context)
160 (async-copy-file temp-file temp-file2
164 preserve-selinux-context
166 (unless synchronously
167 (if use-native-commands
168 (let ((proc (async-get future)))
169 (should (processp proc))
170 (should (equal 'exit (process-status proc))))
171 (should (equal (async-get future) nil))))
173 (should (file-readable-p temp-file2))
175 (should (equal "async-do-copy-file-test"
176 (async-file-contents temp-file2)))))
178 (if (file-exists-p temp-file) (delete-file temp-file))
179 (if (file-exists-p temp-file2) (delete-file temp-file2)))))
181 (ert-deftest async-copy-file-lisp-sync-1 ()
182 (async-do-copy-file-test t t t nil :synchronously t))
183 (ert-deftest async-copy-file-lisp-1 ()
184 (async-do-copy-file-test t t t nil :use-native-commands nil))
185 (ert-deftest async-copy-file-native-1 ()
186 (async-do-copy-file-test t t t nil :use-native-commands t))
188 (defsubst async-file-make-temp-dir (prefix)
189 "Make a temporary directory using PREFIX.
190 Return the name of the directory."
191 (let ((dir (make-temp-name
192 (expand-file-name prefix temporary-file-directory))))
196 (defsubst async-file-make-file (file contents)
197 "Create a new FILE with the given CONTENTS."
200 (write-region (point-min) (point-max) file)))
202 (defun* async-do-copy-directory-test (keep-time parents copy-contents
203 &key use-native-commands
205 (let* ((temp-dir (async-file-make-temp-dir "async-do-copy-directory-test"))
206 (temp-dir2 (concat temp-dir ".target")))
209 (async-file-make-file (expand-file-name "foo" temp-dir) "foo")
210 (async-file-make-file (expand-file-name "bar" temp-dir) "bar")
212 ;; Shouldn't the parents argument cause this to happen when needed?
213 ;; But if the following is wrapped with "unless parents", even
214 ;; `async-copy-directory-lisp-sync-2' fails.
215 (make-directory temp-dir2)
217 (let* ((async-file-use-native-commands use-native-commands)
218 (future (if synchronously
219 (copy-directory temp-dir temp-dir2
223 (async-copy-directory temp-dir temp-dir2
228 (unless synchronously
229 (if use-native-commands
230 (let ((proc (async-get future)))
231 (should (processp proc))
232 (should (equal 'exit (process-status proc))))
233 ;; Ignore the return value from `copy-directory'
236 (if (and parents copy-contents)
237 (should (file-directory-p temp-dir2)))
239 (let* ((target (if copy-contents
241 (expand-file-name (file-name-nondirectory temp-dir)
243 (foo-file (expand-file-name "foo" target))
244 (bar-file (expand-file-name "bar" target)))
246 (should (file-readable-p foo-file))
247 (should (file-readable-p bar-file))
249 (should (equal "foo" (async-file-contents foo-file)))
250 (should (equal "bar" (async-file-contents bar-file))))))
252 (if (file-directory-p temp-dir) (delete-directory temp-dir t))
253 (if (file-directory-p temp-dir2) (delete-directory temp-dir2 t)))))
255 (defun async-do-lexbind-test ()
256 ;; The `cl-loop' macro creates some lexical variables, and in this
257 ;; case one of those variables (the one that collects the result)
258 ;; gets set to a list of process objects, which are unprintable. If
259 ;; `lexical-binding' is non-nil, this unprintable value is
260 ;; incorporated into the closures created by `lambda' within the
261 ;; loop. Closure prevention avoids the error from this unprintable
262 ;; lexical value in these examples.
266 (cl-loop repeat 2 collect
267 (async-start (lambda () t))))
269 (cl-loop repeat 2 collect
270 (async-start '(lambda () t))))
272 (cl-loop repeat 2 collect
273 (async-start #'(lambda () t))))
275 (cl-loop repeat 2 collect
276 (async-start `(lambda () ,(* 150 2))))))
278 ;; However closure prevention also (obviously) prevents creation of
279 ;; lexical closures, leading to an error in this case.
286 (async-sandbox (lambda () (+ x y z))))
290 (ert-deftest async-copy-directory-lisp-sync-1 ()
291 (async-do-copy-directory-test t nil nil :synchronously t))
292 (ert-deftest async-copy-directory-lisp-sync-2 ()
293 (async-do-copy-directory-test t t nil :synchronously t))
294 (ert-deftest async-copy-directory-lisp-sync-3 ()
295 (async-do-copy-directory-test t nil t :synchronously t))
296 (ert-deftest async-copy-directory-lisp-sync-4 ()
297 (async-do-copy-directory-test t t t :synchronously t))
299 (ert-deftest async-copy-directory-lisp-1 ()
300 (async-do-copy-directory-test t nil nil :use-native-commands nil))
301 (ert-deftest async-copy-directory-lisp-2 ()
302 (async-do-copy-directory-test t t nil :use-native-commands nil))
303 (ert-deftest async-copy-directory-lisp-3 ()
304 (async-do-copy-directory-test t nil t :use-native-commands nil))
305 (ert-deftest async-copy-directory-lisp-4 ()
306 (async-do-copy-directory-test t t t :use-native-commands nil))
308 (ert-deftest async-copy-directory-native-1 ()
309 (async-do-copy-directory-test t nil nil :use-native-commands t))
310 (ert-deftest async-copy-directory-native-2 ()
311 (async-do-copy-directory-test t t nil :use-native-commands t))
312 (ert-deftest async-copy-directory-native-3 ()
313 (async-do-copy-directory-test t nil t :use-native-commands t))
314 (ert-deftest async-copy-directory-native-4 ()
315 (async-do-copy-directory-test t t t :use-native-commands t))
317 (ert-deftest async-lexbind-test ()
318 (async-do-lexbind-test))
320 (provide 'async-test)
322 ;;; async-test.el ends here