-;;; async-test --- async.el-related tests
+;;; async-test.el --- async.el-related tests
-;; Copyright (C) 2012 John Wiegley
+;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
;; Author: John Wiegley <jwiegley@gmail.com>
;; Created: 10 Jul 2012
\f
;;; Code:
-(add-to-list 'load-path (file-name-directory (or load-file-name (buffer-file-name))))
(require 'async)
-(require 'async-file)
+
(eval-when-compile
(require 'cl))
(lambda (result)
(message "Async process done: %s" result))))
-(defsubst async-file-contents (file)
- "Return the contents of FILE, as a string."
- (with-temp-buffer
- (insert-file-contents file)
- (buffer-string)))
-
-(defun* async-do-copy-file-test (ok-if-already-exists
- keep-time preserve-uid-gid
- preserve-selinux-context
- &key use-native-commands
- synchronously)
- (let* ((temp-file (make-temp-file "async-do-copy-file-test"))
- (temp-file2 (concat temp-file ".target")))
- (unwind-protect
- (progn
- (with-temp-buffer
- (insert "async-do-copy-file-test")
- (write-region (point-min) (point-max) temp-file))
-
- (let* ((async-file-use-native-commands use-native-commands)
- (future (if synchronously
- (copy-file temp-file temp-file2
- ok-if-already-exists
- keep-time
- preserve-uid-gid
- preserve-selinux-context)
- (async-copy-file temp-file temp-file2
- ok-if-already-exists
- keep-time
- preserve-uid-gid
- preserve-selinux-context
- :callback nil))))
- (unless synchronously
- (if use-native-commands
- (let ((proc (async-get future)))
- (should (processp proc))
- (should (equal 'exit (process-status proc))))
- (should (equal (async-get future) nil))))
-
- (should (file-readable-p temp-file2))
-
- (should (equal "async-do-copy-file-test"
- (async-file-contents temp-file2)))))
-
- (if (file-exists-p temp-file) (delete-file temp-file))
- (if (file-exists-p temp-file2) (delete-file temp-file2)))))
-
-(ert-deftest async-copy-file-lisp-sync-1 ()
- (async-do-copy-file-test t t t nil :synchronously t))
-(ert-deftest async-copy-file-lisp-1 ()
- (async-do-copy-file-test t t t nil :use-native-commands nil))
-(ert-deftest async-copy-file-native-1 ()
- (async-do-copy-file-test t t t nil :use-native-commands t))
-
-(defsubst async-file-make-temp-dir (prefix)
- "Make a temporary directory using PREFIX.
-Return the name of the directory."
- (let ((dir (make-temp-name
- (expand-file-name prefix temporary-file-directory))))
- (make-directory dir)
- dir))
-
-(defsubst async-file-make-file (file contents)
- "Create a new FILE with the given CONTENTS."
- (with-temp-buffer
- (insert contents)
- (write-region (point-min) (point-max) file)))
-
-(defun* async-do-copy-directory-test (keep-time parents copy-contents
- &key use-native-commands
- synchronously)
- (let* ((temp-dir (async-file-make-temp-dir "async-do-copy-directory-test"))
- (temp-dir2 (concat temp-dir ".target")))
- (unwind-protect
- (progn
- (async-file-make-file (expand-file-name "foo" temp-dir) "foo")
- (async-file-make-file (expand-file-name "bar" temp-dir) "bar")
-
- ;; Shouldn't the parents argument cause this to happen when needed?
- ;; But if the following is wrapped with "unless parents", even
- ;; `async-copy-directory-lisp-sync-2' fails.
- (make-directory temp-dir2)
-
- (let* ((async-file-use-native-commands use-native-commands)
- (future (if synchronously
- (copy-directory temp-dir temp-dir2
- keep-time
- parents
- copy-contents)
- (async-copy-directory temp-dir temp-dir2
- keep-time
- parents
- copy-contents
- :callback nil))))
- (unless synchronously
- (if use-native-commands
- (let ((proc (async-get future)))
- (should (processp proc))
- (should (equal 'exit (process-status proc))))
- ;; Ignore the return value from `copy-directory'
- (async-get future)))
-
- (if (and parents copy-contents)
- (should (file-directory-p temp-dir2)))
-
- (let* ((target (if copy-contents
- temp-dir2
- (expand-file-name (file-name-nondirectory temp-dir)
- temp-dir2)))
- (foo-file (expand-file-name "foo" target))
- (bar-file (expand-file-name "bar" target)))
-
- (should (file-readable-p foo-file))
- (should (file-readable-p bar-file))
-
- (should (equal "foo" (async-file-contents foo-file)))
- (should (equal "bar" (async-file-contents bar-file))))))
-
- (if (file-directory-p temp-dir) (delete-directory temp-dir t))
- (if (file-directory-p temp-dir2) (delete-directory temp-dir2 t)))))
-
-(defun async-do-start-func-value-type-test ()
- ;; Variable
- (set 'myfunc-var (lambda () t))
- ;; Function symbol
- (fset 'myfunc-fsym myfunc-var)
- ;; Defun
- (defun myfunc-defun () t)
-
- (should-error (error "ERROR"))
-
- (should (eq t (eval '(async-sandbox myfunc-var))))
- (should-error (eval '(async-sandbox 'myfunc-var)))
- (should-error (eval '(async-sandbox #'myfunc-var)))
-
- (should-error (eval '(async-sandbox myfunc-fsym)))
- (should (eq t (eval '(async-sandbox 'myfunc-fsym))))
- (should (eq t (eval '(async-sandbox #'myfunc-fsym))))
-
- (should-error (eval '(async-sandbox myfunc-defun)))
- (should (eq t (eval '(async-sandbox 'myfunc-defun))))
- (should (eq t (eval '(async-sandbox #'myfunc-defun))))
-
- (should (eq t (eval '(async-sandbox (lambda () t)))))
- (should (eq t (eval '(async-sandbox '(lambda () t)))))
- (should (eq t (eval '(async-sandbox #'(lambda () t)))))
-
- (should-error (eval '(async-sandbox (closure (t) () t))))
- (should (eq t (eval '(async-sandbox '(closure (t) () t)))))
- (should (eq t (eval '(async-sandbox #'(closure (t) () t))))))
-
-(defun async-do-lexbind-test ()
- ;; The `cl-loop' macro creates some lexical variables, and in this
- ;; case one of those variables (the one that collects the result)
- ;; gets set to a list of process objects, which are unprintable. If
- ;; `lexical-binding' is non-nil, this unprintable value is
- ;; incorporated into the closures created by `lambda' within the
- ;; loop. Closure prevention avoids the error from this unprintable
- ;; lexical value in these examples.
- (eval
- '(progn
- (mapcar #'async-get
- (cl-loop repeat 2 collect
- (async-start (lambda () t))))
- (mapcar #'async-get
- (cl-loop repeat 2 collect
- (async-start '(lambda () t))))
- (mapcar #'async-get
- (cl-loop repeat 2 collect
- (async-start #'(lambda () t))))
- (mapcar #'async-get
- (cl-loop repeat 2 collect
- (async-start `(lambda () ,(* 150 2))))))
- t)
- ;; However closure prevention also (obviously) prevents creation of
- ;; lexical closures, leading to an error in this case.
- (should
- (eq 6
- (eval
- '(let ((x 1)
- (y 2)
- (z 3))
- (async-sandbox (lambda () (+ x y z))))
- t)
- )))
-
-(ert-deftest async-copy-directory-lisp-sync-1 ()
- (async-do-copy-directory-test t nil nil :synchronously t))
-(ert-deftest async-copy-directory-lisp-sync-2 ()
- (async-do-copy-directory-test t t nil :synchronously t))
-(ert-deftest async-copy-directory-lisp-sync-3 ()
- (async-do-copy-directory-test t nil t :synchronously t))
-(ert-deftest async-copy-directory-lisp-sync-4 ()
- (async-do-copy-directory-test t t t :synchronously t))
-
-(ert-deftest async-copy-directory-lisp-1 ()
- (async-do-copy-directory-test t nil nil :use-native-commands nil))
-(ert-deftest async-copy-directory-lisp-2 ()
- (async-do-copy-directory-test t t nil :use-native-commands nil))
-(ert-deftest async-copy-directory-lisp-3 ()
- (async-do-copy-directory-test t nil t :use-native-commands nil))
-(ert-deftest async-copy-directory-lisp-4 ()
- (async-do-copy-directory-test t t t :use-native-commands nil))
-
-(ert-deftest async-copy-directory-native-1 ()
- (async-do-copy-directory-test t nil nil :use-native-commands t))
-(ert-deftest async-copy-directory-native-2 ()
- (async-do-copy-directory-test t t nil :use-native-commands t))
-(ert-deftest async-copy-directory-native-3 ()
- (async-do-copy-directory-test t nil t :use-native-commands t))
-(ert-deftest async-copy-directory-native-4 ()
- (async-do-copy-directory-test t t t :use-native-commands t))
-
-(ert-deftest async-start-func-value-type-test ()
- (async-do-start-func-value-type-test))
-
-(ert-deftest async-lexbind-test ()
- (async-do-lexbind-test))
(provide 'async-test)
;;; async-test.el ends here
+
+;; Local Variables:
+;; no-byte-compile: t
+;; End: