code.delx.au - gnu-emacs-elpa/blob - async-test.el

   1 ;;; async-test --- async.el-related tests
   2
   3 ;; Copyright (C) 2012 John Wiegley
   4
   5 ;; Author: John Wiegley <jwiegley@gmail.com>
   6 ;; Created: 10 Jul 2012
   7 ;; Version: 1.0
   8 ;; Keywords: async
   9 ;; X-URL: https://github.com/jwiegley/emacs-async
  10
  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.
  15
  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.
  20
  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.
  25 \f
  26 ;;; Commentary:
  27
  28 ;; Contains tests for all the async modules.
  29 \f
  30 ;;; Code:
  31
  32 (add-to-list 'load-path (file-name-directory (or load-file-name (buffer-file-name))))
  33 (require 'async)
  34 (require 'async-file)
  35
  36 (eval-when-compile
  37   (require 'cl))
  38
  39 (defun async-test-1 ()
  40   (interactive)
  41   (message "Starting async-test-1...")
  42   (async-start
  43    ;; What to do in the child process
  44    (lambda ()
  45      (message "This is a test")
  46      (sleep-for 3)
  47      222)
  48
  49    ;; What to do when it finishes
  50    (lambda (result)
  51      (message "Async process done, result should be 222: %s" result)))
  52   (message "Starting async-test-1...done"))
  53
  54 (defun async-test-2 ()
  55   (interactive)
  56   (message "Starting async-test-2...")
  57   (let ((proc (async-start
  58                ;; What to do in the child process
  59                (lambda ()
  60                  (message "This is a test")
  61                  (sleep-for 3)
  62                  222))))
  63     (message "I'm going to do some work here")
  64     ;; ....
  65     (message "Async process done, result should be 222: %s"
  66              (async-get proc))))
  67
  68 (defun async-test-3 ()
  69   (interactive)
  70   (message "Starting async-test-3...")
  71   (async-start
  72    ;; What to do in the child process
  73    (lambda ()
  74      (message "This is a test")
  75      (sleep-for 3)
  76      (error "Error in child process")
  77      222)
  78
  79    ;; What to do when it finishes
  80    (lambda (result)
  81      (message "Async process done, result should be 222: %s" result)))
  82   (message "Starting async-test-1...done"))
  83
  84 (defun async-test-4 ()
  85   (interactive)
  86   (message "Starting async-test-4...")
  87   (async-start-process "sleep" "sleep"
  88                        ;; What to do when it finishes
  89                        (lambda (proc)
  90                          (message "Sleep done, exit code was %d"
  91                                   (process-exit-status proc)))
  92                        "3")
  93   (message "Starting async-test-4...done"))
  94
  95 (defun async-test-5 ()
  96   (interactive)
  97   (message "Starting async-test-5...")
  98   (let ((proc
  99          (async-start
 100           ;; What to do in the child process
 101           (lambda ()
 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)))
 108             (sleep-for 3)
 109             222)
 110
 111           ;; What to do when it finishes
 112           (lambda (result)
 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"
 117                        result))))))
 118     (async-send proc :goodbye "everyone"))
 119   (message "Starting async-test-5...done"))
 120
 121 (defun async-test-6 ()
 122   (interactive)
 123   (message "Starting async-test-6...")
 124   (async-start
 125    ;; What to do in the child process
 126    `(lambda ()
 127       ,(async-inject-variables "\\`user-mail-address\\'")
 128       (format "user-mail-address = %s" user-mail-address))
 129
 130    ;; What to do when it finishes
 131    (lambda (result)
 132      (message "Async process done: %s" result))))
 133
 134 (defsubst async-file-contents (file)
 135   "Return the contents of FILE, as a string."
 136   (with-temp-buffer
 137     (insert-file-contents file)
 138     (buffer-string)))
 139
 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
 144                                  synchronously)
 145   (let* ((temp-file (make-temp-file "async-do-copy-file-test"))
 146          (temp-file2 (concat temp-file ".target")))
 147     (unwind-protect
 148         (progn
 149           (with-temp-buffer
 150             (insert "async-do-copy-file-test")
 151             (write-region (point-min) (point-max) temp-file))
 152
 153           (let* ((async-file-use-native-commands use-native-commands)
 154                  (future (if synchronously
 155                              (copy-file temp-file temp-file2
 156                                         ok-if-already-exists
 157                                         keep-time
 158                                         preserve-uid-gid
 159                                         preserve-selinux-context)
 160                            (async-copy-file temp-file temp-file2
 161                                             ok-if-already-exists
 162                                             keep-time
 163                                             preserve-uid-gid
 164                                             preserve-selinux-context
 165                                             :callback nil))))
 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))))
 172
 173             (should (file-readable-p temp-file2))
 174
 175             (should (equal "async-do-copy-file-test"
 176                            (async-file-contents temp-file2)))))
 177
 178       (if (file-exists-p temp-file)  (delete-file temp-file))
 179       (if (file-exists-p temp-file2) (delete-file temp-file2)))))
 180
 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))
 187
 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))))
 193     (make-directory dir)
 194     dir))
 195
 196 (defsubst async-file-make-file (file contents)
 197   "Create a new FILE with the given CONTENTS."
 198   (with-temp-buffer
 199     (insert contents)
 200     (write-region (point-min) (point-max) file)))
 201
 202 (defun* async-do-copy-directory-test (keep-time parents copy-contents
 203                                                 &key use-native-commands
 204                                                 synchronously)
 205   (let* ((temp-dir (async-file-make-temp-dir "async-do-copy-directory-test"))
 206          (temp-dir2 (concat temp-dir ".target")))
 207     (unwind-protect
 208         (progn
 209           (async-file-make-file (expand-file-name "foo" temp-dir) "foo")
 210           (async-file-make-file (expand-file-name "bar" temp-dir) "bar")
 211
 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)
 216
 217           (let* ((async-file-use-native-commands use-native-commands)
 218                  (future (if synchronously
 219                              (copy-directory temp-dir temp-dir2
 220                                              keep-time
 221                                              parents
 222                                              copy-contents)
 223                            (async-copy-directory temp-dir temp-dir2
 224                                                  keep-time
 225                                                  parents
 226                                                  copy-contents
 227                                                  :callback nil))))
 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'
 234                 (async-get future)))
 235
 236             (if (and parents copy-contents)
 237                 (should (file-directory-p temp-dir2)))
 238
 239             (let* ((target (if copy-contents
 240                                temp-dir2
 241                              (expand-file-name (file-name-nondirectory temp-dir)
 242                                                temp-dir2)))
 243                    (foo-file (expand-file-name "foo" target))
 244                    (bar-file (expand-file-name "bar" target)))
 245
 246               (should (file-readable-p foo-file))
 247               (should (file-readable-p bar-file))
 248
 249               (should (equal "foo" (async-file-contents foo-file)))
 250               (should (equal "bar" (async-file-contents bar-file))))))
 251
 252       (if (file-directory-p temp-dir)  (delete-directory temp-dir t))
 253       (if (file-directory-p temp-dir2) (delete-directory temp-dir2 t)))))
 254
 255 (defun async-do-start-func-value-type-test ()
 256   ;; Variable
 257   (set 'myfunc-var (lambda () t))
 258   ;; Function symbol
 259   (fset 'myfunc-fsym myfunc-var)
 260   ;; Defun
 261   (defun myfunc-defun () t)
 262
 263   (should-error (error "ERROR"))
 264
 265   (should (eq t (eval '(async-sandbox myfunc-var))))
 266   (should-error (eval '(async-sandbox 'myfunc-var)))
 267   (should-error (eval '(async-sandbox #'myfunc-var)))
 268
 269   (should-error (eval '(async-sandbox myfunc-fsym)))
 270   (should (eq t (eval '(async-sandbox 'myfunc-fsym))))
 271   (should (eq t (eval '(async-sandbox #'myfunc-fsym))))
 272
 273   (should-error (eval '(async-sandbox myfunc-defun)))
 274   (should (eq t (eval '(async-sandbox 'myfunc-defun))))
 275   (should (eq t (eval '(async-sandbox #'myfunc-defun))))
 276
 277   (should (eq t (eval '(async-sandbox (lambda () t)))))
 278   (should (eq t (eval '(async-sandbox '(lambda () t)))))
 279   (should (eq t (eval '(async-sandbox #'(lambda () t)))))
 280
 281   (should-error (eval '(async-sandbox (closure (t) () t))))
 282   (should (eq t (eval '(async-sandbox '(closure (t) () t)))))
 283   (should (eq t (eval '(async-sandbox #'(closure (t) () t))))))
 284
 285 (defun async-do-lexbind-test ()
 286   ;; The `cl-loop' macro creates some lexical variables, and in this
 287   ;; case one of those variables (the one that collects the result)
 288   ;; gets set to a list of process objects, which are unprintable. If
 289   ;; `lexical-binding' is non-nil, this unprintable value is
 290   ;; incorporated into the closures created by `lambda' within the lexical
 291   ;; scope of the loop, causing an error when another process tried to
 292   ;; read in the printed value. `async--sanitize-closure' should
 293   ;; prevent this by deleting the unprintable variable from the
 294   ;; closure before printing it.
 295   (eval
 296    '(progn
 297        (mapcar #'async-get
 298                (cl-loop repeat 2 collect
 299                         (async-start (lambda () t))))
 300        (mapcar #'async-get
 301                (cl-loop repeat 2 collect
 302                         (async-start '(lambda () t))))
 303        (mapcar #'async-get
 304                (cl-loop repeat 2 collect
 305                         (async-start #'(lambda () t))))
 306        (mapcar #'async-get
 307                (cl-loop repeat 2 collect
 308                         (async-start `(lambda () ,(* 150 2))))))
 309    t)
 310   ;; The following lexical closure should work fine, since x, y, and z
 311   ;; all have printable values.
 312   (should
 313    (eq 6
 314        (eval
 315         '(let ((x 1)
 316                (y 2)
 317                (z 3))
 318            (async-sandbox (lambda () (+ x y z))))
 319         t)
 320        )))
 321
 322 (ert-deftest async-copy-directory-lisp-sync-1 ()
 323   (async-do-copy-directory-test t nil nil :synchronously t))
 324 (ert-deftest async-copy-directory-lisp-sync-2 ()
 325   (async-do-copy-directory-test t t nil :synchronously t))
 326 (ert-deftest async-copy-directory-lisp-sync-3 ()
 327   (async-do-copy-directory-test t nil t :synchronously t))
 328 (ert-deftest async-copy-directory-lisp-sync-4 ()
 329   (async-do-copy-directory-test t t t :synchronously t))
 330
 331 (ert-deftest async-copy-directory-lisp-1 ()
 332   (async-do-copy-directory-test t nil nil :use-native-commands nil))
 333 (ert-deftest async-copy-directory-lisp-2 ()
 334   (async-do-copy-directory-test t t nil :use-native-commands nil))
 335 (ert-deftest async-copy-directory-lisp-3 ()
 336   (async-do-copy-directory-test t nil t :use-native-commands nil))
 337 (ert-deftest async-copy-directory-lisp-4 ()
 338   (async-do-copy-directory-test t t t :use-native-commands nil))
 339
 340 (ert-deftest async-copy-directory-native-1 ()
 341   (async-do-copy-directory-test t nil nil :use-native-commands t))
 342 (ert-deftest async-copy-directory-native-2 ()
 343   (async-do-copy-directory-test t t nil :use-native-commands t))
 344 (ert-deftest async-copy-directory-native-3 ()
 345   (async-do-copy-directory-test t nil t :use-native-commands t))
 346 (ert-deftest async-copy-directory-native-4 ()
 347   (async-do-copy-directory-test t t t :use-native-commands t))
 348
 349 (ert-deftest async-start-func-value-type-test ()
 350   (async-do-start-func-value-type-test))
 351
 352 (ert-deftest async-lexbind-test ()
 353   (async-do-lexbind-test))
 354
 355 (provide 'async-test)
 356
 357 ;;; async-test.el ends here