1138 lines
33 KiB
EmacsLisp
1138 lines
33 KiB
EmacsLisp
;;; test code for deferred.el -*- lexical-binding: t; -*-
|
||
|
||
;; Copyright (C) 2010, 2011 SAKURAI Masashi
|
||
;; Author: SAKURAI Masashi <m.sakurai at kiwanami.net>
|
||
|
||
;; This program is free software; you can redistribute it and/or modify
|
||
;; it under the terms of the GNU General Public License as published by
|
||
;; the Free Software Foundation, either version 3 of the License, or
|
||
;; (at your option) any later version.
|
||
|
||
;; This program is distributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;; GNU General Public License for more details.
|
||
|
||
;; You should have received a copy of the GNU General Public License
|
||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
;;; Commentary:
|
||
|
||
;; Run tests:
|
||
;; $ emacs -batch -l test-deferred.el -f ert-run-tests-batch-and-exit
|
||
|
||
|
||
(require 'ert)
|
||
(require 'undercover)
|
||
(undercover "deferred.el"
|
||
(:send-report nil)
|
||
(:report-file "/tmp/undercover-report.json"))
|
||
(require 'deferred)
|
||
(require 'cl-lib)
|
||
(require 'pp)
|
||
|
||
(defmacro should= (a &rest b)
|
||
`(should (equal ,a (progn ,@b)))
|
||
)
|
||
|
||
(defmacro aand (test &rest rest)
|
||
`(let ((it ,test))
|
||
(if it ,(if rest (macroexpand-all `(aand ,@rest)) 'it))))
|
||
|
||
(defmacro $ (&rest elements)
|
||
`(let (it)
|
||
,@(cl-loop for i in elements
|
||
with it = nil
|
||
collect
|
||
`(setq it ,i))
|
||
it))
|
||
|
||
(defmacro dnew(&rest aforms)
|
||
(if aforms
|
||
`(deferred:new (lambda (x) ,@aforms))
|
||
`(deferred:new)))
|
||
|
||
(defmacro next(&rest aforms)
|
||
`(deferred:next (lambda (x) ,@aforms)))
|
||
|
||
(defmacro nextc(d &rest aforms)
|
||
`(deferred:nextc ,d (lambda (x) ,@aforms)))
|
||
|
||
(defmacro errorc(d &rest aforms)
|
||
`(deferred:error ,d (lambda (e) ,@aforms)))
|
||
|
||
(defmacro errorf(d formatstr)
|
||
`(deferred:error ,d (lambda (e) (error ,formatstr e))))
|
||
|
||
(defmacro cancelc(d)
|
||
`(deferred:cancel ,d))
|
||
|
||
(defmacro wait(msec)
|
||
`(deferred:wait ,msec))
|
||
|
||
(defmacro dloop(&rest body)
|
||
`(deferred:loop ,@body))
|
||
|
||
(defmacro parallel(&rest args)
|
||
`(deferred:parallel ,@args))
|
||
|
||
(defmacro earlier(&rest args)
|
||
`(deferred:earlier ,@args))
|
||
|
||
(defmacro flush ()
|
||
`(deferred:flush-queue!))
|
||
|
||
(defmacro clear ()
|
||
`(setq deferred:queue nil))
|
||
|
||
(defmacro dtest (&rest form)
|
||
`(progn
|
||
(clear)
|
||
(let (last-value)
|
||
(nextc
|
||
($
|
||
,@form)
|
||
(setq last-value x))
|
||
(flush)
|
||
last-value)))
|
||
|
||
(defmacro wtest (time &rest form)
|
||
`(progn
|
||
(clear)
|
||
(let (last-value)
|
||
(nextc
|
||
($
|
||
,@form)
|
||
(setq last-value x))
|
||
(while (null last-value)
|
||
(sit-for ,time))
|
||
(flush)
|
||
last-value)))
|
||
|
||
(defun deferred:setTimeout (f _msec)
|
||
"overrided for test"
|
||
(deferred:call f))
|
||
|
||
(defun deferred:cancelTimeout (id)
|
||
"overrided for test"
|
||
(when (deferred-p id)
|
||
(deferred:cancel id)))
|
||
|
||
(defun deferred:run-with-idle-timer (_sec f)
|
||
"overrided for test"
|
||
(deferred:call f))
|
||
|
||
(defun deferred:not-called-func (&optional m)
|
||
(error "Must not be called!! %s" m))
|
||
|
||
|
||
|
||
(ert-deftest deferred-primitive-simple ()
|
||
"> call-lambda simple"
|
||
(should= 1 (deferred:call-lambda (lambda () 1)))
|
||
(should= 1 (deferred:call-lambda (lambda () 1) 1))
|
||
(should= 1 (deferred:call-lambda (lambda (_) 1)))
|
||
(should= 1 (deferred:call-lambda (lambda (_) 1) 1))
|
||
(should= 1 (deferred:call-lambda (deferred:lambda () 1)))
|
||
(should= 1 (deferred:call-lambda (deferred:lambda () 1) 1))
|
||
(should= nil (deferred:call-lambda 'car))
|
||
(should= 2 (deferred:call-lambda 'car '(2 1)))
|
||
(should= nil (deferred:call-lambda (symbol-function 'car)))
|
||
(should= 2 (deferred:call-lambda (symbol-function 'car) '(2 1))))
|
||
|
||
(ert-deftest deferred-primitive-scope ()
|
||
"> call-lambda lexical-scope"
|
||
(should= 3 (let ((st 1))
|
||
(deferred:call-lambda
|
||
(lambda () (+ st 2)))))
|
||
(should= 3 (let ((st 1))
|
||
(deferred:call-lambda
|
||
(lambda () (+ st 2)) 0)))
|
||
(should= 3 (let ((st 1))
|
||
(deferred:call-lambda
|
||
(lambda (_) (+ st 2)))))
|
||
(should= 3 (let ((st 1))
|
||
(deferred:call-lambda
|
||
(lambda (_) (+ st 2)) 0))))
|
||
|
||
(when (version<= "25.0" emacs-version)
|
||
;; Emacs 24 doesn’t know how to byte-compile closures, so run this test only
|
||
;; under Emacs 25.
|
||
(ert-deftest deferred-primitive-compile ()
|
||
"> call-lambda byte-compile"
|
||
(should= 1 (deferred:call-lambda (byte-compile (lambda (_) 1))))
|
||
(should= 1 (deferred:call-lambda (byte-compile (lambda (_) 1)) 1))
|
||
(should= 1 (deferred:call-lambda (byte-compile (lambda () 1))))
|
||
(should= 1 (deferred:call-lambda (byte-compile (lambda () 1)) 1))
|
||
|
||
(should= 3 (let ((st 1))
|
||
(deferred:call-lambda
|
||
(byte-compile (lambda () (+ st 2))))))
|
||
(should= 3 (let ((st 1)) ;ng
|
||
(deferred:call-lambda
|
||
(byte-compile (lambda () (+ st 2))) 0)))
|
||
(should= 3 (let ((st 1))
|
||
(deferred:call-lambda
|
||
(byte-compile (lambda (_) (+ st 2))))))
|
||
(should= 3 (let ((st 1)) ;ng
|
||
(deferred:call-lambda
|
||
(byte-compile (lambda (_) (+ st 2))) 0)))
|
||
|
||
(should-error
|
||
(deferred:call-lambda
|
||
(lambda (x) (signal 'wrong-number-of-arguments '("org"))))
|
||
:type 'wrong-number-of-arguments)))
|
||
|
||
(ert-deftest deferred-basic ()
|
||
"Basic test for deferred functions."
|
||
(should (deferred-p
|
||
;; function test
|
||
(deferred:new)))
|
||
(should (null
|
||
;; basic cancel test
|
||
(let ((d (deferred:next 'deferred:not-called-func)))
|
||
(cancelc d)
|
||
(flush))))
|
||
(should (deferred-p
|
||
;; basic post function test
|
||
(progn
|
||
(clear)
|
||
(let ((d (dnew)))
|
||
(nextc d x)
|
||
(deferred:exec-task d 'ok "ok!")))))
|
||
(should (deferred-p
|
||
;; basic error post function test
|
||
(progn
|
||
(clear)
|
||
(let ((d (dnew)))
|
||
(deferred:error d (lambda (e) e))
|
||
(deferred:exec-task d 'ng "error"))))))
|
||
|
||
(ert-deftest deferred-basic-result-propagation ()
|
||
"> result propagation"
|
||
(should= 'ok
|
||
;; value saving test
|
||
(let ((d (deferred:succeed 1)))
|
||
(deferred:status d)))
|
||
|
||
(should= 1
|
||
;; value saving test
|
||
(let ((d (deferred:succeed 1)))
|
||
(deferred-value d)))
|
||
|
||
(should= nil
|
||
;; value clearing test
|
||
(let ((d (deferred:succeed 1)))
|
||
(deferred:set-next d (dnew))
|
||
(deferred:status d)))
|
||
|
||
(should= 1
|
||
;; value propagating test
|
||
(let ((d (deferred:succeed 1))
|
||
(nd (dnew)))
|
||
(deferred:set-next d nd)
|
||
(deferred-value nd))))
|
||
|
||
(ert-deftest deferred-basic-error-propagation ()
|
||
"> error propagation"
|
||
(should= 'ok
|
||
;; value saving test
|
||
(let ((d (deferred:succeed 1)))
|
||
(deferred:status d)))
|
||
|
||
(should= 1
|
||
;; value saving test
|
||
(let ((d (deferred:succeed 1)))
|
||
(deferred-value d)))
|
||
|
||
(should= nil
|
||
;; value clearing test
|
||
(let ((d (deferred:succeed 1)))
|
||
(deferred:set-next d (dnew))
|
||
(deferred:status d)))
|
||
|
||
(should= 1
|
||
;; value propagating test
|
||
(let ((d (deferred:succeed 1))
|
||
(nd (dnew)))
|
||
(deferred:set-next d nd)
|
||
(deferred-value nd))))
|
||
|
||
(ert-deftest deferred-main-chain ()
|
||
">>> Main Test / Chaining"
|
||
|
||
(should= '(2 1 0)
|
||
;; basic deferred chain test
|
||
(clear)
|
||
(let (vs)
|
||
($ (next (push 1 vs))
|
||
(nextc it (push 2 vs)))
|
||
(push 0 vs)
|
||
(flush)
|
||
vs))
|
||
|
||
(should= "errorback called"
|
||
;; basic errorback test
|
||
(dtest (next (error "errorback"))
|
||
(errorc it (concat (cadr e) " called"))))
|
||
|
||
(should= "next callback called"
|
||
;; error recovery test
|
||
(dtest
|
||
(next (error "callback called"))
|
||
(errorc it (cadr e))
|
||
(nextc it (concat "next " x))))
|
||
|
||
(should= '(error "second errorback called")
|
||
;; error recovery test 2
|
||
(dtest
|
||
(next (error "callback called"))
|
||
(nextc it (deferred:not-called-func "second errorback1"))
|
||
(errorc it e)
|
||
(errorc it (deferred:not-called-func "second errorback2"))
|
||
(nextc it (error "second errorback called"))
|
||
(nextc it "skipped")
|
||
(errorc it e)))
|
||
|
||
(should= "start errorback ok1"
|
||
;; start errorback test1
|
||
(let (message-log-max)
|
||
(cl-letf (((symbol-function 'message) (lambda (&rest args) args)))
|
||
(let ((d (dnew)))
|
||
(dtest
|
||
(progn
|
||
(deferred:errorback d "start errorback") d)
|
||
(nextc it (deferred:not-called-func "ERROR : start errorback"))
|
||
(errorc it (cadr e))
|
||
(nextc it (concat x " ok1")))))))
|
||
|
||
(should= "post errorback ok2"
|
||
;; start errorback test1
|
||
(let ((d (dnew)))
|
||
(dtest
|
||
(progn (deferred:errorback-post d "post errorback") d)
|
||
(nextc it (deferred:not-called-func "ERROR : post errorback"))
|
||
(errorc it (cadr e))
|
||
(nextc it (concat x " ok2")))))
|
||
|
||
(should= "Child deferred chain"
|
||
;; child deferred chain test
|
||
(dtest
|
||
(next
|
||
(next "Child deferred chain"))
|
||
(errorf it "Error on simple chain : %s")))
|
||
|
||
(should= "chain watch ok"
|
||
;; watch chain: normal
|
||
(let ((val "><"))
|
||
(dtest
|
||
(next "chain")
|
||
(deferred:watch it
|
||
(lambda (_) (setq val " watch") nil))
|
||
(nextc it (concat x val " ok")))))
|
||
|
||
(should= "error!! watch ok"
|
||
;; watch chain: error
|
||
(let ((val "><"))
|
||
(dtest
|
||
(next "chain")
|
||
(nextc it (error "error!!"))
|
||
(deferred:watch it (lambda (x) (setq val " watch") nil))
|
||
(errorc it (concat (cadr e) val " ok")))))
|
||
|
||
(should= "chain watch ok2"
|
||
;; watch chain: normal
|
||
(let ((val "><"))
|
||
(dtest
|
||
(next "chain")
|
||
(deferred:watch it
|
||
(lambda (_) (error "ERROR")))
|
||
(nextc it (concat x " watch ok2"))))))
|
||
|
||
(ert-deftest deferred-async-connect ()
|
||
"> async connect"
|
||
(should= "saved result!"
|
||
;; asynchronously connect deferred and propagate a value
|
||
(let (d ret)
|
||
(clear)
|
||
(setq d (next "saved "))
|
||
(deferred:callback d)
|
||
(flush)
|
||
(setq d (nextc d (concat x "result")))
|
||
(nextc d (setq ret (concat x "!")))
|
||
ret)))
|
||
|
||
(ert-deftest deferred-global-onerror ()
|
||
"> global onerror"
|
||
(should= "ONERROR"
|
||
;; default onerror handler test
|
||
(let (ret)
|
||
(let ((deferred:onerror
|
||
(lambda (e) (setq ret (concat "ON" (error-message-string e))))))
|
||
(dtest
|
||
(next (error "ERROR")))
|
||
ret))))
|
||
|
||
(ert-deftest deferred-async-call ()
|
||
"> async call"
|
||
(should= "ASYNC CALL"
|
||
;; basic async 'call' test
|
||
(dtest
|
||
(deferred:call 'concat "ASYNC" " " "CALL")))
|
||
|
||
(should= "ASYNC APPLY"
|
||
;; basic async 'apply' test
|
||
(dtest
|
||
(deferred:apply 'concat '("ASYNC" " " "APPLY")))))
|
||
|
||
(ert-deftest deferred-wait ()
|
||
"> wait"
|
||
(should= "wait ok"
|
||
;; basic wait test
|
||
(dtest
|
||
(wait 1)
|
||
(nextc it (if (< x 300) "wait ok" x))
|
||
(errorf it "Error on simple wait : %s")))
|
||
|
||
(should= "waitc ok"
|
||
;; wait chain test
|
||
(dtest
|
||
(wait 1)
|
||
(nextc it "wait")
|
||
(nextc it (wait 1))
|
||
(nextc it (if (< x 300) "waitc ok" x))
|
||
(errorf it "Error on simple wait chain : %s")))
|
||
|
||
(should= nil
|
||
;; wait cancel test
|
||
(dtest
|
||
(wait 1000)
|
||
(cancelc it)
|
||
(nextc it (deferred:not-called-func "wait cancel"))))
|
||
|
||
(should= "wait-idle ok"
|
||
;; basic wait test
|
||
(dtest
|
||
(deferred:wait-idle 1)
|
||
(nextc it (if (< x 300) "wait-idle ok" x))
|
||
(errorf it "Error on simple wait-idle : %s")))
|
||
|
||
(should= "wait-idlec ok"
|
||
;; wait chain test
|
||
(dtest
|
||
(deferred:wait-idle 1)
|
||
(nextc it "wait")
|
||
(nextc it (deferred:wait-idle 1))
|
||
(nextc it (if (< x 300) "wait-idlec ok" x))
|
||
(errorf it "Error on simple wait-idle chain : %s")))
|
||
|
||
(should= nil
|
||
;; wait cancel test
|
||
(dtest
|
||
(deferred:wait-idle 1000)
|
||
(cancelc it)
|
||
(nextc it (deferred:not-called-func "wait-idle cancel")))))
|
||
|
||
(ert-deftest deferred-sync-connect ()
|
||
"> synchronized connection and wait a value"
|
||
(should= "sync connect1"
|
||
;; real time connection1
|
||
(dtest
|
||
(deferred:succeed "sync ")
|
||
(nextc it
|
||
(concat x "connect1"))))
|
||
|
||
(should= "sync connect11"
|
||
;; real time connection11
|
||
(dtest
|
||
(deferred:succeed "sync ")
|
||
(nextc it
|
||
(concat x "connect1"))
|
||
(nextc it
|
||
(concat x "1"))))
|
||
|
||
(should= "connect2"
|
||
;; real time connection1
|
||
(dtest
|
||
(deferred:succeed "sync ")
|
||
(nextc it
|
||
(next "connect"))
|
||
(nextc it
|
||
(concat x "2"))))
|
||
|
||
(should= "connect!! GO"
|
||
;; real time connection2
|
||
(dtest
|
||
(deferred:succeed "sync ")
|
||
(nextc it
|
||
($
|
||
(next "connect")
|
||
(nextc it (concat x "!!"))))
|
||
(nextc it
|
||
(concat x " GO")))))
|
||
|
||
(ert-deftest deferred-try ()
|
||
"> try-catch-finally"
|
||
|
||
(should= "try"
|
||
;; try block
|
||
(dtest
|
||
(deferred:try
|
||
(next "try"))))
|
||
|
||
(should= "try"
|
||
;; try catch block
|
||
(dtest
|
||
(deferred:try
|
||
(next "try")
|
||
:catch
|
||
(lambda (e) (concat "CATCH:" e)))))
|
||
|
||
(should= "try-finally"
|
||
;; try catch finally block
|
||
(let (val)
|
||
(dtest
|
||
(deferred:try
|
||
(next "try")
|
||
:finally
|
||
(lambda (x) (setq val "finally")))
|
||
(nextc it (concat x "-" val)))))
|
||
|
||
(should= "try-finally2"
|
||
;; try catch finally block
|
||
(let (val)
|
||
(dtest
|
||
(deferred:try
|
||
(next "try")
|
||
:catch
|
||
(lambda (e) (concat "CATCH:" e))
|
||
:finally
|
||
(lambda (x) (setq val "finally2")))
|
||
(nextc it (concat x "-" val)))))
|
||
|
||
(should= "try-catch:err"
|
||
;; try block
|
||
(dtest
|
||
(deferred:try
|
||
($ (next "start")
|
||
(nextc it (error "err"))
|
||
(nextc it (deferred:not-called-func x)))
|
||
:catch
|
||
(lambda (e) (concat "catch:" (cadr e))))
|
||
(nextc it (concat "try-" x))))
|
||
|
||
(should= "try-catch:err-finally"
|
||
;; try catch finally block
|
||
(let (val)
|
||
(dtest
|
||
(deferred:try
|
||
($ (next "start")
|
||
(nextc it (error "err"))
|
||
(nextc it (deferred:not-called-func x)))
|
||
:catch
|
||
(lambda (e) (concat "catch:" (cadr e)))
|
||
:finally
|
||
(lambda (x) (setq val "finally")))
|
||
(nextc it (concat "try-" x "-" val))))))
|
||
|
||
|
||
|
||
(ert-deftest deferred-loop ()
|
||
"> loop"
|
||
(should= 10
|
||
;; basic loop test
|
||
(let ((v 0))
|
||
(dtest
|
||
(dloop 5 (lambda (i) (setq v (+ v i))))
|
||
(errorf it "Error on simple loop calling : %s"))
|
||
v))
|
||
|
||
(should= "loop ok 4"
|
||
;; return value for a loop
|
||
(dtest
|
||
(dloop 5 (lambda (i) i))
|
||
(nextc it (format "loop ok %i" x))
|
||
(errorf it "Error on simple loop calling : %s")))
|
||
|
||
(should= "nested loop ok (4 nil 3 2 1 0)"
|
||
;; nested deferred task in a loop
|
||
(let (count)
|
||
(dtest
|
||
(dloop 5 (lambda (i)
|
||
(push i count)
|
||
(if (eql i 3) (next (push x count)))))
|
||
(nextc it (format "nested loop ok %s" count))
|
||
(errorf it "Error on simple loop calling : %s"))
|
||
)
|
||
)
|
||
|
||
(should= '(6 4 2)
|
||
;; do-loop test
|
||
(let (count)
|
||
(dtest
|
||
(dloop '(1 2 3)
|
||
(lambda (x) (push (* 2 x) count)))
|
||
(errorf it "Error on do-loop calling : %s"))))
|
||
|
||
(should= nil
|
||
;; zero times loop test
|
||
(dtest
|
||
(dloop 0 (lambda (i) (deferred:not-called-func "zero loop")))))
|
||
|
||
(should= nil
|
||
;; loop cancel test
|
||
(dtest
|
||
(dloop 3 (lambda (i) (deferred:not-called-func "loop cancel")))
|
||
(cancelc it)))
|
||
|
||
(should= "loop error!"
|
||
;; loop error recover test
|
||
(dtest
|
||
(deferred:loop 5
|
||
(lambda (i) (if (= 2 i) (error "loop error"))))
|
||
(nextc it (deferred:not-called-func))
|
||
(errorc it (format "%s!" (cadr e)))
|
||
(nextc it x)))
|
||
|
||
(should= "loop error catch ok"
|
||
;; try catch finally test
|
||
(let ((body (lambda ()
|
||
(deferred:loop 5
|
||
(lambda (i) (if (= 2 i) (error "loop error")))))))
|
||
(dtest
|
||
(next "try ") ; try
|
||
(nextc it (funcall body)) ; body
|
||
(errorc it (format "%s catch " (cadr e))) ; catch
|
||
(nextc it (concat x "ok"))))) ; finally
|
||
|
||
(should= "4 ok"
|
||
;; try catch finally test
|
||
(let ((body (lambda ()
|
||
(deferred:loop 5
|
||
(lambda (i) i)))))
|
||
(dtest
|
||
(next "try ") ; try
|
||
(nextc it (funcall body)) ; body
|
||
(errorc it (format "%s catch " e)) ; catch
|
||
(nextc it (format "%s ok" x))))) ; finally
|
||
)
|
||
|
||
|
||
|
||
(ert-deftest deferred-parallel ()
|
||
"> parallel"
|
||
(should= nil
|
||
;; nil test
|
||
(dtest
|
||
(parallel '())))
|
||
|
||
(should= '(1)
|
||
;; single job test: argument
|
||
(dtest
|
||
(parallel
|
||
(next 1))))
|
||
|
||
(should= '(1)
|
||
;; single job test: function
|
||
(dtest
|
||
(parallel
|
||
(lambda () 1))))
|
||
|
||
(should= '(1)
|
||
;; single job test: list
|
||
(dtest
|
||
(parallel
|
||
(list (next 1)))))
|
||
|
||
(should= '((a . 1))
|
||
;; single job test: alist
|
||
(dtest
|
||
(parallel
|
||
(list (cons 'a (next 1))))))
|
||
|
||
(should= '(0 1)
|
||
;; simple parallel test: just return value
|
||
(dtest
|
||
(parallel
|
||
(next 0) (next 1))))
|
||
|
||
(should= '(13 14)
|
||
;; simple parallel test: list
|
||
(dtest
|
||
(parallel
|
||
(list (next 13)
|
||
(next 14)))))
|
||
|
||
(should= '((a . 20) (b . 30))
|
||
;; simple parallel test: alist
|
||
(dtest
|
||
(parallel
|
||
(list (cons 'a (next 20))
|
||
(cons 'b (next 30))))))
|
||
|
||
(should= '(0 1)
|
||
;; simple parallel test: function list
|
||
(dtest
|
||
(parallel
|
||
(lambda () 0) (lambda () 1))))
|
||
|
||
(should= '(0 1)
|
||
;; nested deferred and order change test
|
||
(dtest
|
||
(parallel
|
||
(lambda () (next 0))
|
||
(next 1))))
|
||
|
||
(should= "((error ERROR) OK (error ERROR2))"
|
||
;; error handling
|
||
(dtest
|
||
(parallel
|
||
(next (error "ERROR")) (next "OK") (next (error "ERROR2")))
|
||
(nextc it (format "%s" x))))
|
||
|
||
(should= "((error ERROR) (error ERROR2))"
|
||
;; failed test
|
||
(dtest
|
||
(parallel
|
||
(next (error "ERROR")) (next (error "ERROR2")))
|
||
(nextc it (format "%s" x))))
|
||
|
||
(should= "((b . OK) (a error ERROR) (c error ERROR2))"
|
||
;; error handling
|
||
(dtest
|
||
(parallel
|
||
(cons 'a (next (error "ERROR")))
|
||
(cons 'b (next "OK"))
|
||
(cons 'c (next (error "ERROR2"))))
|
||
(nextc it (format "%s" x))))
|
||
|
||
(should= "((a error ERROR) (b error ERROR2))"
|
||
;; failed test
|
||
(dtest
|
||
(parallel
|
||
(cons 'a (next (error "ERROR")))
|
||
(cons 'b (next (error "ERROR2"))))
|
||
(nextc it (format "%s" x))))
|
||
|
||
(should= nil
|
||
;; parallel cancel test
|
||
(dtest
|
||
(parallel
|
||
(list (next (deferred:not-called-func "parallel 1"))
|
||
(next (deferred:not-called-func "parallel 2"))))
|
||
(cancelc it)))
|
||
|
||
(should= "nest parallel ok"
|
||
;; parallel next
|
||
(let* ((flow (lambda (x)
|
||
(parallel
|
||
(next "nest ")
|
||
(next "parallel ")))))
|
||
(dtest
|
||
(next "start ")
|
||
(nextc it (funcall flow x))
|
||
(nextc it (apply 'concat x))
|
||
(nextc it (concat x "ok")))))
|
||
|
||
(should= "arrived (1) ok"
|
||
;; arrived one deferred
|
||
(dtest
|
||
(parallel (deferred:succeed 1))
|
||
(nextc it (format "arrived %s ok" x))))
|
||
|
||
(should= "arrived (1 2) ok"
|
||
;; arrived deferreds
|
||
(dtest
|
||
(parallel (deferred:succeed 1) (deferred:succeed 2))
|
||
(nextc it (format "arrived %s ok" x)))))
|
||
|
||
|
||
|
||
(ert-deftest deferred-earlier ()
|
||
"> earlier"
|
||
(should= nil
|
||
;; nil test
|
||
(dtest
|
||
(earlier '())))
|
||
|
||
(should= 1
|
||
;; single job test: argument
|
||
(dtest
|
||
(earlier
|
||
(nextc (wait 10) 1))
|
||
(nextc it x)))
|
||
|
||
(should= 1
|
||
;; single job test: function
|
||
(dtest
|
||
(earlier
|
||
(lambda () 1))
|
||
(nextc it x)))
|
||
|
||
(should= 1
|
||
;; single job test: list
|
||
(dtest
|
||
(earlier
|
||
(list (next 1)))
|
||
(nextc it x)))
|
||
|
||
(should= '(a . 1)
|
||
;; single job test: alist
|
||
(dtest
|
||
(earlier
|
||
(list (cons 'a (next 1))))
|
||
(nextc it x)))
|
||
|
||
(should= '0
|
||
;; simple earlier test
|
||
(dtest
|
||
(earlier
|
||
(next 0) (next 1))
|
||
(nextc it x)))
|
||
|
||
(should= '11
|
||
;; simple earlier test: argument
|
||
(dtest
|
||
(earlier
|
||
(next 11) (next 12))
|
||
(nextc it x)))
|
||
|
||
(should= '13
|
||
;; simple earlier test: list
|
||
(dtest
|
||
(earlier
|
||
(list (next 13) (next 14)))
|
||
(nextc it x)))
|
||
|
||
(should= '(a . 20)
|
||
;; simple earlier test: alist
|
||
(dtest
|
||
(earlier
|
||
(list (cons 'a (next 20))
|
||
(cons 'b (next 30))))
|
||
(nextc it x)))
|
||
|
||
(should= '0
|
||
;; simple earlier test: function list
|
||
(dtest
|
||
(earlier
|
||
(lambda () 0) (lambda () 1))
|
||
(nextc it x)))
|
||
|
||
(should= '1
|
||
;; nested deferred and order change test
|
||
(dtest
|
||
(earlier
|
||
(lambda () (dnew 0))
|
||
(next 1))))
|
||
|
||
(should= "OK"
|
||
;; error handling
|
||
(dtest
|
||
(earlier
|
||
(next (error "ERROR")) (next "OK") (next (error "ERROR2")))
|
||
(nextc it x)))
|
||
|
||
(should= nil
|
||
;; failed test
|
||
(dtest
|
||
(earlier
|
||
(next (error "ERROR")) (next (error "ERROR2")))
|
||
(nextc it x)))
|
||
|
||
(should= '(b . "OK")
|
||
;; error handling
|
||
(dtest
|
||
(earlier
|
||
(cons 'a (next (error "ERROR")))
|
||
(cons 'b (next "OK"))
|
||
(cons 'c (next (error "ERROR2"))))
|
||
(nextc it x)))
|
||
|
||
(should= nil
|
||
;; failed test
|
||
(dtest
|
||
(earlier
|
||
(cons 'a (next (error "ERROR")))
|
||
(cons 'b (next (error "ERROR2"))))
|
||
(nextc it x)))
|
||
|
||
(should= nil
|
||
;; cancel test
|
||
(dtest
|
||
(earlier
|
||
(list (next (deferred:not-called-func "earlier 1"))
|
||
(next (deferred:not-called-func "earlier 2"))))
|
||
(cancelc it)))
|
||
|
||
(should= "arrived 1 ok"
|
||
;; arrived one deferred
|
||
(dtest
|
||
(earlier (deferred:succeed 1))
|
||
(nextc it (format "arrived %s ok" x))))
|
||
|
||
(should= "arrived 1 ok"
|
||
;; arrived deferreds
|
||
(dtest
|
||
(earlier (deferred:succeed 1) (deferred:succeed 2))
|
||
(nextc it (format "arrived %s ok" x)))))
|
||
|
||
(ert-deftest deferred-sync! ()
|
||
(should= "foo"
|
||
(deferred:$
|
||
(deferred:next
|
||
(lambda ()
|
||
"foo"))
|
||
(deferred:sync! it))))
|
||
|
||
;; process
|
||
|
||
(defmacro should-match (proc-name err-msg a &rest b)
|
||
`(let ((expected ,a)
|
||
(actual (progn ,@b)))
|
||
(should= (nth 0 expected) (nth 0 actual))
|
||
(should= (nth 1 expected) (nth 1 actual))
|
||
;; The stderr buffer gets a notification that it's closing. The regexp
|
||
;; below should match exactly the allowed proc-name only.
|
||
(should= (string-match
|
||
(format "%s\nProcess \\*deferred:\\*%s\\*:[0-9]+ stderr finished\n$" ,err-msg ,proc-name)
|
||
(nth 2 actual))
|
||
0)))
|
||
|
||
(ert-deftest deferred-process ()
|
||
"> Process"
|
||
(should=
|
||
(with-temp-buffer
|
||
(call-process "pwd" nil t nil)
|
||
(buffer-string))
|
||
(wtest 0.1 ;; maybe fail in some environments...
|
||
(deferred:process "pwd")))
|
||
|
||
(should=
|
||
(with-temp-buffer
|
||
(call-process "pwd" nil t nil)
|
||
(buffer-string))
|
||
(wtest 0.1 ;; maybe fail in some environments...
|
||
(deferred:process "pwd" nil)))
|
||
|
||
(should=
|
||
(length (buffer-list))
|
||
(deferred:cancel (deferred:process "pwd" nil))
|
||
(length (buffer-list)))
|
||
|
||
(should= 0
|
||
(dtest
|
||
(deferred:process "pwd---")
|
||
(nextc it (deferred:not-called-func))
|
||
(errorc it (string-match "^Searching for program" (cadr e)))))
|
||
|
||
(should=
|
||
(with-temp-buffer (call-process "pwd" nil t nil)
|
||
(buffer-string))
|
||
(wtest 0.1
|
||
(wait 0.1)
|
||
(deferred:processc it "pwd" nil)))
|
||
|
||
(should=
|
||
(with-temp-buffer
|
||
(call-process "ls" nil t "-1")
|
||
(buffer-string))
|
||
(wtest 0.1 ;; maybe fail in some environments...
|
||
(deferred:process-buffer "ls" "-1")
|
||
(nextc it
|
||
(unless (buffer-live-p x)
|
||
(error "Not live buffer : %s" x))
|
||
(with-current-buffer x (buffer-string)))))
|
||
|
||
(should=
|
||
(with-temp-buffer
|
||
(call-process "ls" nil t "-1")
|
||
(buffer-string))
|
||
(wtest 0.1 ;; maybe fail in some environments...
|
||
(wait 0.1)
|
||
(deferred:process-bufferc it "ls" "-1")
|
||
(nextc it
|
||
(unless (buffer-live-p x)
|
||
(error "Not live buffer : %s" x))
|
||
(with-current-buffer x (buffer-string)))))
|
||
|
||
(should=
|
||
(length (buffer-list))
|
||
(deferred:cancel (deferred:process-buffer "ls" nil))
|
||
(length (buffer-list)))
|
||
|
||
(should= 0
|
||
(dtest
|
||
(deferred:process-buffer "pwd---")
|
||
(nextc it (deferred:not-called-func))
|
||
(errorc it (string-match "^Searching for program" (cadr e)))))
|
||
|
||
;;shell
|
||
|
||
(should=
|
||
(with-temp-buffer
|
||
(call-process-shell-command "pwd" nil t nil)
|
||
(buffer-string))
|
||
(wtest 0.1 ;; maybe fail in some environments...
|
||
(deferred:process-shell "pwd")))
|
||
|
||
(should=
|
||
(with-temp-buffer
|
||
(call-process-shell-command "pwd" nil t nil)
|
||
(buffer-string))
|
||
(wtest 0.1 ;; maybe fail in some environments...
|
||
(deferred:process-shell "pwd" nil)))
|
||
|
||
(should=
|
||
(length (buffer-list))
|
||
(deferred:cancel (deferred:process-shell "pwd" nil))
|
||
(length (buffer-list)))
|
||
|
||
(should= "ERROR"
|
||
(wtest 0.1
|
||
(deferred:process-shell "lsasfdsadf")
|
||
(nextc it (deferred:not-called-func))
|
||
(errorc it "ERROR")))
|
||
|
||
(should=
|
||
(with-temp-buffer (call-process-shell-command "pwd" nil t nil)
|
||
(buffer-string))
|
||
(wtest 0.1
|
||
(wait 0.1)
|
||
(deferred:process-shellc it "pwd" nil)))
|
||
|
||
(should=
|
||
(with-temp-buffer
|
||
(call-process-shell-command "ls" nil t "-1")
|
||
(buffer-string))
|
||
(wtest 0.1 ;; maybe fail in some environments...
|
||
(deferred:process-shell-buffer "ls" "-1")
|
||
(nextc it
|
||
(unless (buffer-live-p x)
|
||
(error "Not live buffer : %s" x))
|
||
(with-current-buffer x (buffer-string)))))
|
||
|
||
(should=
|
||
(with-temp-buffer
|
||
(call-process-shell-command "ls" nil t "-1")
|
||
(buffer-string))
|
||
(wtest 0.1 ;; maybe fail in some environments...
|
||
(wait 0.1)
|
||
(deferred:process-shell-bufferc it "ls" "-1")
|
||
(nextc it
|
||
(unless (buffer-live-p x)
|
||
(error "Not live buffer : %s" x))
|
||
(with-current-buffer x (buffer-string)))))
|
||
|
||
(should=
|
||
(length (buffer-list))
|
||
(deferred:cancel (deferred:process-shell-buffer "ls" nil))
|
||
(length (buffer-list)))
|
||
|
||
(should= "ERROR"
|
||
(wtest 0.1
|
||
(deferred:process-shell-buffer "lssaf")
|
||
(nextc it (deferred:not-called-func))
|
||
(errorc it "ERROR")))
|
||
|
||
;; w-stderr
|
||
|
||
(should-match "pwd" ""
|
||
(with-temp-buffer
|
||
(call-process "pwd" nil t nil)
|
||
(list 0 (buffer-string) ""))
|
||
(wtest 0.1 ;; maybe fail in some environments...
|
||
(deferred:process-w-stderr "pwd")))
|
||
|
||
(should-match "pwd" ""
|
||
(with-temp-buffer
|
||
(call-process "pwd" nil t nil)
|
||
(list 0 (buffer-string) ""))
|
||
(wtest 0.1 ;; maybe fail in some environments...
|
||
(deferred:process-w-stderr "pwd" nil)))
|
||
|
||
(should=
|
||
(length (buffer-list))
|
||
(deferred:cancel (deferred:process-w-stderr "pwd" nil))
|
||
(length (buffer-list)))
|
||
|
||
(should= 0
|
||
(dtest
|
||
(deferred:process-w-stderr "pwd---")
|
||
(nextc it (deferred:not-called-func))
|
||
(errorc it (string-match "^Searching for program" (cadr e)))))
|
||
|
||
(should-match "pwd" "/usr/bin/pwd: unrecognized option '--nonsensical-argument'\nTry '/usr/bin/pwd --help' for more information.\n"
|
||
(list 1 "" "")
|
||
(wtest 0.1 ;; maybe fail in some environments...
|
||
(deferred:process-w-stderr "pwd" "--nonsensical-argument")))
|
||
|
||
(should-match "pwd" ""
|
||
(with-temp-buffer
|
||
(call-process "pwd" nil t nil)
|
||
(list 0 (buffer-string) ""))
|
||
(wtest 0.1 ;; maybe fail in some environments...
|
||
(wait 0.1)
|
||
(deferred:process-w-stderrc it "pwd" nil)))
|
||
|
||
(should-match "ls" ""
|
||
(with-temp-buffer
|
||
(call-process "ls" nil t "-1")
|
||
(list 0 (buffer-string) ""))
|
||
(wtest 0.1 ;; maybe fail in some environments...
|
||
(deferred:process-w-stderr-buffer "ls" "-1")
|
||
(nextc it
|
||
(let ((stdout (nth 1 x))
|
||
(stderr (nth 2 x)))
|
||
(unless (buffer-live-p stdout)
|
||
(error "Not live buffer : %s" stdout))
|
||
(unless (buffer-live-p stderr)
|
||
(error "Not live buffer : %s" stderr))
|
||
(list (nth 0 x)
|
||
(with-current-buffer stdout (buffer-string))
|
||
(with-current-buffer stderr (buffer-string)))))))
|
||
|
||
(should-match "pwd" "/usr/bin/pwd: unrecognized option '--nonsensical-argument'\nTry '/usr/bin/pwd --help' for more information.\n"
|
||
(list 1 "" "")
|
||
(wtest 0.1 ;; maybe fail in some environments...
|
||
(deferred:process-w-stderr-buffer "pwd" "--nonsensical-argument")
|
||
(nextc it
|
||
(let ((stdout (nth 1 x))
|
||
(stderr (nth 2 x)))
|
||
(unless (buffer-live-p stdout)
|
||
(error "Not live buffer : %s" stdout))
|
||
(unless (buffer-live-p stderr)
|
||
(error "Not live buffer : %s" stderr))
|
||
(list (nth 0 x)
|
||
(with-current-buffer stdout (buffer-string))
|
||
(with-current-buffer stderr (buffer-string)))))))
|
||
|
||
(should-match "ls" ""
|
||
(with-temp-buffer
|
||
(call-process "ls" nil t "-1")
|
||
(list 0 (buffer-string) ""))
|
||
(wtest 0.1 ;; maybe fail in some environments...
|
||
(wait 0.1)
|
||
(deferred:process-w-stderr-bufferc it "ls" "-1")
|
||
(nextc it
|
||
(let ((stdout (nth 1 x))
|
||
(stderr (nth 2 x)))
|
||
(unless (buffer-live-p stdout)
|
||
(error "Not live buffer : %s" stdout))
|
||
(unless (buffer-live-p stderr)
|
||
(error "Not live buffer : %s" stderr))
|
||
(list (nth 0 x)
|
||
(with-current-buffer stdout (buffer-string))
|
||
(with-current-buffer stderr (buffer-string)))))))
|
||
|
||
(should=
|
||
(length (buffer-list))
|
||
(deferred:cancel (deferred:process-w-stderr-buffer "ls" nil))
|
||
(length (buffer-list)))
|
||
|
||
(should= 0
|
||
(dtest
|
||
(deferred:process-w-stderr-buffer "pwd---")
|
||
(nextc it (deferred:not-called-func))
|
||
(errorc it (string-match "^Searching for program" (cadr e))))))
|