Codebase list emacs-deferred / 95ed984
New upstream version 0.4.0 Lev Lamberov 7 years ago
15 changed file(s) with 5810 addition(s) and 0 deletion(s). Raw diff Collapse all Expand all
+1
-0
.ert-runner less more
0 -L .
+11
-0
.gitignore less more
0 # Compiled and temporary files
1 *.elc
2 *~
3
4 # Cask
5 /.cask
6 dist
7
8 # Ecukes
9 /features/project/.cask
10 /features/project/test/*.el
+17
-0
.travis.yml less more
0 language: generic
1 sudo: false
2 before_install:
3 - curl -fsSkL https://gist.github.com/rejeep/ebcd57c3af83b049833b/raw > x.sh && source ./x.sh
4 - evm install $EVM_EMACS --use --skip
5 - cask
6 env:
7 - EVM_EMACS=emacs-24.3-travis
8 - EVM_EMACS=emacs-24.4-travis
9 - EVM_EMACS=emacs-24.5-travis
10
11 script:
12 - emacs --version
13 - make travis-ci
14 after_script:
15 - cat /tmp/undercover-report.json
16 - curl -v -include --form json_file=@/tmp/undercover-report.json https://coveralls.io/api/v1/jobs⏎
+12
-0
Cask less more
0 (source gnu)
1 (source melpa)
2
3 (package-file "deferred.el")
4
5 (development
6 (depends-on "f")
7 (depends-on "ecukes")
8 (depends-on "ert-runner")
9 (depends-on "el-mock")
10 (depends-on "cask-package-toolset")
11 (depends-on "undercover"))
+42
-0
Makefile less more
0 EMACS ?= emacs
1 CASK ?= cask
2
3 CURL=curl --silent -L
4 ERT_URL=http://git.savannah.gnu.org/cgit/emacs.git/plain/lisp/emacs-lisp/ert.el?h=emacs-24
5 ERT=ert
6 CL_URL=https://raw.githubusercontent.com/emacsmirror/cl-lib/master/cl-lib.el
7 CL=cl-lib
8
9 .PHONY: test test-deferred test-concurrent compile clean print-deps travis-ci
10
11 test: test-deferred test-deferred-compiled test-concurrent
12 # test-concurrent-compiled
13
14 test-deferred:
15 $(CASK) exec ert-runner test/deferred-test.el
16
17 test-deferred-compiled: deferred.elc
18 $(CASK) exec ert-runner test/deferred-test.el -l deferred.elc
19
20 test-concurrent:
21 $(CASK) exec ert-runner test/concurrent-test.el
22
23 test-concurrent-compiled: concurrent.elc
24 $(CASK) exec ert-runner test/concurrent-test.el -l concurrent.elc
25
26 compile: deferred.elc concurrent.elc
27
28 %.elc: %.el
29 $(EMACS) -batch -L . -f batch-byte-compile $<
30
31 clean:
32 rm -rfv *.elc
33
34 print-deps:
35 @echo "----------------------- Dependencies -----------------------"
36 $(EMACS) --version
37 @echo "------------------------------------------------------------"
38
39 travis-ci: print-deps
40 $(MAKE) clean test
41 $(MAKE) compile test
+416
-0
README-concurrent.ja.markdown less more
0 # concurrent.el #
1
2 [![Build Status](https://travis-ci.org/kiwanami/emacs-deferred.svg)](https://travis-ci.org/kiwanami/emacs-deferred)
3 [![Coverage Status](https://coveralls.io/repos/kiwanami/emacs-deferred/badge.svg)](https://coveralls.io/r/kiwanami/emacs-deferred)
4 [![MELPA](http://melpa.org/packages/concurrent-badge.svg)](http://melpa.org/#/concurrent)
5 [![MELPA stable](http://stable.melpa.org/packages/concurrent-badge.svg)](http://stable.melpa.org/#/concurrent)
6 [![Tag Version](https://img.shields.io/github/tag/kiwanami/emacs-deferred.svg)](https://github.com/kiwanami/emacs-deferred/tags)
7 [![License](http://img.shields.io/:license-gpl3-blue.svg)](http://www.gnu.org/licenses/gpl-3.0.html)
8
9 concurrent.elは、良くある非同期処理を抽象化したライブラリです。スレッド、セマフォ、イベント管理などがあります。他の環境のライブラリや並行プログラミングのアイデアを参考にしました。
10
11 ## インストール ##
12
13 concurrent.elは package.elを使って, [MELPA](http://melpa.org)からインストールすることができます.
14
15 ## 使い方例 ##
16
17 以下のサンプルで例示したソースは concurrent-samples.el の中にあります。
18 eval-last-sexp (C-x C-e) などで実行してみてください。
19
20 ### Threadの例
21
22 lexical-letを評価するとその場でアニメーションします。引数の時間は、bodyの処理の間隔です。
23
24 Thread:
25
26 ```el
27 (lexical-let
28 ((count 0) (anm "-/|\\-")
29 (end 50) (pos (point)))
30 (cc:thread
31 60
32 (message "Animation started.")
33 (while (> end (incf count))
34 (save-excursion
35 (when (< 1 count)
36 (goto-char pos) (delete-char 1))
37 (insert (char-to-string
38 (aref anm (% count (length anm)))))))
39 (save-excursion
40 (goto-char pos) (delete-char 1))
41 (message "Animation finished.")))
42 ```
43
44 whileを使うことでスレッドをループさせることが出来ます。whileの中身は一気に実行されます。
45
46 無限ループや重い処理でEmacsが固まらないように注意してください。もし無限ループに突入してしまったり、固まってしまったら deferred:clear-queue コマンドで回復できる可能性があります。
47
48
49 ### Generatorの例
50
51 fib-genにジェネレーターを作ります。ジェネレーター生成body内のyield関数で値を返します。値はコールバックで値を受け取ります。
52
53 Generator:
54
55 ```el
56 (setq fib-list nil)
57 (setq fib-gen
58 (lexical-let ((a1 0) (a2 1))
59 (cc:generator
60 (lambda (x) (push x fib-list)) ; コールバックで結果受け取り
61 (yield a1)
62 (yield a2)
63 (while t
64 (let ((next (+ a1 a2)))
65 (setq a1 a2
66 a2 next)
67 (yield next))))))
68
69 (funcall fib-gen) ; 何度か呼んでみる
70 (funcall fib-gen) (funcall fib-gen)
71 (funcall fib-gen) (funcall fib-gen)
72
73 fib-list ; => (3 2 1 1 0)
74 ```
75
76 ### Semaphoreの例
77
78 cc:semaphore-acquire 関数が deferred を返すので、それに続けて実行させたいタスクをつなげていきます。時系列で挙動が変わっていくのでコード中に簡単な説明を書いてみました。
79
80 Semaphore:
81
82 ```el
83 ;; permit=1のセマフォ作成
84 (setq smp (cc:semaphore-create 1))
85
86 ;; 続けて3つ実行しようとする
87 (deferred:nextc (cc:semaphore-acquire smp)
88 (lambda(x)
89 (message "go1")))
90 (deferred:nextc (cc:semaphore-acquire smp)
91 (lambda(x)
92 (message "go2")))
93 (deferred:nextc (cc:semaphore-acquire smp)
94 (lambda(x)
95 (message "go3")))
96
97 ;; => 1つ目だけ実行されて go1 が表示される
98
99 (cc:semaphore-release smp) ; permitを返す
100
101 ;; => 2つ目が実行されて go2 が表示される
102
103 (cc:semaphore-waiting-deferreds smp) ; go3 を表示するdeferred
104
105 (cc:semaphore-release-all smp) ; => permitを初期化して go3 を表示するdeferredを返す
106
107 (cc:semaphore-waiting-deferreds smp) ; => nil
108 ```
109
110 ### Dataflowの例：
111
112 cc:dataflow-environment 関数で変数を格納する「環境」を作ります。 cc:dataflow-get は値の取得とそれに続くタスクをつなげる deferred を返します。 cc:dataflow-set で値をバインドします。例ではキーに文字列を使っていますが、キーには任意のオブジェクトを指定できます。
113
114 Dataflow:
115
116 ```el
117 (setq dfenv (cc:dataflow-environment))
118
119 ;; ○基本の使い方
120
121 ;; ↓同期的に値を取得。ブロックしない。
122 (cc:dataflow-get-sync dfenv "abc") ; => nil まだ値が無い。
123
124 (deferred:$ ; abc という値を取ってきて表示する処理
125 (cc:dataflow-get dfenv "abc")
126 (deferred:nextc it
127 (lambda (x) (message "Got abc : %s" x))))
128 ;; => 値がないので処理はブロックしたまま
129
130 (cc:dataflow-set dfenv "abc" 256) ; 値をセット
131 ;; => ここで先ほどブロックしていた処理が再開し、 "Got abc : 256" が表示される
132
133 (cc:dataflow-get-sync dfenv "abc") ; => 256
134
135 (cc:dataflow-clear dfenv "abc") ; 値を未バインドに戻す
136
137 (cc:dataflow-get-sync dfenv "abc") ; => nil
138
139 ;; ○リストをキーにする
140
141 (deferred:$
142 (cc:dataflow-get dfenv '("http://example.com/a.jpg" 300))
143 (deferred:nextc it
144 (lambda (x) (message "a.jpg:300 OK %s" x))))
145
146 (cc:dataflow-set dfenv '("http://example.com/a.jpg" 300) 'jpeg)
147
148 ;; => a.jpg:300 OK jpeg
149
150 ;; ○2つの値を待ち受ける
151
152 (deferred:$ ; abc, def の2つの値を使う
153 (deferred:parallel
154 (cc:dataflow-get dfenv "abc")
155 (cc:dataflow-get dfenv "def"))
156 (deferred:nextc it
157 (lambda (values)
158 (apply 'message "Got values : %s, %s" values)
159 (apply '+ values)))
160 (deferred:nextc it
161 (lambda (x) (insert (format ">> %s" x)))))
162 ;; => もちろんブロックする
163
164 (cc:dataflow-get-waiting-keys dfenv) ; => ("def" "abc")
165 (cc:dataflow-get-avalable-pairs dfenv) ; => ((("http://example.com/a.jpg" 300) . jpeg))
166
167 (cc:dataflow-set dfenv "abc" 128) ; ここではまだブロックしたまま
168 (cc:dataflow-set dfenv "def" 256) ; ここでやっと動く
169 ;; => Got values : 128, 256
170 ```
171
172 ### Signalの例：
173
174 cc:signal-channel でシグナルを流すチャンネルを作成します。その後、signalに応答する処理を接続していきます。
175
176 ```el
177 ;; シグナルのチャンネルを作成
178 (setq channel (cc:signal-channel))
179
180 (cc:signal-connect ; foo というシグナルを拾う
181 channel 'foo
182 (lambda (event) (message "Signal : %S" event)))
183
184 (cc:signal-connect
185 channel t ; t にするとすべてのシグナルを拾う
186 (lambda (event)
187 (destructuring-bind (event-name (args)) event
188 (message "Listener : %S / %S" event-name args))))
189
190 (deferred:$ ; deferred で非同期タスクを接続できる
191 (cc:signal-connect channel 'foo)
192 (deferred:nextc it
193 (lambda (x) (message "Deferred Signal : %S" x))))
194
195 (cc:signal-send channel 'foo "hello signal!")
196 ;; =>
197 ;; Listener : foo / "hello signal!"
198 ;; Signal : (foo ("hello signal!"))
199 ;; Deferred Signal : (foo ("hello signal!"))
200
201 (cc:signal-send channel 'some "some signal!")
202 ;; =>
203 ;; Listener : some / "some signal!"
204 ```
205
206 dataflowの内部には、変数へのアクセスやバインドのシグナルを発信するchannelがあります。これを使って、未バインドの変数に値を作成してセットするようなことが出来ます。
207
208 signalやdataflowは、カスケード接続して親子関係を構築できます。例えば、親dataflowにデフォルト値（フォールバックの値）を入れておくとか、channelで親子関係を構築してローカルなイベントとグローバルなイベントを分けて効率的にイベントを管理するなどが出来ます。
209
210 ## インタフェース解説 ##
211
212 ### Thread
213
214 * cc:thread (wait-time-msec &rest body)
215 * 引数：
216 * wait-time-msec: タスク間の間隔（ミリ秒）
217 * 返値：Threadオブジェクト（今のところ使い道無し）
218 * スレッドを作成して開始します
219 * bodyのS式が一つずつ非同期で実行されます。その間隔が wait-time-msec で指定された時間です。
220 * bodyの中に while があった場合は、特別にループとして処理します。
221 * 無限ループや重い処理でEmacsが固まらないように注意してください。もし無限ループに突入してしまったり、固まってしまったら deferred:clear-queue コマンドで回復できる可能性があります。
222
223 ### Generator
224
225 * cc:generator (callback &rest body)
226 * 引数：
227 * callback: yieldした値を受け取る関数
228 * body: Generatorの中身
229 * 返値：Generatorを実行する関数
230 * Threadと同様に、bodyのS式が一つずつ非同期で実行されます。
231 * bodyの中に while があった場合は、特別にループとして処理します。
232 * bodyの内で yield 関数を使う（実際にはマクロで置換されます）と、callbackで指定した関数に値が渡って処理が停止します。
233 * 再度 Generator 関数を実行すると停止した位置から開始します。
234
235 ### Semaphore
236
237 * cc:semaphore-create (permits-num)
238 * 引数：
239 * permits-num: 許可数
240 * 返値：Semaphoreオブジェクト
241 * セマフォオブジェクトを作成します。
242
243 * cc:semaphore-acquire (semaphore)
244 * 引数：
245 * semaphore: Semaphoreオブジェクト
246 * 返値：Deferredオブジェクト
247 * 返したDeferredオブジェクトに、実行数を制限したいタスクをつなげます。
248 * 実行する際、許可数を1つ消費します。許可数が0になったら、以降のタスクは待たされます。
249 * 実行可能なら、返したDeferredタスクがすぐに実行されます。
250 * 実行可能でなければ、許可数が戻るまで返したDeferredタスクは待たされます。
251
252 * cc:semaphore-release (semaphore)
253 * 引数：
254 * semaphore: Semaphoreオブジェクト
255 * 返値：Semaphoreオブジェクト
256 * 許可数を一つ戻します。その際、待っているタスクがあれば実行されます。
257 * 許可数は自動では戻りませんので、 cc:semaphore-release を呼ぶのはプログラマの責任です。
258
259 * cc:semaphore-with (semaphore body-func &optional error-func)
260 * 引数：
261 * semaphore: Semaphoreオブジェクト
262 * body-func: 実行数を制御したいタスクの関数
263 * error-func: 発生したエラーを処理する関数（deferred:errorで接続される）
264 * 返値：Deferredオブジェクト
265 * acquireとreleaseを前後で行う関数です。特に理由がない限りは、acquireとreleaseを自分で書くよりも、こちらを使う方が安全で楽です。
266
267
268 * cc:semaphore-release-all (semaphore)
269 * 引数：
270 * semaphore: Semaphoreオブジェクト
271 * 返値：実行待ちだったDeferredオブジェクト
272 * 許可数を強制的に初期値に戻します。デバッグ時や状態をリセットしたいときに使います。
273
274 * cc:semaphore-interrupt-all (semaphore)
275 * 引数：
276 * semaphore: Semaphoreオブジェクト
277 * 返値：Deferredオブジェクト
278 * 実行待ちのタスクがなければ、すぐに実行するDeferredオブジェクトを返します。
279 * 現在実行待ちのタスクがあれば取り除いて、現在実行中のタスクの次に実行されるDeferredオブジェクトを返します。
280 * 割り込みしたいときに使います。
281
282 ### Signal
283
284 * cc:signal-channel (&optional name parent-channel)
285 * 引数：
286 * name: このチャンネルの名前。主にデバッグ用。
287 * parent-channel: 上流のチャンネルオブジェクト。
288 * 返値：チャンネルオブジェクト
289 * 新しいチャンネルを作成します。
290 * 上流のシグナルは下流に流れてきますが、下流から上流には cc:signal-send-global を使わない限り流れません。
291
292 * cc:signal-connect (channel event-sym &optional callback)
293 * 引数：
294 * channel: チャンネルオブジェクト
295 * event-sym: イベント識別シンボル
296 * callback: 受け取り関数
297 * 返値：Deferredオブジェクト
298 * シグナルを受信するタスクを追加します。
299 * event-sym が t の場合は、すべてのシグナルを受信します。
300 * 通常はこの関数の返値にシグナルを受信する非同期タスクを接続します。
301
302 * cc:signal-send (channel event-sym &rest args)
303 * 引数：
304 * channel: チャンネルオブジェクト
305 * event-sym: イベント識別シンボル
306 * args: イベント引数
307 * 返値：なし
308 * シグナルを発信します。
309 * args は、受信側で (lambda (event) (destructuring-bind (event-sym (args)) event ... )) のようにすると受け取れます。
310
311
312 * cc:signal-send-global (channel event-sym &rest args)
313 * 引数：
314 * channel: チャンネルオブジェクト
315 * event-sym: イベント識別シンボル
316 * args: イベント引数
317 * 返値：なし
318 * 上流のチャンネルにシグナルを送信します。
319
320 * cc:signal-disconnect (channel deferred)
321 * 引数：
322 * channel: チャンネルオブジェクト
323 * deferred: チャンネルから取り除きたいDeferredオブジェクト
324 * 返値：削除されたDeferredオブジェクト
325 * チャンネルから受信タスクを取り除きます。
326
327 * cc:signal-disconnect-all (channel)
328 * 引数：
329 * channel: チャンネルオブジェクト
330 * 返値：なし
331 * すべての受信タスクを取り除きます。
332
333 ### Dataflow
334
335 * cc:dataflow-environment (&optional parent-env test-func channel)
336 * 引数：
337 * parent-env: デフォルト値として使うDataflowオブジェクト
338 * test-func: keyの比較関数
339 * channel: チャンネルオブジェクト
340 * 返値：Dataflowオブジェクト
341 * 新しくDataflowオブジェクトを作成して返します。
342 * channelは引数で与えなかった場合は、内部新しいチャンネルオブジェクトを作成します。
343 * 以下のシグナルがチャンネルに送信されます
344 * get-first : 初回未バインド変数を参照したとき
345 * get-waiting : 2回目以降の未バインド変数を参照したとき
346 * set : 値をバインドしたとき
347 * get : バインドされた値を参照したとき
348 * clear : バインド解除されたとき
349 * clear-all : すべてのバインドが解除されたとき
350
351 * cc:dataflow-get (df key)
352 * 引数：
353 * df: Dataflowオブジェクト
354 * key: 変数キー
355 * 返値：変数の値を受け取るDeferredオブジェクト
356 * 変数の値を受け取るDeferredタスクを返すので、変数の値を使う処理を接続します。
357 * 変数の値がバインドされていれば、直ちに実行されます。
358 * 変数の値がバインドされていなければ、返されたDeferredタスクはバインドされるまで実行されません。
359
360 * cc:dataflow-get-sync (df key)
361 * 引数：
362 * df: Dataflowオブジェクト
363 * key: 変数キー
364 * 返値：nil か値
365 * 変数の値を同期的に参照します。
366 * 値がバインドされていなければ nil を返します。
367
368 * cc:dataflow-set (df key value)
369 * 引数：
370 * df: Dataflowオブジェクト
371 * key: 変数キー
372 * value: 値
373 * 返値：なし
374 * 変数に値をバインドします。
375 * もし、すでにバインドされている変数にバインドしようとした場合はエラーが発生します。
376
377 * cc:dataflow-clear (df key)
378 * 引数：
379 * df: Dataflowオブジェクト
380 * key: 変数キー
381 * 返値：なし
382 * 変数を未バインドに戻します。
383
384 * cc:dataflow-get-avalable-pairs (df)
385 * 引数：
386 * df: Dataflowオブジェクト
387 * 返値：バインドされている変数キーと値の alist
388
389 * cc:dataflow-get-waiting-keys (df)
390 * 引数：
391 * df: Dataflowオブジェクト
392 * 返値：未バインドで、受け取り待ちのタスクが存在する変数キーのリスト
393
394 * cc:dataflow-clear-all (df)
395 * 引数：
396 * df: Dataflowオブジェクト
397 * 返値：なし
398 * 指定されたDataflowオブジェクトを空にします。
399 * 受け取り待ちのタスクについては何もしません。
400
401 * cc:dataflow-connect (df event-sym &optional callback)
402 * 引数：
403 * df: Dataflowオブジェクト
404 * event-sym: イベント識別シンボル
405 * callback: 受け取り関数
406 * 返値：Deferredオブジェクト
407 * このDataflowオブジェクトのチャンネルにシグナル受け取りタスクを追加します。
408 * 内部で cc:signal-connect を呼びます。
409 * 受け取れるイベント識別シンボルについては、 cc:dataflow-environment を参照してください。
410
411
412 * * * * *
413
414 (C) 2011-2016 SAKURAI Masashi All rights reserved.
415 m.sakurai at kiwanami.net
+463
-0
README-concurrent.markdown less more
0 # concurrent.el
1
2 [![Build Status](https://travis-ci.org/kiwanami/emacs-deferred.svg)](https://travis-ci.org/kiwanami/emacs-deferred)
3 [![Coverage Status](https://coveralls.io/repos/kiwanami/emacs-deferred/badge.svg)](https://coveralls.io/r/kiwanami/emacs-deferred)
4 [![MELPA](http://melpa.org/packages/concurrent-badge.svg)](http://melpa.org/#/concurrent)
5 [![MELPA stable](http://stable.melpa.org/packages/concurrent-badge.svg)](http://stable.melpa.org/#/concurrent)
6 [![Tag Version](https://img.shields.io/github/tag/kiwanami/emacs-deferred.svg)](https://github.com/kiwanami/emacs-deferred/tags)
7 [![License](http://img.shields.io/:license-gpl3-blue.svg)](http://www.gnu.org/licenses/gpl-3.0.html)
8
9 `concurrent.el` is a higher level library for asynchronous tasks, based on `deferred.el`.
10
11 It is inspired by libraries of other environments and concurrent programing models.
12 It has following facilities: *pseud-thread*, *generator*, *semaphore*, *dataflow variables* and
13 *event management*.
14
15 ## Installation ##
16
17 You can install `concurrent.el` from [MELPA](http://melpa.org) by `package.el`.
18
19 ## Sample codes ##
20
21 You can find following sample codes in `concurrent-sample.el`.
22 Executing `eval-last-sexp` (C-x C-e), you can try those codes.
23
24 ### Pseud-thread
25
26 Evaluating the lexical-let in the blow code, the animation starts. After few seconds, the animation will stop.
27
28 Thread:
29
30 ```el
31 (lexical-let
32 ((count 0) (anm "-/|\\-")
33 (end 50) (pos (point)))
34 (cc:thread
35 60
36 (message "Animation started.")
37 (while (> end (incf count))
38 (save-excursion
39 (when (< 1 count)
40 (goto-char pos) (delete-char 1))
41 (insert (char-to-string
42 (aref anm (% count (length anm)))))))
43 (save-excursion
44 (goto-char pos) (delete-char 1))
45 (message "Animation finished.")))
46 ```
47
48 Using `while` clause in the body content, one can make a loop in the thread.
49
50 Be careful not to make an infinite loop or heavy loop accidentally. If you find that the Emacs enters infinite loop, you may be able to stop the loop with executing the command `deferred:clear-queue`.
51
52 ### Generator
53
54 The following code creates a generator object and binds it to the variable `fib-gen`.
55 One can receive values, using `yield` function in the generator body code.
56 When the generator returns a value, the evaluation process stops.
57 Calling generator object as a function, the evaluation process resumes.
58
59 Generator:
60
61 ```el
62 (setq fib-list nil)
63 (setq fib-gen
64 (lexical-let ((a1 0) (a2 1))
65 (cc:generator
66 (lambda (x) (push x fib-list)) ; Receiving values as a callback function
67 (yield a1)
68 (yield a2)
69 (while t
70 (let ((next (+ a1 a2)))
71 (setq a1 a2
72 a2 next)
73 (yield next))))))
74
75 (funcall fib-gen) ; calling 5 times
76 (funcall fib-gen) (funcall fib-gen)
77 (funcall fib-gen) (funcall fib-gen)
78
79 fib-list ; => (3 2 1 1 0)
80 ```
81
82 ### Semaphore
83
84 The semaphore restricts the number of concurrent tasks.
85 The following code creates a semaphore object with one permit, and binds it to the variable `smp`.
86 The subsequent codes and comments show how the semaphore object works.
87
88 Semaphore:
89
90 ```el
91 ;; Create a semaphore with permit=1.
92 (setq smp (cc:semaphore-create 1))
93
94 ;; Start three tasks with acquiring permit.
95 (deferred:nextc (cc:semaphore-acquire smp)
96 (lambda(x)
97 (message "go1")))
98 (deferred:nextc (cc:semaphore-acquire smp)
99 (lambda(x)
100 (message "go2")))
101 (deferred:nextc (cc:semaphore-acquire smp)
102 (lambda(x)
103 (message "go3")))
104
105 ;; => Only the first task is executed and displays "go1".
106 ;; Rest ones are blocked.
107
108 (cc:semaphore-release smp) ; Releasing one permit
109
110 ;; => The second task is executed, then, displays "go2".
111
112 (cc:semaphore-waiting-deferreds smp) ; => The third task object
113
114 (cc:semaphore-release-all smp) ; => Reset permits and return the third task object
115
116 (cc:semaphore-waiting-deferreds smp) ; => nil
117 ```
118
119 ### Dataflow
120
121 The function `cc:dataflow-environment` creates an environment for dataflow variables.
122 The function `cc:dataflow-get` returns a deferred object that can refer the value.
123 The function `cc:dataflow-set` binds a value to a dataflow variable.
124 Any objects can be variable keys in the environment. This sample code uses strings as keys.
125
126 Dataflow:
127
128 ```el
129 ;; Create an environment.
130 (setq dfenv (cc:dataflow-environment))
131
132 ;;## Basic usage
133
134 ;; Referring a variable synchronously. This function doesn't block.
135 (cc:dataflow-get-sync dfenv "abc") ; => nil
136
137 (deferred:$ ; Start the task that gets the value of `abc` and that displays the value.
138 (cc:dataflow-get dfenv "abc")
139 (deferred:nextc it
140 (lambda (x) (message "Got abc : %s" x))))
141 ;; => This task is blocked because no value is bound to the variable `abc`.
142
143 (cc:dataflow-set dfenv "abc" 256) ; Binding a value to the variable `abc`.
144 ;; => The blocked task resumes and displays "Got abc : 256".
145
146 (cc:dataflow-get-sync dfenv "abc") ; => 256
147
148 (cc:dataflow-clear dfenv "abc") ; unbind the variable `abc`
149
150 (cc:dataflow-get-sync dfenv "abc") ; => nil
151
152 ;;## Complex key
153
154 (deferred:$
155 (cc:dataflow-get dfenv '("http://example.com/a.jpg" 300))
156 (deferred:nextc it
157 (lambda (x) (message "a.jpg:300 OK %s" x))))
158
159 (cc:dataflow-set dfenv '("http://example.com/a.jpg" 300) 'jpeg)
160
161 ;; => a.jpg:300 OK jpeg
162
163 ;;## Waiting for two variables
164
165 (deferred:$ ; Start the task that refers two variables, `abc` and `def`.
166 (deferred:parallel
167 (cc:dataflow-get dfenv "abc")
168 (cc:dataflow-get dfenv "def"))
169 (deferred:nextc it
170 (lambda (values)
171 (apply 'message "Got values : %s, %s" values)
172 (apply '+ values)))
173 (deferred:nextc it
174 (lambda (x) (insert (format ">> %s" x)))))
175 ;; => This task is blocked.
176
177 (cc:dataflow-get-waiting-keys dfenv) ; => ("def" "abc")
178 (cc:dataflow-get-avalable-pairs dfenv) ; => ((("http://example.com/a.jpg" 300) . jpeg))
179
180 (cc:dataflow-set dfenv "abc" 128) ; Binding one value. The task is still blocked.
181 (cc:dataflow-set dfenv "def" 256) ; Binding the next value. Then, the task resumes.
182 ;; => Got values : 128, 256
183 ```
184
185 ### Signal
186
187 The function `cc:signal-channel` creates a channel for signals.
188 Then, one can connect receivers and send signals.
189
190 Signal:
191
192 ```el
193 ;; Create a channel.
194 (setq channel (cc:signal-channel))
195
196 (cc:signal-connect ; Connect the receiver for the signal 'foo.
197 channel 'foo
198 (lambda (event) (message "Signal : %S" event)))
199
200 (cc:signal-connect
201 channel t ; The signal symbol 't' means any signals.
202 (lambda (event)
203 (destructuring-bind (event-name (args)) event
204 (message "Listener : %S / %S" event-name args))))
205
206 (deferred:$ ; Connect the deferred task.
207 (cc:signal-connect channel 'foo)
208 (deferred:nextc it
209 (lambda (x) (message "Deferred Signal : %S" x))))
210
211 (cc:signal-send channel 'foo "hello signal!")
212 ;; =>
213 ;; Listener : foo / "hello signal!"
214 ;; Signal : (foo ("hello signal!"))
215 ;; Deferred Signal : (foo ("hello signal!"))
216
217 (cc:signal-send channel 'some "some signal!")
218 ;; =>
219 ;; Listener : some / "some signal!"
220 ```
221
222 Dataflow objects have the own channel to notify accessing to the variables.
223 Receiving the signals for referring unbound variables, one can create values on demand.
224
225 The signal and dataflow objects can be cascades, creating objects with the parent ones.
226 It enables that the dataflow object can have the default values, and that
227 one can use the different scope signals in the tree structure of the channel objects, such as global signals and local signals.
228
229 ## API Details
230
231 ### Thread
232
233 * cc:thread (wait-time-msec &rest body)
234 * Arguments
235 * wait-time-msec: The interval time between tasks (millisecond).
236 * Return
237 * A thread object.
238 * This function creates a thread and start it.
239 * The `thread` means that each s-exps in the body part are executed as asynchronous tasks. Then, the interval between tasks is `wait-time-msec`.
240 * The `while` form in the body part acts as a loop.
241 * Note that the infinite loops or the heavy loop tasks may make the Emacs freeze. The command `deferred:clear-queue` may recover such freeze situation.
242
243 ### Generator
244
245 * cc:generator (callback &rest body)
246 * Arguments
247 * callback: A function to receive the value passed by `yield` form.
248 * body: Generator forms.
249 * Return
250 * A generating function.
251 * Similar to `cc:thread`, each s-exps in the body part are executed as asynchronous tasks and the `while` form in the body part acts as a loop.
252 * The `yield` form in the body part passes the value to the `callback` function and pause the asynchronous tasks.
253 * Calling the generating function, the asynchronous tasks resume.
254
255 ### Semaphore
256
257 * cc:semaphore-create (permits-num)
258 * Arguments
259 * permits-num: The number of permits.
260 * Return
261 * A semaphore object.
262 * This function creates a semaphore object.
263
264 * cc:semaphore-acquire (semaphore)
265 * Argument
266 * semaphore: A semaphore object.
267 * Return
268 * A deferred object.
269 * Acquire an execution permission and return deferred object to chain.
270 * If this semaphore object has permissions, the subsequent deferred task is executed immediately.
271 * If this semaphore object has no permissions, the subsequent deferred task is blocked. After the permission is returned, the task is executed.
272
273 * cc:semaphore-release (semaphore)
274 * Arguments
275 * semaphore: A semaphore object
276 * Return
277 * The given semaphore object
278 * Release an execution permission.
279 * The programmer is responsible to return the permissions.
280
281 * cc:semaphore-with (semaphore body-func &optional error-func)
282 * Arguments
283 * semaphore: A semaphore object
284 * body-func: A task function
285 * error-func: An error handling function (which is connected by `deferred:error`.)
286 * Return
287 * A deferred object
288 * Execute the task function asynchronously with the semaphore block.
289 * Using this function is bit safer than using a pair of `cc:semaphore-acquire` and `cc:semaphore-release`.
290
291 * cc:semaphore-release-all (semaphore)
292 * Arguments
293 * semaphore: A semaphore object
294 * Return
295 * Deferred objects those were waiting for permission.
296 * Release all permissions for resetting the semaphore object.
297 * If the semaphore object has some blocked tasks, this function return a list of the tasks and clear the list of the blocked tasks in the semaphore object.
298
299 * cc:semaphore-interrupt-all (semaphore)
300 * Arguments
301 * semaphore: A semaphore object
302 * Return
303 * A deferred object
304 * Clear the list of the blocked tasks in the semaphore and return a deferred object to chain.
305 * This function is used for the interruption cases.
306
307 ### Signal
308
309 * cc:signal-channel (&optional name parent-channel)
310 * Arguments
311 * name: A channel name for debug.
312 * parent-channel: An upstream channel object.
313 * Return
314 * A channel object.
315 * Create a new channel object.
316 * The observers of this channel can receive the upstream signals.
317 * In the case of using the function `cc:signal-send`, the observers of the upstream channel can not receive the signals of this channel.
318 * The function `cc:signal-send-global` can send a signal to the upstream channels from the downstream channels.
319
320 * cc:signal-connect (channel event-sym &optional callback)
321 * Arguments
322 * channel: A channel object
323 * event-sym: A signal symbol
324 * callback: A receiver function
325 * Return
326 * A deferred object
327 * Append an observer for the symbol of the channel and return a deferred object.
328 * If `event-sym` is `t`, the observer receives all signals of the channel.
329 * If the callback function is given, the deferred object executes the callback function asynchronously.
330 * One can connect subsequent tasks to the returned deferred object.
331
332 * cc:signal-send (channel event-sym &rest args)
333 * Arguments
334 * channel: A channel object
335 * event-sym: A signal symbol
336 * args: Signal arguments
337 * Return
338 * None
339 * Send a signal to the channel.
340 * If the `args` are given, observers can get the values by following code:
341 * `(lambda (event) (destructuring-bind (event-sym (args)) event ... ))`
342
343 * cc:signal-send-global (channel event-sym &rest args)
344 * Arguments
345 * channel: A channel object
346 * event-sym: A signal symbol
347 * args: Signal arguments
348 * Return
349 * None
350 * Send a signal to the most upstream channel.
351
352 * cc:signal-disconnect (channel deferred)
353 * Arguments
354 * channel: A channel object
355 * deferred: The deferred object to delete
356 * Return
357 * The deleted deferred object
358 * Remove the observer object from the channel and return the removed deferred object.
359
360 * cc:signal-disconnect-all (channel)
361 * Arguments
362 * channel: A channel object
363 * Return
364 * None
365 * Remove all observers.
366
367 ### Dataflow
368
369 * cc:dataflow-environment (&optional parent-env test-func channel)
370 * Arguments
371 * parent-env: A dataflow object as the default value.
372 * test-func: A test function that compares the entry keys.
373 * channel: A channel object that sends signals of variable events.
374 * Return
375 * A dataflow object
376 * Create a dataflow environment.
377 * The parent environment
378 * If this environment doesn't have the entry A and the parent one has the entry A, this environment can return the entry A.
379 * One can override the entry, setting another entry A to this environment.
380 * If no channel is given, this function creates a new channel object internally.
381 * Observers can receive following signals:
382 * `get-first` : the fist referrer is waiting for binding,
383 * `get-waiting` : another referrer is waiting for binding,
384 * `set` : a value is bound,
385 * `get` : returned a bound value,
386 * `clear` : cleared one entry,
387 * `clear-all` : cleared all entries.
388
389 * cc:dataflow-get (df key)
390 * Arguments
391 * df: A dataflow object
392 * key: A key object
393 * Return
394 * A deferred object
395 * Return a deferred object that can refer the value which is indicated by the key.
396 * If the dataflow object has the entry that bound value, the subsequent deferred task is executed immediately.
397 * If not, the task is deferred till a value is bound.
398
399 * cc:dataflow-get-sync (df key)
400 * Arguments
401 * df: A dataflow object
402 * key: A key object
403 * Return
404 * Nil or a value
405 * Return the value which is indicated by the key synchronously.
406 * If the environment doesn't have an entry of the key, this function returns nil.
407
408 * cc:dataflow-set (df key value)
409 * Arguments
410 * df: A dataflow object
411 * key: A key object
412 * value: A value
413 * Return
414 * None
415 * Bind the value to the key in the environment.
416 * If the dataflow already has the bound entry of the key, this function throws an error signal.
417 * The value can be nil as a value.
418
419 * cc:dataflow-clear (df key)
420 * Arguments
421 * df: A dataflow object
422 * key: A key object
423 * Return
424 * None
425 * Clear the entry which is indicated by the key.
426 * This function does nothing for the waiting deferred objects.
427
428 * cc:dataflow-get-avalable-pairs (df)
429 * Arguments
430 * df: A dataflow object
431 * Return
432 * An available key-value alist in the environment and the parent ones.
433
434 * cc:dataflow-get-waiting-keys (df)
435 * Arguments
436 * df: A dataflow object
437 * Return
438 * A list of keys which have waiting deferred objects in the environment and the parent ones.
439
440 * cc:dataflow-clear-all (df)
441 * Arguments
442 * df: A dataflow object
443 * Return
444 * None
445 * Clear all entries in the environment.
446 * This function does nothing for the waiting deferred objects.
447
448 * cc:dataflow-connect (df event-sym &optional callback)
449 * Arguments
450 * df: A dataflow object
451 * event-sym: A signal symbol
452 * callback: A receiver function
453 * Return
454 * A deferred object
455 * Append an observer for the symbol of the channel of the environment and return a deferred object.
456 * See the document of `cc:dataflow-environment` for details of signals.
457
458
459 * * * * *
460
461 (C) 2011-2016 SAKURAI Masashi All rights reserved.
462 m.sakurai at kiwanami.net
+669
-0
README.ja.markdown less more
0 # deferred.el #
1
2 [![Build Status](https://travis-ci.org/kiwanami/emacs-deferred.svg)](https://travis-ci.org/kiwanami/emacs-deferred)
3 [![Coverage Status](https://coveralls.io/repos/kiwanami/emacs-deferred/badge.svg)](https://coveralls.io/r/kiwanami/emacs-deferred)
4 [![MELPA](http://melpa.org/packages/deferred-badge.svg)](http://melpa.org/#/deferred)
5 [![MELPA stable](http://stable.melpa.org/packages/deferred-badge.svg)](http://stable.melpa.org/#/deferred)
6 [![Tag Version](https://img.shields.io/github/tag/kiwanami/emacs-deferred.svg)](https://github.com/kiwanami/emacs-deferred/tags)
7 [![License](http://img.shields.io/:license-gpl3-blue.svg)](http://www.gnu.org/licenses/gpl-3.0.html)
8
9 deferred.elは非同期処理を抽象化して書きやすくするためのライブラリです。APIや
10 実装については
11 [JSDeferred](https://github.com/cho45/jsdeferred "JSDeferred") (by cho45さん)と
12 [Mochikit.Async](http://mochikit.com/doc/html/MochiKit/Async.html
13 "Mochikit.Async") (by Bob Ippolitoさん)を参考にしています。
14
15 ## インストール ##
16
17 deferred.elは package.elを使って, [MELPA](http://melpa.org)からインストールすることができます.
18
19 ## 使い方例 ##
20
21 以下のサンプルで例示したソースは deferred-samples.el の中にあります。
22 eval-last-sexp (C-x C-e) などで実行してみてください。
23
24 ### 基本 ###
25
26 基本的な deferred の連結です。messageにいくつか表示し、ミニバッファから
27 入力を受け付けます。
28
29 Chain:
30
31 ```el
32 (deferred:$
33 (deferred:next
34 (lambda () (message "deferred start")))
35 (deferred:nextc it
36 (lambda ()
37 (message "chain 1")
38 1))
39 (deferred:nextc it
40 (lambda (x)
41 (message "chain 2 : %s" x)))
42 (deferred:nextc it
43 (lambda ()
44 (read-minibuffer "Input a number: ")))
45 (deferred:nextc it
46 (lambda (x)
47 (message "Got the number : %i" x)))
48 (deferred:error it
49 (lambda (err)
50 (message "Wrong input : %s" err))))
51 ```
52
53
54 * この式を実行すると、直ちに結果が帰ってきます。
55 * 実際の処理自体はすぐ後に非同期で実行されます。
56 * deferred:$ は deferred を連結するためのマクロです。
57 * itには前の式(deferred:nextなど)の返値が入っています。
58 * 前の deferred 処理の返値が、次の処理の引数になっています。
59 * 数字以外を入力するとエラーになりますが、 deferred:error でエラーを拾っています。
60
61
62 ### タイマーで一定時間後 ###
63
64 1秒待ってメッセージを表示します。
65
66 Timer:
67
68 ```el
69 (deferred:$
70 (deferred:wait 1000) ; 1000msec
71 (deferred:nextc it
72 (lambda (x)
73 (message "Timer sample! : %s msec" x))))
74 ```
75
76 * deferred:wait の次の処理には、実際に経過した時間が渡ってきます。
77
78 ### 外部プロセス・コマンド実行 ###
79
80 外部プロセスで「ls -la」を実行して結果を現在のバッファに表示します。（素のWindowsで動かす場合は、dirなどに変更してみてください。）
81
82 Command process:
83
84 ```el
85 (deferred:$
86 (deferred:process "ls" "-la")
87 (deferred:nextc it
88 (lambda (x) (insert x))))
89 ```
90
91 * 非同期で実行するため、処理がブロックしたりしません。
92
93
94 ### HTTP GET ###
95
96 GNUのトップページのHTMLを取ってきて、現在のバッファに貼り付けます（大量のHTMLが張り付きますが、undoで戻せます）。
97
98 HTTP GET:
99
100 ```el
101 (require 'url)
102
103 (deferred:$
104 (deferred:url-retrieve "http://www.gnu.org")
105 (deferred:nextc it
106 (lambda (buf)
107 (insert (with-current-buffer buf (buffer-string)))
108 (kill-buffer buf))))
109 ```
110
111 ### 画像 ###
112
113 googleの画像を取ってきてそのままバッファに貼り付けます。
114
115 Get an image:
116
117 ```el
118 (deferred:$
119 (deferred:url-retrieve "http://www.google.co.jp/intl/en_com/images/srpr/logo1w.png")
120 (deferred:nextc it
121 (lambda (buf)
122 (insert-image
123 (create-image
124 (let ((data (with-current-buffer buf (buffer-string))))
125 (substring data (+ (string-match "\n\n" data) 2)))
126 'png t))
127 (kill-buffer buf))))
128 ```
129
130 ### 並列 ###
131
132 2つの画像を取ってきて、結果がそろったところで各画像のファイルサイズを現在のバッファに表示します。
133
134 Parallel deferred:
135
136 ```el
137 (deferred:$
138 (deferred:parallel
139 (lambda ()
140 (deferred:url-retrieve "http://www.google.co.jp/intl/en_com/images/srpr/logo1w.png"))
141 (lambda ()
142 (deferred:url-retrieve "http://www.google.co.jp/images/srpr/nav_logo14.png")))
143 (deferred:nextc it
144 (lambda (buffers)
145 (loop for i in buffers
146 do
147 (insert
148 (format
149 "size: %s\n"
150 (with-current-buffer i (length (buffer-string)))))
151 (kill-buffer i)))))
152 ```
153
154 * deferred:parallel 内部で、並列に実行できるものは並列に動作します。
155 * 各処理が完了するかエラーが発生して、すべての処理が完了したところで次の処理が開始されます。
156 * 次の処理には結果がリストで渡されます。
157 * 順番は保持されます
158 * alistを渡して名前で結果を選ぶことも出来ます
159
160 ### deferred組み合わせ、try-catch-finally ###
161
162 外部プロセスの wget で画像を取ってきて、ImageMagic の convert コマンドでリサイズし、バッファに画像を表示します。（wget, convertが無いと動きません）
163 deferred を組み合わせて、非同期処理の try-catch のような構造を作ることが出来ます。
164
165 Get an image by wget and resize by ImageMagick:
166
167 ```el
168 (deferred:$
169
170 ;; try
171 (deferred:$
172 (deferred:process "wget" "-O" "a.jpg" "http://www.gnu.org/software/emacs/tour/images/splash.png")
173 (deferred:nextc it
174 (lambda () (deferred:process "convert" "a.jpg" "-resize" "100x100" "jpg:b.jpg")))
175 (deferred:nextc it
176 (lambda ()
177 (clear-image-cache)
178 (insert-image (create-image (expand-file-name "b.jpg") 'jpeg nil)))))
179
180 ;; catch
181 (deferred:error it ;
182 (lambda (err)
183 (insert "Can not get a image! : " err)))
184
185 ;; finally
186 (deferred:nextc it
187 (lambda ()
188 (deferred:parallel
189 (lambda () (delete-file "a.jpg"))
190 (lambda () (delete-file "b.jpg")))))
191 (deferred:nextc it
192 (lambda (x) (message ">> %s" x))))
193 ```
194
195 * deferred を静的につなげることで、自由に組み合わせることが出来ます。
196 * 関数などで個別の deferred 処理を作って、後で一つにまとめるなど。
197
198 なお、この例は以下のようにも書けます。（注意：完全に同じ動作ではありません。また、非同期の仕組み上、finallyタスクは必ず実行することを保証するものではありません。）
199
200 Try-catch-finally:
201
202 ```el
203 (deferred:$
204 (deferred:try
205 (deferred:$
206 (deferred:process "wget" "-O" "a.jpg" "http://www.gnu.org/software/emacs/tour/images/splash.png")
207 (deferred:nextc it
208 (lambda () (deferred:process "convert" "a.jpg" "-resize" "100x100" "jpg:b.jpg")))
209 (deferred:nextc it
210 (lambda ()
211 (clear-image-cache)
212 (insert-image (create-image (expand-file-name "b.jpg") 'jpeg nil)))))
213 :catch
214 (lambda (err) (insert "Can not get a image! : " err))
215 :finally
216 (lambda ()
217 (delete-file "a.jpg")
218 (delete-file "b.jpg")))
219 (deferred:nextc it
220 (lambda (x) (message ">> %s" x))))
221 ```
222
223 ### earlierでtimeout ###
224
225 外部プロセスで3秒待つコマンドを実行しますが、途中でキャンセルします。
226
227 deferred:earlier は parallel と同様に、引数の処理を並列に実行しますが、一番早く完了した処理の結果を次の処理に渡します。他の処理はその時点でキャンセルされます。
228
229 Timeout Process:
230
231 ```el
232 (deferred:$
233 (deferred:earlier
234 (deferred:process "sh" "-c" "sleep 3 | echo 'hello!'")
235 (deferred:$
236 (deferred:wait 1000) ; timeout msec
237 (deferred:nextc it (lambda () "canceled!"))))
238 (deferred:nextc it
239 (lambda (x) (insert x))))
240 ```
241
242 * deferred:wait の待つ時間を5秒などにすると、コマンドの結果が渡ってきます。
243 * エラーは完了と見なされません。すべての処理がエラーになった場合は nil が次に渡ります。
244 * deferred:parallel と deferred:earlier は lisp の and や or のようなイメージです。
245
246 なお、この例は deferred:timeout マクロを使って以下のようにも書けます。
247
248 Timeout macro:
249
250 ```el
251 (deferred:$
252 (deferred:timeout
253 1000 "canceled!"
254 (deferred:process "sh" "-c" "sleep 3 | echo 'hello!'"))
255 (deferred:nextc it
256 (lambda (x) (insert x))))
257 ```
258
259 ### ループとアニメーション・スレッド ###
260
261 数秒間カーソールのある位置に文字でアニメーションを表示します。その間、カーソールを自由に動かして普通にEmacsを操作できます。
262
263 deferredの処理の中でdeferredオブジェクトを返すと、ソースコードで（静的に）繋がっている次のdeferred処理へ移る前に、返した方のdeferredオブジェクトを実行します（動的なdeferredの接続）。再帰的な構造にしてwaitを入れて負荷を調節することで、マルチスレッドのような処理を実現することが出来ます。
264
265 Loop and animation:
266
267 ```el
268 (lexical-let ((count 0) (anm "-/|\\-")
269 (end 50) (pos (point))
270 (wait-time 50))
271 (deferred:$
272 (deferred:next
273 (lambda (x) (message "Animation started.")))
274
275 (deferred:nextc it
276 (deferred:lambda (x)
277 (save-excursion
278 (when (< 0 count)
279 (goto-char pos) (delete-char 1))
280 (insert (char-to-string
281 (aref anm (% count (length anm))))))
282 (if (> end (incf count)) ; 止める場合はdeferredでないものを返す（この場合はnil）
283 (deferred:nextc (deferred:wait wait-time) self)))) ; 続けるときはdeferredを返す
284
285 (deferred:nextc it
286 (lambda (x)
287 (save-excursion
288 (goto-char pos) (delete-char 1))
289 (message "Animation finished.")))))
290 ```
291
292 * deferred:lambda は自分自身をselfとして使えるマクロです。再帰的構造を作るのに便利です。
293
294 ## インタフェース解説 ##
295
296 「関数」の章では各関数の簡単な説明を行います。「実行・接続」の章では、deferredオブジェクトの接続（実行順序）などの説明を行います。
297
298 ### 関数 ###
299
300 #### 基本 ####
301
302 良く使用する基本的な関数やマクロです。
303
304 * deferred:next (callback)
305 * 引数：
306 * callback: 引数1つか0個の関数
307 * 返値：deferredオブジェクト
308 * 引数の関数をコールバックとしてラップしたdeferredオブジェクトを生成して返します。また実行キューに入れて非同期実行をスケジュールします。
309 * →関数を非同期で実行します。
310
311
312 * deferred:nextc (d callback)
313 * 引数：
314 * d: deferredオブジェクト
315 * callback: 引数1つか0個の関数
316 * 返値：deferredオブジェクト
317 * 引数の関数をコールバックとしてラップしたdeferredオブジェクトを生成し、引数のdeferredオブジェクトに接続して返します。
318 * →前のdeferredの後に関数を実行するように連結します。
319
320 * deferred:error (d errorback)
321 * 引数：
322 * d: deferredオブジェクト
323 * errorback: 引数1つか0個の関数
324 * 返値：deferredオブジェクト
325 * 引数の関数をエラー処理コールバックとしてラップしたdeferredオブジェクトを生成し、引数のdeferredオブジェクトに接続して返します。
326 * →前のdeferredでエラーが起きたときに、この関数で処理するようにします。
327 * この関数内で例外を発生しなければ、後続のdeferredのコールバック関数が実行されます。
328
329 * deferred:cancel (d)
330 * 引数：
331 * d: deferredオブジェクト
332 * 返値：引数のdeferredオブジェクト（無効になっている）
333 * 引数のdeferredオブジェクトを無効にして、コールバックやエラーバック関数が実行されないようにします。
334 * この関数は引数のdeferredオブジェクトを破壊的に変更します。
335
336 * deferred:watch (d callback)
337 * 引数：
338 * d: deferredオブジェクト
339 * callback: 引数1つか0個の関数
340 * 返値：deferredオブジェクト
341 * 引数の関数をコールバックとエラーバックの両方でラップしたdeferredオブジェクトを生成し、引数のdeferredオブジェクトに接続して返します。
342 * 次のdeferredタスクへの値は前のタスクの結果をそのまま渡します。
343 * callbackが何を返しても、callback内部でエラーが発生しても、deferredの流れに影響を与えません。
344 * callback内部の非同期タスクは後続のdeferredタスクと非同期に実行されます。
345 * →deferred処理の流れに割り込んだり、実行状況を監視したいときに使います。
346
347 * deferred:wait (msec)
348 * 引数：
349 * msec: 数値
350 * 返値：deferredオブジェクト
351 * この関数が実行された時点から引数で指定されたミリ秒待って、後続のdeferredオブジェクトを実行します。
352 * 後続のdeferredオブジェクトのコールバック関数の引数には、実際に経過した時間がミリ秒で渡ってきます。
353
354 * deferred:$ (forms...)
355 * 引数：1つ以上のdeferredフォーム
356 * 返値：一番最後のdeferredオブジェクト
357 * deferredオブジェクトのチェインを書きやすくするためのアナフォリックマクロです。
358 * 一つ前のdeferredオブジェクトが「it」で渡ってきます。
359
360 #### ユーティリティ ####
361
362 複数のdeferredを扱う関数です。
363
364 * deferred:loop (number-or-list callback)
365 * 引数：
366 * number-or-list: 1以上の整数もしくはリスト
367 * callback: 引数1つか0個の関数
368 * 返値：deferredオブジェクト
369 * 引数の数値で指定された数だけループするようなdeferredオブジェクトを生成して返します。関数には0から始まるカウンタが渡ってきます。
370 * 整数ではなくリストが渡ってきた場合は、mapcのようにループします。
371
372 * deferred:parallel (list-or-alist)
373 * 引数：以下のどちらか
374 * 1つ以上のdeferredオブジェクトか引数1つか0個の関数のリスト
375 * 1つ以上のシンボルとdeferredオブジェクトか引数1つか0個の関数によるconsセルのリスト（つまりalist）
376 * 返値：deferredオブジェクト
377 * 引数に与えられたdeferredオブジェクトを並列に実行し、結果を待ち合わせます。
378 * 後続のdeferredには結果が順番の保持されたリストとして渡ります。
379 * 引数にalistが渡した場合は、結果もalistで渡ります。この場合は順番は保持されません。
380 * deferred処理の中でエラーが発生した場合は、結果のリストの中にエラーオブジェクトが入ります。
381
382 * deferred:earlier (list-or-alist)
383 * 引数：以下のどちらか
384 * 1つ以上のdeferredオブジェクトか引数1つか0個の関数のリスト
385 * 1つ以上のシンボルとdeferredオブジェクトか引数1つか0個の関数によるconsセルのリスト（つまりalist）
386 * 返値：deferredオブジェクト
387 * 引数に与えられたdeferredオブジェクトを並列に実行し、最初に帰ってきた結果を後続のdeferredに渡します。
388 * 2番目以降の処理はキャンセルされ、結果が帰ってきても無視されます。
389 * 引数にalistを渡した場合は、結果はconsセルで渡ります。
390 * deferred処理の中でエラーが発生した場合は、結果が帰ってこなかったものとして扱われます。
391 * すべての処理がエラーになった場合は、後続のdeferredにnilが渡ります。つまり、エラーバックで処理されません。
392
393 #### ラッパー ####
394
395 元からある処理をdeferredでラップする関数です。
396
397 * deferred:call (function args...)
398 * 引数：
399 * function: 関数のシンボル
400 * args: 引数（可変長）
401 * 返値：deferredオブジェクト
402 * オリジナルのfuncallを非同期にした関数です
403
404 * deferred:apply (function args)
405 * 引数：
406 * function: 関数のシンボル
407 * args: 引数（リスト）
408 * 返値：deferredオブジェクト
409 * オリジナルのapplyを非同期にした関数です
410
411 * deferred:process (command args...) / deferred:process-shell (command args...)
412 * 引数：
413 * command: 外部実行コマンド
414 * args: コマンドの引数(可変長)
415 * 返値：deferredオブジェクト
416 * 外部コマンドを非同期で実行します。（start-process, start-process-shell-command のラッパー）
417 * 外部コマンドのstdoutの結果が文字列として後続のdeferredに渡ります。
418
419 * deferred:process-buffer (command args...) / deferred:process-shell-buffer (command args...)
420 * 引数：
421 * command: 外部実行コマンド
422 * args: コマンドの引数(可変長)
423 * 返値：deferredオブジェクト
424 * 外部コマンドを非同期で実行します。（start-process, start-process-shell-command のラッパー）
425 * 外部コマンドのstdoutの結果がバッファとして後続のdeferredに渡ります。
426 * バッファの処分は後続のdeferredに任されます。
427
428 * deferred:wait-idle (msec)
429 * 引数：
430 * msec: 数値
431 * 返値：deferredオブジェクト
432 * 引数で指定されたミリ秒間Emacsがアイドル状態だったときに、後続のdeferredオブジェクトを実行します。
433 * 後続のdeferredオブジェクトのコールバック関数の引数には、この関数が呼ばれてから経過した時間がミリ秒で渡ってきます。
434
435 * deferred:url-retrieve (url [cbargs])
436 * 引数：
437 * url: 取ってきたいURL
438 * cbargs: コールバック引数（オリジナル関数のもの。省略可。）
439 * 返値：deferredオブジェクト
440 * urlパッケージにある、オリジナルのurl-retrieveをdeferredでラップした関数です。
441 * HTTPで取得した結果が、後続のdeferredにバッファで渡ります。
442 * バッファの処分は後続のdeferredに任されます。
443
444 * （仮）deferred:url-get (url params)
445 * 引数：
446 * url: 取ってきたいURL
447 * params: パラメーターのalist
448 * 返値：deferredオブジェクト
449 * パラメーターを指定しやすくした関数です。仮実装ですので今後仕様が変わる可能性があります。
450
451 * （仮）deferred:url-post (url params)
452 * 引数：
453 * url: 取ってきたいURL
454 * params: パラメーターのalist
455 * 返値：deferredオブジェクト
456 * パラメーターを指定しやすくして、POSTでアクセスする関数です。仮実装ですので今後仕様が変わる可能性があります。
457
458 #### インスタンスメソッド ####
459
460 プリミティブな操作を行う関数です。典型的でないdeferred処理を行いたい場合に、組み合わせて使います。
461
462 * deferred:new (callback)
463 * 引数：引数1つか0個の関数
464 * 返値：deferredオブジェクト
465 * 引数の関数をコールバックとしてラップしたdeferredオブジェクトを生成して返します。
466 * 実行キューに入れないため、deferred:callbackやdeferred:errorbackが呼ばれない限り実行されません。
467 * 一時停止して他のイベントを待つような、deferredチェインを作りたいときに使います。 → deferred:wait のソースなどを参考。
468
469 * deferred:succeed ([value])
470 * 引数：値（省略可）
471 * 返値：deferredオブジェクト
472 * 引数の値を使って、既にコールバックが呼ばれた状態のdeferredを返します。
473 * 後続のdeferredは接続されたら直ちに（同期的に）実行されます。
474
475 * deferred:fail ([error])
476 * 引数：値（省略可）
477 * 返値：deferredオブジェクト
478 * 引数の値を使って、既にエラーバックが呼ばれた状態のdeferredを返します。
479 * 後続のdeferredは接続されたら直ちに（同期的に）実行されます。
480
481 * deferred:callback (d [value])
482 * 引数：
483 * d: deferredオブジェクト
484 * value: 値（省略可）
485 * 返値：deferredオブジェクトか、結果値
486 * 引数のdeferredオブジェクトを同期的に開始します。
487 * ただし、同期的な実行は初回のみで、引数のdeferred以降のdeferredオブジェクトは非同期に実行されます。
488
489 * deferred:callback-post (d [value])
490 * 引数：
491 * d: deferredオブジェクト
492 * value: 値（省略可）
493 * 返値：deferredオブジェクトか、結果値
494 * 引数のdeferredオブジェクトを非同期に開始します。
495
496 * deferred:errorback (d [error])
497 * 引数：
498 * d: deferredオブジェクト
499 * error: 値（省略可）
500 * 返値：deferredオブジェクトか、結果値
501 * 引数のdeferredオブジェクトからエラーバックを同期的に開始します。
502
503 * deferred:errorback-post (d [error])
504 * 引数：
505 * d: deferredオブジェクト
506 * error: 値（省略可）
507 * 返値：deferredオブジェクトか、結果値
508 * 引数のdeferredオブジェクトからエラーバックを非同期に開始します。
509
510
511 ### ユーティリティマクロ ###
512
513 いくつかの便利なマクロを用意しています。マクロですので、スコープや評価順序などに注意して予想外の動作に気をつけてください。
514
515 * deferred:try (d &key catch finally)
516 * 引数：
517 * d: deferredオブジェクト
518 * catch: [キーワード引数] dのタスクを実行中にエラーが起きたときに実行される関数。（マクロ展開によって deferred:error の引数に入る）
519 * finally: [キーワード引数] dのタスクが正常・エラーに関わらず終了したあとに実行する関数（マクロ展開によって deferred:watch の引数に入る）
520 * 返値：deferredオブジェクト
521 * 非同期処理で try-catch-finally のような処理を実現するマクロです。所詮非同期なので、メインのdeferredタスクの内容によっては、finallyタスクに処理が回ってこない可能性もあります。
522 * deferred:error と deferred:watch を使って実装しています。
523
524 * deferred:timeout (msec timeout-form d)
525 * 引数：
526 * msec: 数値
527 * timeout-form: キャンセル時に評価する sexp-form
528 * d: deferredオブジェクト
529 * 返値：deferredオブジェクト
530 * dのタスクを開始してmsecミリ秒経過した場合、dのタスクをキャンセルして、timeout-formの結果を後続のdeferredに渡します。
531 * deferred:earlierとdeferred:waitを使って実装しています。
532
533 * deferred:process〜
534 * deferred:processc (d command args...)
535 * deferred:process-bufferc (d command args...)
536 * deferred:process-shellc (d command args...)
537 * deferred:process-shell-bufferc (d command args...)
538 * 引数：
539 * d: deferredオブジェクト
540 * command: 外部実行コマンド
541 * args: コマンドの引数(可変長)
542 * 返値：deferredオブジェクト
543 * 外部コマンドを非同期で実行するdeferredオブジェクトをdに接続します。
544 * deferred:nextc の lambda の中に元の関数を埋め込んで実装しています。
545
546 ### 実行・接続 ###
547
548 #### 処理開始について ####
549
550 関数の中には処理を自動的に開始するものとしないものがあります。
551
552 以下の関数は、非同期実行用のキューにdeferredオブジェクトを登録します。つまり、自動的に実行を開始します。
553
554 * next
555 * wait
556 * loop
557 * parallel
558 * earlier
559 * call, apply
560 * process
561 * url-retrieve, url-get, url-post
562
563 new は callback や errorback を呼ぶまで実行が開始されません。他のイベントを待って実行を開始するような用途で使います。
564
565 deferredオブジェクトは先にコールバックを実行しておいて、後で後続のdeferredオブジェクトをつなげることも出来ます。つまり、一番最後のdeferredオブジェクトは、続きのdeferredオブジェクトが接続されるまで結果を保持し続けます。succeed と fail は、そのような既に実行された状態の deferred を生成します。
566
567 #### ソースコード上のでの接続 ####
568
569 deferredオブジェクトを$などを使ってソースコード上で連結することを、静的な接続と呼びます。
570
571 これはdeferredの基本的な使い方で、コールバック処理の書き方を変えたものだと言えます。
572
573 処理がコード上に並びますので読みやすく、流れも理解しやすいです。通常、このパターンを使います。
574
575 #### 実行時に接続 ####
576
577 deferred処理の中でdeferredオブジェクトを返すと、静的に接続された（ソースコード上の）後続のdeferredオブジェクトの前に、そのdeferredを割り込ませます。
578
579 この動作により、ループや分岐などの高度な非同期処理を行うことができます。
580
581 ## ポイント ##
582
583 ここでは、いくつかの実装上のポイントを示します。
584
585 ### レキシカルスコープ ###
586
587 deferredの処理に値を持って行く場合、lexical-let などを用いてレキシカルスコープを使うと大変便利です。
588
589 特に、一連のdeferred処理の中で共通に使う値にレキシカルスコープを使うと、ローカル変数のようにアクセスすること出来るため、非同期処理のために値をグローバルに保持しておく必要が無くなります。
590
591 lexical-let 例:
592
593 ```el
594 (lexical-let ((a (point)))
595 (deferred:$
596 (deferred:wait 1000)
597 (deferred:nextc it
598 (lambda (x)
599 (goto-char a)
600 (insert "here!")))))
601 ```
602
603 逆に、lexical-letでレキシカルスコープにバインドしていないシンボルを参照しようとして、エラーになることがよくあります。
604
605 ### カレント状態 ###
606
607 save-execursion や with-current-buffer など、S式の範囲で状態を保持する関数がありますが、deferred関数を囲っていても非同期で処理される時点では無効になっています。
608
609 ダメな例:
610
611 ```el
612 (with-current-buffer (get-buffer "*Message*")
613 (deferred:$
614 (deferred:wait 1000)
615 (deferred:nextc it
616 (lambda (x)
617 (insert "Time: %s " x) ; ここは *Message* バッファとは限らない！
618 ))))
619 ```
620
621 このような場合は、レキシカルスコープなどでdeferredの中にバッファオブジェクトを持って行き、その中でバッファを切り替える必要があります。
622
623 改善例:
624
625 ```el
626 (lexical-let ((buf (get-buffer "*Message*")))
627 (deferred:$
628 (deferred:wait 1000)
629 (deferred:nextc it
630 (lambda (x)
631 (with-current-buffer buf ; 非同期処理の中で設定する
632 (insert "Time: %s " x))))))
633 ```
634
635 ### lambdaの返り値に気を使う ###
636
637 先に述べたとおり、deferredの処理の中でdeferredオブジェクトを返すと、動的な接続によりdeferred処理が割り込まれます。しかしながら、意図せずdeferredオブジェクトを返してしまい、実行順序がおかしくなり、バグに繋がるケースがあります。
638
639 そのため、deferredのコールバックで返す値には気をつける必要があります。特に値を返さない場合は、予防として明示的にnilを返すようにするといいと思います。
640
641 ### デバッグ ###
642
643 通常の処理に比べて、非同期の処理はデバッグが難しいことが多いです。デバッガが使える場面も多いですが、デバッガで停止中に他の非同期処理が行われたりすることがあるため、正しくデバッグできないこともあります。その場合は、message文をちりばめるとか、独自のログバッファに出力するなどしてデバッグすることが確実だと思います。
644
645 意図せず無限ループに陥って、非同期処理が延々と走り続けてしまうことがあります。その場合は、 deferred:clear-queue 関数を呼ぶ（M-xからも呼べます）ことで、実行キューを空にして止めることが出来ます。
646
647 非同期のタスクで発生したエラーは、エラーバックで拾わないと最終的にはmessageに表示されます。deferredの実装内部は condition-case で囲っていますので、デバッガでエラーを拾いたい場合は toggle-debug-on-error でデバッガを有効にすると同時に、 deferred:debug-on-signal を t に設定して発生したエラー取得するようにしてください。
648
649 deferred:sync! 関数を使うことによって、deferred タスクを待ち合わせて同期的にすることができます。ただし、待ち合わせは完全ではないため、テストやデバッグ目的にのみ使うようにして、実アプリでは使わないようにしてください。
650
651 ### マクロ ###
652
653 deferred.elを使うと、nextcやlambdaをたくさん書くことになると思います。これらをマクロでラップすることで短く書くことが可能になります。deferred.elのテストコードのtest-deferred.elでは、マクロを使ってとにかく短く書いています。
654
655 一方、マクロでlambdaを隠蔽することで、フォームを実行した値を渡したいのか、あるいは非同期に実行される関数が引数なのか、分かりづらくなるおそれがあります。そういった理由からdeferred.elでは積極的に便利なマクロを提供していません。マクロで短く書く場合には、実行されるタイミングに気をつける必要があります。
656
657 ### deferred入門 ###
658
659 deferredによってどのようなことが可能になるかなどについては、JavaScriptの例ではありますが、以下のドキュメントが大変参考になると思います。
660
661 * [JSDeferred紹介](http://cho45.stfuawsc.com/jsdeferred/doc/intro.html "JSDeferred紹介")
662 * [特集：JSDeferredで，面倒な非同期処理とサヨナラ｜gihyo.jp … 技術評論社](http://gihyo.jp/dev/feature/01/jsdeferred "特集：JSDeferredで，面倒な非同期処理とサヨナラ｜gihyo.jp … 技術評論社")
663
664
665 * * * * *
666
667 (C) 2010-2016 SAKURAI Masashi All rights reserved.
668 m.sakurai at kiwanami.net
+721
-0
README.markdown less more
0 # deferred.el #
1
2 [![Build Status](https://travis-ci.org/kiwanami/emacs-deferred.svg)](https://travis-ci.org/kiwanami/emacs-deferred)
3 [![Coverage Status](https://coveralls.io/repos/kiwanami/emacs-deferred/badge.svg)](https://coveralls.io/r/kiwanami/emacs-deferred)
4 [![MELPA](http://melpa.org/packages/deferred-badge.svg)](http://melpa.org/#/deferred)
5 [![MELPA stable](http://stable.melpa.org/packages/deferred-badge.svg)](http://stable.melpa.org/#/deferred)
6 [![Tag Version](https://img.shields.io/github/tag/kiwanami/emacs-deferred.svg)](https://github.com/kiwanami/emacs-deferred/tags)
7 [![License](http://img.shields.io/:license-gpl3-blue.svg)](http://www.gnu.org/licenses/gpl-3.0.html)
8
9 `deferred.el` provides facilities to manage asynchronous tasks.
10
11 The API and implementations were translated from
12 [JSDeferred](https://github.com/cho45/jsdeferred "JSDeferred") (by cho45) and
13 [Mochikit.Async](http://mochikit.com/doc/html/MochiKit/Async.html
14 "Mochikit.Async") (by Bob Ippolito) in JavaScript.
15
16 *(note the README for `concurrent` is [here in the same repo](./README-concurrent.markdown))*
17
18 ## Installation ##
19
20 You can install deferred.el from [MELPA](http://melpa.org) by package.el.
21
22 ## Sample codes ##
23
24 You can find following sample codes in `deferred-sample.el`.
25 Executing `eval-last-sexp` (C-x C-e), you can try those codes.
26
27 ### Basic usage ###
28
29 This is a basic deferred chain. This code puts some outputs into
30 message buffer, and then require a number from minibuffer.
31
32 Chain:
33
34 ```el
35 (deferred:$
36 (deferred:next
37 (lambda () (message "deferred start")))
38 (deferred:nextc it
39 (lambda ()
40 (message "chain 1")
41 1))
42 (deferred:nextc it
43 (lambda (x)
44 (message "chain 2 : %s" x)))
45 (deferred:nextc it
46 (lambda ()
47 (read-minibuffer "Input a number: ")))
48 (deferred:nextc it
49 (lambda (x)
50 (message "Got the number : %i" x)))
51 (deferred:error it
52 (lambda (err)
53 (message "Wrong input : %s" err))))
54 ```
55
56 * This s-exp returns immediately.
57 * Asynchronous tasks start subsequently.
58 * The macro `deferred:$` chains deferred objects.
59 * The anaphoric variable `it` holds a deferred object in the previous line.
60 * The next deferred task receives the value that is returned by the previous deferred one.
61 * Inputting a wrong value, such as alphabets, this s-exp raises an error. The error is caught by the errorback function defined by `deferred:error`.
62
63 ### Timer ###
64
65 After evaluating this s-exp and waiting for 1 second, a message is shown in the minibuffer.
66
67 Timer:
68
69 ```el
70 (deferred:$
71 (deferred:wait 1000) ; 1000msec
72 (deferred:nextc it
73 (lambda (x)
74 (message "Timer sample! : %s msec" x))))
75 ```
76
77 * The next deferred task subsequent to deferred:wait receives the actual elapse time in millisecond.
78
79 ### Commands and Sub-process ###
80
81 This s-exp inserts the result that is performed by the command `ls -la`. (This s-exp may not run in windows. Try `dir` command.)
82
83 Command process:
84
85 ```el
86 (deferred:$
87 (deferred:process "ls" "-la")
88 (deferred:nextc it
89 (lambda (x) (insert x))))
90 ```
91
92 * This s-exp hardly blocks Emacs because of asynchronous mechanisms.
93
94
95 ### HTTP GET : Text ###
96
97 This s-exp inserts a text from http://www.gnu.org asynchronously. (You can clear the result with undo command.)
98
99 HTTP GET:
100
101 ```el
102 (require 'url)
103
104 (deferred:$
105 (deferred:url-retrieve "http://www.gnu.org")
106 (deferred:nextc it
107 (lambda (buf)
108 (insert (with-current-buffer buf (buffer-string)))
109 (kill-buffer buf))))
110 ```
111
112 ### HTTP Get : Image ###
113
114 This s-exp inserts an image from google asynchronously.
115
116 Get an image:
117
118 ```el
119 (deferred:$
120 (deferred:url-retrieve "http://www.google.co.jp/intl/en_com/images/srpr/logo1w.png")
121 (deferred:nextc it
122 (lambda (buf)
123 (insert-image
124 (create-image
125 (let ((data (with-current-buffer buf (buffer-string))))
126 (substring data (+ (string-match "\n\n" data) 2)))
127 'png t))
128 (kill-buffer buf))))
129 ```
130
131 ### Parallel ###
132
133 This s-exp retrieves two images from google concurrently and wait for the both results. Then, the file sizes of the images are inserted the current buffer.
134
135 Parallel deferred:
136
137 ```el
138 (deferred:$
139 (deferred:parallel
140 (lambda ()
141 (deferred:url-retrieve "http://www.google.co.jp/intl/en_com/images/srpr/logo1w.png"))
142 (lambda ()
143 (deferred:url-retrieve "http://www.google.co.jp/images/srpr/nav_logo14.png")))
144 (deferred:nextc it
145 (lambda (buffers)
146 (loop for i in buffers
147 do
148 (insert
149 (format
150 "size: %s\n"
151 (with-current-buffer i (length (buffer-string)))))
152 (kill-buffer i)))))
153 ```
154
155 * The function `deferred:parallel` runs asynchronous tasks concurrently.
156 * The function wait for all results, regardless normal or abnormal. Then, the subsequent tasks are executed.
157 * The next task receives a list of the results.
158 * The order of the results is corresponding to one of the argument.
159 * Giving an alist of tasks as the argument, the results alist is returned.
160
161 ### Deferred Combination : try-catch-finally ###
162
163 This s-exp executes following tasks:
164 * Getting an image by wget command,
165 * Resizing the image by convert command in ImageMagick,
166 * Insert the re-sized image into the current buffer.
167 You can construct the control structure of deferred tasks, like try-catch-finally in Java.
168
169 Get an image by wget and resize by ImageMagick:
170
171 ```el
172 (deferred:$
173
174 ;; try
175 (deferred:$
176 (deferred:process "wget" "-O" "a.jpg" "http://www.gnu.org/software/emacs/tour/images/splash.png")
177 (deferred:nextc it
178 (lambda () (deferred:process "convert" "a.jpg" "-resize" "100x100" "jpg:b.jpg")))
179 (deferred:nextc it
180 (lambda ()
181 (clear-image-cache)
182 (insert-image (create-image (expand-file-name "b.jpg") 'jpeg nil)))))
183
184 ;; catch
185 (deferred:error it ;
186 (lambda (err)
187 (insert "Can not get a image! : " err)))
188
189 ;; finally
190 (deferred:nextc it
191 (lambda ()
192 (deferred:parallel
193 (lambda () (delete-file "a.jpg"))
194 (lambda () (delete-file "b.jpg")))))
195 (deferred:nextc it
196 (lambda (x) (message ">> %s" x))))
197 ```
198
199 * In this case, the deferred tasks are statically connected.
200
201 Here is an another sample code for try-catch-finally blocks. This is simpler than above code because of the `deferred:try' macro. (Note: They bring the same results practically, but are not perfectly identical. The `finally` task may not be called because of asynchrony.)
202
203 Try-catch-finally:
204
205 ```el
206 (deferred:$
207 (deferred:try
208 (deferred:$
209 (deferred:process "wget" "-O" "a.jpg" "http://www.gnu.org/software/emacs/tour/images/splash.png")
210 (deferred:nextc it
211 (lambda () (deferred:process "convert" "a.jpg" "-resize" "100x100" "jpg:b.jpg")))
212 (deferred:nextc it
213 (lambda ()
214 (clear-image-cache)
215 (insert-image (create-image (expand-file-name "b.jpg") `jpeg nil)))))
216 :catch
217 (lambda (err) (insert "Can not get a image! : " err))
218 :finally
219 (lambda ()
220 (delete-file "a.jpg")
221 (delete-file "b.jpg")))
222 (deferred:nextc it
223 (lambda (x) (message ">> %s" x))))
224 ```
225
226 ### Timeout ###
227
228 Although a long time command is executed (3 second sleeping), the task is rejected by timeout for 1 second.
229
230 The function `deferred:earlier` also runs asynchronous tasks concurrently, however, the next deferred task receives the first result. The other results and tasks will be rejected (canceled or ignored).
231
232 Timeout Process:
233
234 ```el
235 (deferred:$
236 (deferred:earlier
237 (deferred:process "sh" "-c" "sleep 3 | echo 'hello!'")
238 (deferred:$
239 (deferred:wait 1000) ; timeout msec
240 (deferred:nextc it (lambda () "canceled!"))))
241 (deferred:nextc it
242 (lambda (x) (insert x))))
243 ```
244
245 * Changing longer timeout for `deferred:wait`, the next task receives a result of the command.
246 * When a task finishes abnormally, the task is ignored.
247 * When all tasks finishes abnormally, the next task receives nil.
248 * The functions `deferred:parallel` and `deferred:earlier` may be corresponding to `and` and `or`, respectively.
249
250 Here is an another sample code for timeout, employing `deferred:timeout` macro.
251
252 Timeout macro:
253
254 ```el
255 (deferred:$
256 (deferred:timeout
257 1000 "canceled!"
258 (deferred:process "sh" "-c" "sleep 3 | echo 'hello!'"))
259 (deferred:nextc it
260 (lambda (x) (insert x))))
261 ```
262
263 Note that the `deferred:timeout` and `deferred:earlier` just rejects the task result and does not stop the running task chains. Please see the document for `deferred:cancel`.
264
265 ### Loop and Animation ###
266
267 This s-exp plays an animation at the cursor position for few seconds. Then, you can move cursor freely, because the animation does not block Emacs.
268
269 Returning a deferred object in the deferred tasks, the returned task is executed before the next deferred one that is statically connected on the source code. (In this case, the interrupt task is dynamically connected.)
270
271 Employing a recursive structure of deferred tasks, you can construct a deferred loop.
272 It may seem the multi-thread in Emacs Lisp.
273
274 Loop and animation:
275
276 ```el
277 (lexical-let ((count 0) (anm "-/|\\-")
278 (end 50) (pos (point))
279 (wait-time 50))
280 (deferred:$
281 (deferred:next
282 (lambda (x) (message "Animation started.")))
283
284 (deferred:nextc it
285 (deferred:lambda (x)
286 (save-excursion
287 (when (< 0 count)
288 (goto-char pos) (delete-char 1))
289 (insert (char-to-string
290 (aref anm (% count (length anm))))))
291 (if (> end (incf count)) ; return nil to stop this loop
292 (deferred:nextc (deferred:wait wait-time) self)))) ; return the deferred
293
294 (deferred:nextc it
295 (lambda (x)
296 (save-excursion
297 (goto-char pos) (delete-char 1))
298 (message "Animation finished.")))))
299 ```
300
301 * `deferred:lambda` is an anaphoric macro in which `self` refers itself. It is convenient to construct a recursive structure.
302
303 ### Wrapping asynchronous function ###
304
305 Let's say you have an asynchronous function which takes a callback. For example, dbus.el, xml-rpc.el and websocket.el has such kind of asynchronous APIs. To use such libraries with deferred.el, you can make an unregistered deferred object using `deferred:new` and then start the deferred callback queue using `deferred:callback-post` in the callback given to the asynchronous function. If the asynchronous function supports "errorback", you can use `deferred:errorback-post` to pass the error information to the following callback queue.
306
307 In the following example, `run-at-time` is used as an example for the asynchronous function. Deferred.el already has `deferred:wait` for this purpose so that you don't need the following code if you want to use `run-at-time`.
308
309 ```el
310 (deferred:$
311 (deferred:next
312 (lambda ()
313 (message "1")
314 1))
315 (deferred:nextc it
316 (lambda (x)
317 (lexical-let ((d (deferred:new #'identity)))
318 (run-at-time 0 nil (lambda (x)
319 ;; Start the following callback queue now.
320 (deferred:callback-post d x))
321 x)
322 ;; Return the unregistered (not yet started) callback
323 ;; queue, so that the following queue will wait until it
324 ;; is started.
325 d)))
326 ;; You can connect deferred callback queues
327 (deferred:nextc it
328 (lambda (x)
329 (message "%s" (1+ x)))))
330 ```
331
332 ## API ##
333
334 ### Functions ###
335
336 #### Basic functions ####
337
338 * deferred:next (callback)
339 * Arguments
340 * callback: a function with zero or one argument
341 * Return
342 * a deferred object
343 * Return a deferred object that wrap the given callback function. Then, put the deferred object into the execution queue to run asynchronously.
344 * Namely, run the given function asynchronously.
345
346
347 * deferred:nextc (d callback)
348 * Arguments
349 * d: a deferred object
350 * callback: a function with zero or one argument
351 * Return
352 * a deferred object
353 * Return a deferred object that wrap the given callback function. Then, connect the created deferred object with the given deferred object.
354 * Namely, add the given function to the previous deferred object.
355
356 * deferred:error (d errorback)
357 * Arguments
358 * d: a deferred object
359 * errorback: a function with zero or one argument
360 * Return
361 * a deferred object
362 * Return a deferred object that wrap the given function as errorback. Then, connect the created deferred object with the given deferred object.
363 * Namely, the given function catches the error occurred in the previous task.
364 * If this function does not throw an error, the subsequent callback functions are executed.
365
366 * deferred:cancel (d)
367 * Arguments
368 * d: a deferred object
369 * Return
370 * the given deferred object (invalidated)
371 * Invalidate the given deferred object.
372 * Because this function modifies the deferred object, one can not used the given deferred instance again.
373 * This function just cancels the given deferred instance, not the whole deferred chain. In the current deferred implementation, a message of cancellation can not propagate to chained deferred objects because the chain is built by the singly linked list. If the deferred chains may be canceled on your code, you should care the side-effect tasks.
374
375 * deferred:watch (d callback)
376 * Arguments
377 * d: deferred object
378 * callback: a function with zero or one argument
379 * Return
380 * a deferred object
381 * Create a deferred object with watch task and connect it to the given deferred object.
382 * The watch task CALLBACK can not affect deferred chains with return values.
383 * This function is used in following purposes, simulation of try-finally block in asynchronous tasks, monitoring of progress of deferred tasks.
384
385 * deferred:wait (msec)
386 * Arguments
387 * msec: a number (millisecond)
388 * Return
389 * a deferred object
390 * Return a deferred object that will be called after the specified millisecond.
391 * The subsequent deferred task receives the actual elapse time in millisecond.
392
393 * deferred:$
394 * Arguments / more than one deferred forms
395 * Return / the last deferred object
396 * An anaphoric macro chains deferred objects.
397 * The anaphoric variable `it` holds a deferred object in the previous line.
398
399 #### Utility functions ####
400
401 * deferred:loop (number-or-list callback)
402 * Arguments
403 * number-or-list: an integer or a list
404 * callback: a function with zero or one argument
405 * Return
406 * a deferred object
407 * Return a deferred object that iterates the function for the specified times.
408 * The function receives the count number that begins zero.
409 * If a list is given, not a number, the function visits each elements in the list like `mapc`.
410
411 * deferred:parallel (list-or-alist)
412 * Arguments
413 * list-or-alist:
414 * more than one deferred objects or a list of functions
415 * an alist consist of cons cells with a symbol and a deferred object or a function
416 * Return
417 * a deferred object
418 * Return a deferred object that executes given functions in parallel and wait for all callback values.
419 * The subsequent deferred task receives a list of the results. The order of the results is corresponding to one of the argument.
420 * Giving an alist of tasks as the argument, the results alist is returned.
421 * If the parallel task throws an error, the error object is passed as a result.
422
423 * deferred:earlier (list-or-alist)
424 * Arguments
425 * list-or-alist:
426 * more than one deferred objects or a list of functions
427 * an alist consist of cons cells with a symbol and a deferred object or a function
428 * Return
429 * a deferred object
430 * Return a deferred object that executes given functions in parallel and wait for the first callback value.
431 * The other tasks are rejected. (See the document for `deferred:cancel`)
432 * Giving an alist of tasks as the argument, a cons cell is returned as a result.
433 * When a task finishes abnormally, the task is ignored.
434 * When all tasks finishes abnormally, the next task receives nil. That is, no errorback function is called.
435
436 #### Wrapper functions ####
437
438 * deferred:call (function args...)
439 * Arguments
440 * function: a function
441 * args: arguments (variable length)
442 * Return
443 * a deferred object
444 * a wrapper of the function `funcall`
445
446 * deferred:apply (function args)
447 * Arguments
448 * function: a function
449 * args: a list of arguments
450 * Return
451 * a deferred object
452 * a wrapper of the function `apply`
453
454 * deferred:process (command args...) / deferred:process-shell (command args...)
455 * Arguments
456 * command: command to execute
457 * args: command arguments (variable length)
458 * Return
459 * a deferred object
460 * Execute a command asynchronously. These functions are wrappers of `start-process` and `start-process-shell-command`.
461 * The subsequent deferred task receives the stdout from the command as a string.
462
463 * deferred:process-buffer (command args...) / deferred:process-shell-buffer (command args...)
464 * Arguments
465 * command: command to execute
466 * args: command arguments (variable length)
467 * Return
468 * a deferred object
469 * Execute a command asynchronously. These functions are wrappers of `start-process` and `start-process-shell-command`.
470 * The subsequent deferred task receives the stdout from the command as a buffer.
471 * The following tasks are responsible to kill the buffer.
472
473 * deferred:wait-idle (msec)
474 * Arguments
475 * msec: a number (millisecond)
476 * Return
477 * a deferred object
478 * Return a deferred object that will be called when Emacs has been idle for the specified millisecond.
479 * The subsequent deferred task receives the elapse time in millisecond.
480
481 * deferred:url-retrieve (url [cbargs])
482 * Arguments
483 * url: URL to get
484 * cbargs: callback argument (optional)
485 * Return
486 * a deferred object
487 * A wrapper function of `url-retrieve` in the `url` package.
488 * The subsequent deferred task receives the content as a buffer.
489 * The following tasks are responsible to kill the buffer.
490
491 * [experimental] deferred:url-get (url [params])
492 * Arguments
493 * url: URL to get
494 * params: alist of parameters
495 * Return
496 * a deferred object
497
498 * [experimental] deferred:url-post (url [params])
499 * Arguments
500 * url: URL to get
501 * params: alist of parameters
502 * Return
503 * a deferred object
504
505 #### Primitive functions ####
506
507 * deferred:new ([callback])
508 * Arguments
509 * callback: a function with zero or one argument (optional)
510 * Return
511 * a deferred object
512 * Create a deferred object
513 * The created deferred object is never called until someone call the function `deferred:callback` or `deferred:errorback`.
514 * Using this object, a deferred chain can pause to wait for other events. (See the source for `deferred:wait`.)
515
516 * deferred:succeed ([value])
517 * Arguments
518 * value: a value (optional)
519 * Return
520 * a deferred object
521 * Create a deferred object that has been called the callback function.
522 * When a deferred task is connected, the subsequent task will be executed immediately (synchronously).
523
524 * deferred:fail ([error])
525 * Arguments
526 * error: an error value (optional)
527 * Return
528 * a deferred object
529 * Create a deferred object that has been called the errorback function.
530 * When a deferred task is connected, the subsequent task will be executed immediately (synchronously).
531
532 * deferred:callback (d [value])
533 * Arguments
534 * d: a deferred object
535 * value: a value (optional)
536 * Return
537 * a deferred object or a result value
538 * Start executing the deferred tasks. The first task is executed synchronously.
539
540 * deferred:callback-post (d [value])
541 * Arguments
542 * d: a deferred object
543 * value: a value (optional)
544 * Return
545 * a deferred object or a result value
546 * Start executing the deferred tasks. The first task is executed asynchronously.
547
548 * deferred:errorback (d [error])
549 * Arguments
550 * d: a deferred object
551 * error: an error value (optional)
552 * Return
553 * a deferred object or a result value
554 * Start executing the deferred tasks from errorback. The first task is executed synchronously.
555
556 * deferred:errorback-post (d [error])
557 * Arguments
558 * d: a deferred object
559 * error: an error value (optional)
560 * Return
561 * a deferred object or a result value
562 * Start executing the deferred tasks from errorback. The first task is executed asynchronously.
563
564 ### Utility Macros ###
565
566 * deferred:try (d &key catch finally)
567 * Arguments
568 * d: deferred object
569 * catch: [keyword argument] A function that is called when an error is occurred during tasks `d`. (This function is expanded as an argument of `deferred:error`.)
570 * finally: [keyword argument] A function that is called when tasks `d` finishes whether in success or failure. (This function is expanded as an argument of deferred:watch.)
571 * Return
572 * a deferred object
573 * Try-catch-finally macro. This macro simulates the try-catch-finally block asynchronously.
574 * Because of asynchrony, this macro does not ensure that the `finally` task should be called.
575 * This macro is implemented by `deferred:error` and `deferred:watch`.
576
577 * deferred:timeout (msec timeout-form d)
578 * Arguments
579 * msec: a number
580 * timeout-form: sexp-form
581 * d: a deferred object
582 * Return
583 * a deferred object
584 * Time out macro on a deferred task `d`.
585 * If the deferred task `d` does not complete within `timeout-msec`, this macro rejects the deferred task and return the `timeout-form`. (See the document for `deferred:cancel`)
586 * This macro is implemented by `deferred:earlier` and `deferred:wait`.
587
588 * deferred:process...
589 * deferred:processc (d command args...)
590 * deferred:process-bufferc (d command args...)
591 * deferred:process-shellc (d command args...)
592 * deferred:process-shell-bufferc (d command args...)
593 * Arguments
594 * d: a deferred object
595 * command: command to execute
596 * args: command arguments (variable length)
597 * Return
598 * a deferred object
599 * This macro wraps the deferred:process function in deferred:nextc and connect the given deferred task.
600
601 ### Execution and Connection ###
602
603 #### Firing ####
604
605 Some deferred functions can fire a deferred chain implicitly. Following functions register a deferred object with the execution queue to run asynchronously.
606
607 * next
608 * wait
609 * loop
610 * parallel
611 * earlier
612 * call, apply
613 * process
614 * url-retrieve, url-get, url-post
615
616
617 The deferred tasks those are created by `deferred:new` are never called. Using this object, a deferred chain can pause to wait for other events. (See the source for `deferred:wait`.)
618
619
620 One can fire the chain before connecting. That is, deferred objects wait for connecting the subsequent task holding the result value. The functions `deferred:succeed` and `deferred:fail` create those waiting objects.
621
622 #### Static connection ####
623
624 The `static connection (statically connected)` is a connection between deferred tasks on the source code.
625 This is a basic usage for the deferred chain.
626
627 The static connection is almost equivalent to ordinary callback notation as an argument in the function declarations. The deferred notation is easy to read and write better than the callback one, because the sequence of asynchronous tasks can be written by the deferred notation straightforward.
628
629 #### Dynamic Connection ####
630
631 Returning a deferred object in the deferred tasks, the returned task is executed before the next deferred one that is statically connected on the source code. This is the `dynamic connection (dynamically connected)`.
632
633 Employing a recursive structure of deferred tasks, you can construct higher level control structures, such as loop.
634
635 ## Discussion ##
636
637 Some discussions of writing deferred codes.
638
639 ### Using lexical scope ###
640
641 Using the lexical scope macro, such as `lexical-let`, the deferred tasks defined by lambdas can access local variables.
642
643 `lexical-let` Ex.:
644
645 ```el
646 (lexical-let ((a (point)))
647 (deferred:$
648 (deferred:wait 1000)
649 (deferred:nextc it
650 (lambda (x)
651 (goto-char a)
652 (insert "here!")))))
653 ```
654
655 If you write a code of deferred tasks without lexical scope macros, you should be careful with the scopes of each variables.
656
657 ### Excursion (Current status) ###
658
659 The `excursion` functions those hold the current status with the s-exp form, such as `save-execursion` or `with-current-buffer`, are not valid in the deferred tasks, because of execution asynchronously.
660
661 Wrong Ex.:
662
663 ```el
664 (with-current-buffer (get-buffer "*Message*")
665 (deferred:$
666 (deferred:wait 1000)
667 (deferred:nextc it
668 (lambda (x)
669 (insert "Time: %s " x) ; `insert` may not be in the *Message* buffer!
670 ))))
671 ```
672
673 In this case, using lexical scope macros to access the buffer variable, you can change the buffer in the deferred task.
674
675 Corrected:
676
677 ```el
678 (lexical-let ((buf (get-buffer "*Message*")))
679 (deferred:$
680 (deferred:wait 1000)
681 (deferred:nextc it
682 (lambda (x)
683 (with-current-buffer buf ; Set buffer in the asynchronous task.
684 (insert "Time: %s " x))))))
685 ```
686
687
688 ### Be aware of return values ###
689
690 However the dynamic connection is a powerful feature, sometimes it causes bugs of the wrong execution order, because of returning not intended deferred objects.
691
692 Then, you should watch the return values of the deferred tasks not to cause an unexpected dynamic connection.
693
694 ### Debugging ###
695
696 The debugging of asynchronous tasks is difficult. Of course, you can use debugger for deferred tasks, but asynchronous tasks cause some troubles, such as interruptions of your debugging and timing gap of simultaneous deferred tasks. Therefore, logging is a safe debugging to observe the tasks correctly, for example, using the `message` function and making custom application log buffer.
697
698 If deferred tasks fall into an infinite loop unexpectedly (but Emacs may not freeze), calling the command `deferred:clear-queue`, you can stop the deferred tasks immediately.
699
700 If the errors occurred in deferred tasks are caught by no errorback functions, finally the deferred framework catches it and reports to the message buffer. Because the implementation of the framework uses a `condition-case` form, the debugger can not catch the signals normally. If you want to debug the errors in the deferred tasks with the debug-on-error mechanism, set the variable `deferred:debug-on-signal` non-nil.
701
702 Wrapping a deferred task in the function `deferred:sync!`, you can wait for the result of the task synchronously. However, the wrapper function should be used for test or debug purpose, because the synchronous waiting is not exact.
703
704 ### Using macros ###
705
706 Writing deferred tasks with `deferred.el`, you may write a lot of `deferred:nextc` and `lambda` to define tasks. Defining a macro, you may write codes shortly. The test code `test-deferred.el` uses many macros to shorten test codes.
707
708 On the other hand, using macros to hide `lambda`, it is difficult to realize when the deferred codes are evaluated. That is why `deferred.el` does not provide lot of convenient macros. If you use macros, be careful evaluation timing of deferred forms.
709
710 ### Introduction for deferred ###
711
712 Following documents are good introduction to deferred.
713
714 * [Introduction to JSDeferred](http://cho45.stfuawsc.com/jsdeferred/doc/intro.en.html "Introduction to JSDeferred")
715 * [JSDeferred site](http://cho45.stfuawsc.com/jsdeferred/ "JSDeferred site")
716
717 * * * * *
718
719 (C) 2010-2016 SAKURAI Masashi All rights reserved.
720 m.sakurai at kiwanami.net
+506
-0
concurrent.el less more
0 ;;; concurrent.el --- Concurrent utility functions for emacs lisp
1
2 ;; Copyright (C) 2010-2016 SAKURAI Masashi
3
4 ;; Author: SAKURAI Masashi <m.sakurai at kiwanami.net>
5 ;; Version: 0.4.0
6 ;; Keywords: deferred, async, concurrent
7 ;; Package-Requires: ((deferred "0.4.0"))
8 ;; URL: https://github.com/kiwanami/emacs-deferred/blob/master/README-concurrent.markdown
9
10 ;; This program is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
14
15 ;; This program is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU 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 ;; 'concurrent.el' is a higher level library for concurrent tasks
26 ;; based on 'deferred.el'. This library has following features:
27 ;;
28 ;; - Generator
29 ;; - Green thread
30 ;; - Semaphore
31 ;; - Dataflow
32 ;; - Signal/Channel
33
34 (require 'cl)
35
36 (require 'deferred)
37
38 (defvar cc:version nil "version number")
39 (setq cc:version "0.3")
40
41 ;;; Code:
42
43
44
45 (defmacro cc:aif (test-form then-form &rest else-forms)
46 (declare (debug (form form &rest form)))
47 `(let ((it ,test-form))
48 (if it ,then-form ,@else-forms)))
49 (put 'cc:aif 'lisp-indent-function 2)
50
51 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
52 ;; Generator
53
54 (defun cc:generator-replace-yield (tree)
55 "[internal] Replace `yield' symbols to calling a function in TREE."
56 (let (ret)
57 (loop for i in tree
58 do (cond
59 ((eq i 'yield)
60 (push 'funcall ret)
61 (push i ret))
62 ((listp i)
63 (push (cc:generator-replace-yield i) ret))
64 (t
65 (push i ret))))
66 (nreverse ret)))
67
68 (defun cc:generator-line (chain line)
69 "[internal] Return a macro expansion to execute the sexp LINE
70 asynchronously."
71 (cond
72 ;; function object
73 ((functionp line)
74 `(setq ,chain (deferred:nextc ,chain ,line)))
75 ;; while loop form
76 ((eq 'while (car line))
77 (let ((condition (cadr line))
78 (body (cddr line)))
79 `(setq ,chain
80 (deferred:nextc ,chain
81 (deferred:lambda (x)
82 (if ,condition
83 (deferred:nextc
84 (progn
85 ,@(cc:generator-replace-yield body)) self)))))))
86 ;; statement
87 (t
88 `(setq ,chain
89 (deferred:nextc ,chain
90 (deferred:lambda (x) ,(cc:generator-replace-yield line)))))))
91
92 (defmacro cc:generator (callback &rest body)
93 "Create a generator object. If BODY has `yield' symbols, it
94 means calling callback function CALLBACK."
95 (let ((chain (gensym))
96 (cc (gensym))
97 (waiter (gensym)))
98 `(lexical-let*
99 (,chain
100 (,cc ,callback)
101 (,waiter (deferred:new))
102 (yield (lambda (x) (funcall ,cc x) ,waiter)))
103 (setq ,chain ,waiter)
104 ,@(loop for i in body
105 collect
106 (cc:generator-line chain i))
107 (lambda () (deferred:callback ,waiter)))))
108
109
110
111 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
112 ;; Thread
113
114 (defun cc:thread-line (wait-time chain line)
115 "[internal] Return a macro expansion to execute the sexp LINE asynchronously.
116 WAIT-TIME is an interval time between tasks.
117 CHAIN is the previous deferred task."
118 (cond
119 ;; function object
120 ((functionp line)
121 `(setq ,chain (deferred:nextc ,chain ,line)))
122 ;; while loop form
123 ((eq 'while (car line))
124 (let ((condition (cadr line))
125 (body (cddr line))
126 (retsym (gensym)))
127 `(setq ,chain
128 (deferred:nextc ,chain
129 (deferred:lambda (x)
130 (if ,condition
131 (deferred:nextc
132 (let ((,retsym (progn ,@body)))
133 (if (deferred-p ,retsym) ,retsym
134 (deferred:wait ,wait-time)))
135 self)))))))
136 ;; statement
137 (t
138 `(setq ,chain
139 (deferred:nextc ,chain
140 (lambda (x) ,line))))))
141
142 (defmacro cc:thread (wait-time-msec &rest body)
143 "Return a thread object."
144 (let ((chain (gensym))
145 (dstart (gensym)))
146 `(lexical-let*
147 (,chain
148 (,dstart (deferred:new)))
149 (setq ,chain ,dstart)
150 ,@(loop for i in body
151 collect
152 (cc:thread-line wait-time-msec chain i))
153 (deferred:callback ,dstart))))
154 (put 'cc:thread 'lisp-indent-function 1)
155
156
157
158 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
159 ;; Semaphore
160
161 (defstruct cc:semaphore max-permits permits waiting-deferreds)
162
163 (defun cc:semaphore-create(permits-num)
164 "Return a semaphore object with PERMITS-NUM permissions."
165 (make-cc:semaphore :max-permits permits-num :permits permits-num))
166
167 (defun cc:semaphore-acquire(semaphore)
168 "Acquire an execution permission and return deferred object to chain.
169 If this semaphore object has permissions, the subsequent deferred
170 task is executed immediately. If this semaphore object has no
171 permissions, the subsequent deferred task is blocked. After the
172 permission is returned, the task is executed."
173 (cond
174 ((< 0 (cc:semaphore-permits semaphore))
175 (decf (cc:semaphore-permits semaphore))
176 (deferred:succeed))
177 (t
178 (let ((d (deferred:new)))
179 (push d (cc:semaphore-waiting-deferreds semaphore))
180 d))))
181
182 (defun cc:semaphore-release(semaphore)
183 "Release an execution permission. The programmer is responsible to return the permissions."
184 (when (<= (cc:semaphore-max-permits semaphore)
185 (cc:semaphore-permits semaphore))
186 (error "Too many calling semaphore-release. [max:%s <= permits:%s]"
187 (cc:semaphore-max-permits semaphore)
188 (cc:semaphore-permits semaphore)))
189 (let ((waiting-deferreds
190 (cc:semaphore-waiting-deferreds semaphore)))
191 (cond
192 (waiting-deferreds
193 (let* ((d (car (last waiting-deferreds))))
194 (setf (cc:semaphore-waiting-deferreds semaphore)
195 (nbutlast waiting-deferreds))
196 (deferred:callback-post d)))
197 (t
198 (incf (cc:semaphore-permits semaphore)))))
199 semaphore)
200
201 (defun cc:semaphore-with (semaphore body-func &optional error-func)
202 "Execute the task BODY-FUNC asynchronously with the semaphore block."
203 (lexical-let ((semaphore semaphore))
204 (deferred:try
205 (deferred:nextc (cc:semaphore-acquire semaphore) body-func)
206 :catch
207 error-func
208 :finally
209 (lambda (_x) (cc:semaphore-release semaphore)))))
210 (put 'cc:semaphore-with 'lisp-indent-function 1)
211
212 (defun cc:semaphore-release-all (semaphore)
213 "Release all permissions for resetting the semaphore object.
214 If the semaphore object has some blocked tasks, this function
215 return a list of the tasks and clear the list of the blocked
216 tasks in the semaphore object."
217 (setf (cc:semaphore-permits semaphore)
218 (cc:semaphore-max-permits semaphore))
219 (let ((ds (cc:semaphore-waiting-deferreds semaphore)))
220 (when ds
221 (setf (cc:semaphore-waiting-deferreds semaphore) nil))
222 ds))
223
224 (defun cc:semaphore-interrupt-all (semaphore)
225 "Clear the list of the blocked tasks in the semaphore and return a deferred object to chain.
226 This function is used for the interruption cases."
227 (when (cc:semaphore-waiting-deferreds semaphore)
228 (setf (cc:semaphore-waiting-deferreds semaphore) nil)
229 (setf (cc:semaphore-permits semaphore) 0))
230 (cc:semaphore-acquire semaphore))
231
232
233
234 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
235 ;; Signal / Channel
236
237 (defun cc:signal-channel (&optional name parent-channel)
238 "Create a channel.
239 NAME is a channel name for debug.
240 PARENT-CHANNEL is an upstream channel. The observers of this channel can receive the upstream signals.
241 In the case of using the function `cc:signal-send', the observers of the upstream channel can not receive the signals of this channel. The function `cc:signal-send-global' can send a signal to the upstream channels from the downstream channels."
242 (lexical-let
243 ((ch (cons
244 (or name (format "signal%s" (deferred:uid))) ; name for debug
245 (cons
246 parent-channel ; parent-channel
247 nil)))) ; observers
248 (when parent-channel
249 (cc:signal-connect
250 parent-channel
251 t (lambda (event)
252 (destructuring-bind
253 (event-name event-args) event
254 (apply 'cc:signal-send
255 ch event-name event-args)))))
256 ch))
257
258 (defmacro cc:signal-name (ch)
259 "[internal] Return signal name."
260 `(car ,ch))
261
262 (defmacro cc:signal-parent-channel (ch)
263 "[internal] Return parent channel object."
264 `(cadr ,ch))
265
266 (defmacro cc:signal-observers (ch)
267 "[internal] Return observers."
268 `(cddr ,ch))
269
270 (defun cc:signal-connect (channel event-sym &optional callback)
271 "Append an observer for EVENT-SYM of CHANNEL and return a deferred object.
272 If EVENT-SYM is `t', the observer receives all signals of the channel.
273 If CALLBACK function is given, the deferred object executes the
274 CALLBACK function asynchronously. One can connect subsequent
275 tasks to the returned deferred object."
276 (let ((d (if callback
277 (deferred:new callback)
278 (deferred:new))))
279 (push (cons event-sym d)
280 (cc:signal-observers channel))
281 d))
282
283 (defun cc:signal-send (channel event-sym &rest args)
284 "Send a signal to CHANNEL. If ARGS values are given, observers can get the values by following code: (lambda (event) (destructuring-bind (event-sym (args)) event ... )). "
285 (let ((observers (cc:signal-observers channel))
286 (event (list event-sym args)))
287 (loop for i in observers
288 for name = (car i)
289 for d = (cdr i)
290 if (or (eq event-sym name) (eq t name))
291 do (deferred:callback-post d event))))
292
293 (defun cc:signal-send-global (channel event-sym &rest args)
294 "Send a signal to the most upstream channel. "
295 (cc:aif (cc:signal-parent-channel channel)
296 (apply 'cc:signal-send-global it event-sym args)
297 (apply 'cc:signal-send channel event-sym args)))
298
299
300 (defun cc:signal-disconnect (channel deferred)
301 "Remove the observer object DEFERRED from CHANNEL and return
302 the removed deferred object. "
303 (let ((observers (cc:signal-observers channel)) deleted)
304 (setf
305 (cc:signal-observers channel) ; place
306 (loop for i in observers
307 for d = (cdr i)
308 unless (eq d deferred)
309 collect i
310 else
311 do (push i deleted)))
312 deleted))
313
314 (defun cc:signal-disconnect-all (channel)
315 "Remove all observers."
316 (setf
317 (cc:signal-observers channel) ; place
318 nil))
319
320
321
322
323 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
324 ;; Dataflow
325
326 ;; Dataflow variable entry
327 (defstruct cc:dataflow key (value 'cc:dataflow-undefine) deferred-list)
328
329 (defun cc:dataflow-undefine-p (obj)
330 "[internal] If the variable entry is not bound, return `t'."
331 (eq 'cc:dataflow-undefine (cc:dataflow-value obj)))
332
333 (defmacro cc:dataflow-parent-environment (df)
334 "[internal] Return the parent environment."
335 `(car ,df))
336
337 (defmacro cc:dataflow-test (df)
338 "[internal] Return the test function."
339 `(cadr ,df))
340
341 (defmacro cc:dataflow-channel (df)
342 "[internal] Return the channel object."
343 `(caddr ,df))
344
345 (defmacro cc:dataflow-list (df)
346 "[internal] Return the list of deferred object which are waiting for value binding."
347 `(cdddr ,df))
348
349 (defun cc:dataflow-environment (&optional parent-env test-func channel)
350 "Create a dataflow environment.
351 PARENT-ENV is the default environment. If this environment doesn't have the entry A and the parent one has the entry A, this environment can return the entry A. One can override the entry, setting another entry A to this environment.
352 TEST-FUNC is a test function that compares the entry keys. The default function is `equal'.
353 CHANNEL is a channel object that sends signals of variable events. Observers can receive following signals:
354 -get-first : the fist referrer is waiting for binding,
355 -get-waiting : another referrer is waiting for binding,
356 -set : a value is bound,
357 -get : returned a bound value,
358 -clear : cleared one entry,
359 -clear-all : cleared all entries.
360 "
361 (let ((this (list parent-env
362 (or test-func 'equal)
363 (or channel
364 (cc:signal-channel
365 'dataflow
366 (and parent-env
367 (cc:dataflow-channel parent-env)))))))
368 (cc:dataflow-init-connect this)
369 this))
370
371 (defun cc:dataflow-init-connect (df)
372 "[internal] Initialize the channel object."
373 (lexical-let ((df df))
374 (cc:dataflow-connect
375 df 'set
376 (lambda (args)
377 (destructuring-bind (_event (key)) args
378 (let* ((obj (cc:dataflow-get-object-for-value df key))
379 (value (and obj (cc:dataflow-value obj))))
380 (when obj
381 (loop for i in (cc:aif (cc:dataflow-get-object-for-deferreds df key)
382 (cc:dataflow-deferred-list it) nil)
383 do (deferred:callback-post i value))
384 (setf (cc:dataflow-deferred-list obj) nil))))))))
385
386 (defun cc:dataflow-get-object-for-value (df key)
387 "[internal] Return an entry object that is indicated by KEY.
388 If the environment DF doesn't have the entry and the parent one has the entry, this function returns the entry of the parent environment. This function doesn't affect the waiting list."
389 (or
390 (loop for i in (cc:dataflow-list df)
391 with test = (cc:dataflow-test df)
392 if (and (funcall test key (cc:dataflow-key i))
393 (not (cc:dataflow-undefine-p i)))
394 return i)
395 (deferred:aand
396 (cc:dataflow-parent-environment df)
397 (cc:dataflow-get-object-for-value it key))))
398
399 (defun cc:dataflow-get-object-for-deferreds (df key)
400 "[internal] Return a list of the deferred objects those are waiting for value binding.
401 This function doesn't affect the waiting list and doesn't refer the parent environment."
402 (loop for i in (cc:dataflow-list df)
403 with test = (cc:dataflow-test df)
404 if (funcall test key (cc:dataflow-key i))
405 return i))
406
407 (defun cc:dataflow-connect (df event-sym &optional callback)
408 "Append an observer for EVENT-SYM of the channel of DF and return a deferred object.
409 See the docstring of `cc:dataflow-environment' for details."
410 (cc:signal-connect (cc:dataflow-channel df) event-sym callback))
411
412 (defun cc:dataflow-signal (df event &optional arg)
413 "[internal] Send a signal to the channel of DF."
414 (cc:signal-send (cc:dataflow-channel df) event arg))
415
416 (defun cc:dataflow-get (df key)
417 "Return a deferred object that can refer the value which is indicated by KEY.
418 If DF has the entry that bound value, the subsequent deferred task is executed immediately.
419 If not, the task is deferred till a value is bound."
420 (let ((obj (cc:dataflow-get-object-for-value df key)))
421 (cond
422 ((and obj (cc:dataflow-value obj))
423 (cc:dataflow-signal df 'get key)
424 (deferred:succeed (cc:dataflow-value obj)))
425 (t
426 (setq obj (cc:dataflow-get-object-for-deferreds df key))
427 (unless obj
428 (setq obj (make-cc:dataflow :key key))
429 (push obj (cc:dataflow-list df))
430 (cc:dataflow-signal df 'get-first key))
431 (let ((d (deferred:new)))
432 (push d (cc:dataflow-deferred-list obj))
433 (cc:dataflow-signal df 'get-waiting key)
434 d)))))
435
436 (defun cc:dataflow-get-sync (df key)
437 "Return the value which is indicated by KEY synchronously.
438 If the environment DF doesn't have an entry of KEY, this function returns nil."
439 (let ((obj (cc:dataflow-get-object-for-value df key)))
440 (and obj (cc:dataflow-value obj))))
441
442 (defun cc:dataflow-set (df key value)
443 "Bind the VALUE to KEY in the environment DF.
444 If DF already has the bound entry of KEY, this function throws an error signal.
445 VALUE can be nil as a value."
446 (let ((obj (cc:dataflow-get-object-for-deferreds df key)))
447 (cond
448 ((and obj (not (cc:dataflow-undefine-p obj)))
449 ;; overwrite!
450 (error "Can not set a dataflow value. The key [%s] has already had a value. NEW:[%s] OLD:[%s]" key value (cc:dataflow-value obj)))
451 (obj
452 (setf (cc:dataflow-value obj) value))
453 (t
454 ;; just value arrived
455 (push (make-cc:dataflow :key key :value value)
456 (cc:dataflow-list df))))
457 ;; value arrived and start deferred objects
458 (cc:dataflow-signal df 'set key)
459 value))
460
461 (defun cc:dataflow-clear (df key)
462 "Clear the entry which is indicated by KEY.
463 This function does nothing for the waiting deferred objects."
464 (cc:dataflow-signal df 'clear key)
465 (setf (cc:dataflow-list df)
466 (loop for i in (cc:dataflow-list df)
467 with test = (cc:dataflow-test df)
468 unless (funcall test key (cc:dataflow-key i))
469 collect i)))
470
471 (defun cc:dataflow-get-avalable-pairs (df)
472 "Return an available key-value alist in the environment DF and the parent ones."
473 (append
474 (loop for i in (cc:dataflow-list df)
475 for key = (cc:dataflow-key i)
476 for val = (cc:dataflow-value i)
477 unless (cc:dataflow-undefine-p i) collect (cons key val))
478 (deferred:aand
479 (cc:dataflow-parent-environment df)
480 (cc:dataflow-get-avalable-pairs it))))
481
482 (defun cc:dataflow-get-waiting-keys (df)
483 "Return a list of keys which have waiting deferred objects in the environment DF and the parent ones."
484 (append
485 (loop for i in (cc:dataflow-list df)
486 for key = (cc:dataflow-key i)
487 if (cc:dataflow-undefine-p i) collect key)
488 (deferred:aand
489 (cc:dataflow-parent-environment df)
490 (cc:dataflow-get-waiting-keys it))))
491
492 (defun cc:dataflow-clear-all (df)
493 "Clear all entries in the environment DF.
494 This function does nothing for the waiting deferred objects."
495 (cc:dataflow-signal df 'clear-all)
496 (setf (cc:dataflow-list df) nil))
497
498
499 (provide 'concurrent)
500
501 ;; Local Variables:
502 ;; byte-compile-warnings: (not cl-functions)
503 ;; End:
504
505 ;;; concurrent.el ends here
+963
-0
deferred.el less more
0 ;;; deferred.el --- Simple asynchronous functions for emacs lisp
1
2 ;; Copyright (C) 2010-2016 SAKURAI Masashi
3
4 ;; Author: SAKURAI Masashi <m.sakurai at kiwanami.net>
5 ;; Version: 0.4.0
6 ;; Keywords: deferred, async
7 ;; URL: https://github.com/kiwanami/emacs-deferred
8
9 ;; This program is free software; you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation, either version 3 of the License, or
12 ;; (at your option) any later version.
13
14 ;; This program is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
18
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
21
22 ;;; Commentary:
23
24 ;; 'deferred.el' is a simple library for asynchronous tasks.
25 ;; [https://github.com/kiwanami/emacs-deferred]
26
27 ;; The API is almost the same as JSDeferred written by cho45. See the
28 ;; JSDeferred and Mochikit.Async web sites for further documentations.
29 ;; [https://github.com/cho45/jsdeferred]
30 ;; [http://mochikit.com/doc/html/MochiKit/Async.html]
31
32 ;; A good introduction document (JavaScript)
33 ;; [http://cho45.stfuawsc.com/jsdeferred/doc/intro.en.html]
34
35 ;;; Samples:
36
37 ;; ** HTTP Access
38
39 ;; (require 'url)
40 ;; (deferred:$
41 ;; (deferred:url-retrieve "http://www.gnu.org")
42 ;; (deferred:nextc it
43 ;; (lambda (buf)
44 ;; (insert (with-current-buffer buf (buffer-string)))
45 ;; (kill-buffer buf))))
46
47 ;; ** Invoking command tasks
48
49 ;; (deferred:$
50 ;; (deferred:process "wget" "-O" "a.jpg" "http://www.gnu.org/software/emacs/tour/images/splash.png")
51 ;; (deferred:nextc it
52 ;; (lambda (x) (deferred:process "convert" "a.jpg" "-resize" "100x100" "jpg:b.jpg")))
53 ;; (deferred:nextc it
54 ;; (lambda (x)
55 ;; (insert-image (create-image (expand-file-name "b.jpg") 'jpeg nil)))))
56
57 ;; See the readme for further API documentation.
58
59 ;; ** Applications
60
61 ;; *Inertial scrolling for Emacs
62 ;; [https://github.com/kiwanami/emacs-inertial-scroll]
63
64 ;; This program makes simple multi-thread function, using
65 ;; deferred.el.
66
67 (require 'cl)
68
69 (declare-function pp-display-expression 'pp)
70
71 (defvar deferred:version nil "deferred.el version")
72 (setq deferred:version "0.4.0")
73
74 ;;; Code:
75
76 (defmacro deferred:aand (test &rest rest)
77 "[internal] Anaphoric AND."
78 (declare (debug ("test" form &rest form)))
79 `(let ((it ,test))
80 (if it ,(if rest `(deferred:aand ,@rest) 'it))))
81
82 (defmacro deferred:$ (&rest elements)
83 "Anaphoric function chain macro for deferred chains."
84 (declare (debug (&rest form)))
85 `(let (it)
86 ,@(loop for i in elements
87 collect
88 `(setq it ,i))
89 it))
90
91 (defmacro deferred:lambda (args &rest body)
92 "Anaphoric lambda macro for self recursion."
93 (declare (debug ("args" form &rest form)))
94 (let ((argsyms (loop repeat (length args) collect (gensym))))
95 `(lambda (,@argsyms)
96 (lexical-let (self)
97 (setq self (lambda( ,@args ) ,@body))
98 (funcall self ,@argsyms)))))
99
100 (defmacro* deferred:try (d &key catch finally)
101 "Try-catch-finally macro. This macro simulates the
102 try-catch-finally block asynchronously. CATCH and FINALLY can be
103 nil. Because of asynchrony, this macro does not ensure that the
104 task FINALLY should be called."
105 (let ((chain
106 (if catch `((deferred:error it ,catch)))))
107 (when finally
108 (setq chain (append chain `((deferred:watch it ,finally)))))
109 `(deferred:$ ,d ,@chain)))
110
111 (defun deferred:setTimeout (f msec)
112 "[internal] Timer function that emulates the `setTimeout' function in JS."
113 (run-at-time (/ msec 1000.0) nil f))
114
115 (defun deferred:cancelTimeout (id)
116 "[internal] Timer cancellation function that emulates the `cancelTimeout' function in JS."
117 (cancel-timer id))
118
119 (defun deferred:run-with-idle-timer (sec f)
120 "[internal] Wrapper function for run-with-idle-timer."
121 (run-with-idle-timer sec nil f))
122
123 (defun deferred:call-lambda (f &optional arg)
124 "[internal] Call a function with one or zero argument safely.
125 The lambda function can define with zero and one argument."
126 (condition-case err
127 (funcall f arg)
128 ('wrong-number-of-arguments
129 (display-warning 'deferred "\
130 Callback that takes no argument may be specified.
131 Passing callback with no argument is deprecated.
132 Callback must take one argument.
133 Or, this error is coming from somewhere inside of the callback: %S" err)
134 (condition-case nil
135 (funcall f)
136 ('wrong-number-of-arguments
137 (signal 'wrong-number-of-arguments (cdr err))))))) ; return the first error
138
139 ;; debug
140
141 (eval-and-compile
142 (defvar deferred:debug nil "Debug output switch."))
143 (defvar deferred:debug-count 0 "[internal] Debug output counter.")
144
145 (defmacro deferred:message (&rest args)
146 "[internal] Debug log function."
147 (when deferred:debug
148 `(progn
149 (with-current-buffer (get-buffer-create "*deferred:debug*")
150 (save-excursion
151 (goto-char (point-max))
152 (insert (format "%5i %s\n" deferred:debug-count (format ,@args)))))
153 (incf deferred:debug-count))))
154
155 (defun deferred:message-mark ()
156 "[internal] Debug log function."
157 (interactive)
158 (deferred:message "==================== mark ==== %s"
159 (format-time-string "%H:%M:%S" (current-time))))
160
161 (defun deferred:pp (d)
162 (require 'pp)
163 (deferred:$
164 (deferred:nextc d
165 (lambda (x)
166 (pp-display-expression x "*deferred:pp*")))
167 (deferred:error it
168 (lambda (e)
169 (pp-display-expression e "*deferred:pp*")))
170 (deferred:nextc it
171 (lambda (_x) (pop-to-buffer "*deferred:pp*")))))
172
173 (defvar deferred:debug-on-signal nil
174 "If non nil, the value `debug-on-signal' is substituted this
175 value in the `condition-case' form in deferred
176 implementations. Then, Emacs debugger can catch an error occurred
177 in the asynchronous tasks.")
178
179 (defmacro deferred:condition-case (var protected-form &rest handlers)
180 "[internal] Custom condition-case. See the comment for
181 `deferred:debug-on-signal'."
182 (declare (debug condition-case)
183 (indent 2))
184 `(let ((debug-on-signal
185 (or debug-on-signal deferred:debug-on-signal)))
186 (condition-case ,var
187 ,protected-form
188 ,@handlers)))
189
190
191
192 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
193 ;; Back end functions of deferred tasks
194
195 (defvar deferred:tick-time 0.001
196 "Waiting time between asynchronous tasks (second).
197 The shorter waiting time increases the load of Emacs. The end
198 user can tune this paramter. However, applications should not
199 modify it because the applications run on various environments.")
200
201 (defvar deferred:queue nil
202 "[internal] The execution queue of deferred objects.
203 See the functions `deferred:post-task' and `deferred:worker'.")
204
205 (defmacro deferred:pack (a b c)
206 `(cons ,a (cons ,b ,c)))
207
208 (defun deferred:schedule-worker ()
209 "[internal] Schedule consuming a deferred task in the execution queue."
210 (run-at-time deferred:tick-time nil 'deferred:worker))
211
212 (defun deferred:post-task (d which &optional arg)
213 "[internal] Add a deferred object to the execution queue
214 `deferred:queue' and schedule to execute.
215 D is a deferred object. WHICH is a symbol, `ok' or `ng'. ARG is
216 an argument value for execution of the deferred task."
217 (push (deferred:pack d which arg) deferred:queue)
218 (deferred:message "QUEUE-POST [%s]: %s"
219 (length deferred:queue) (deferred:pack d which arg))
220 (deferred:schedule-worker)
221 d)
222
223 (defun deferred:clear-queue ()
224 "Clear the execution queue. For test and debugging."
225 (interactive)
226 (deferred:message "QUEUE-CLEAR [%s -> 0]" (length deferred:queue))
227 (setq deferred:queue nil))
228
229 (defun deferred:worker ()
230 "[internal] Consume a deferred task.
231 Mainly this function is called by timer asynchronously."
232 (when deferred:queue
233 (let* ((pack (car (last deferred:queue)))
234 (d (car pack))
235 (which (cadr pack))
236 (arg (cddr pack)) value)
237 (setq deferred:queue (nbutlast deferred:queue))
238 (condition-case err
239 (setq value (deferred:exec-task d which arg))
240 (error
241 (deferred:message "ERROR : %s" err)
242 (message "deferred error : %s" err)))
243 value)))
244
245 (defun deferred:flush-queue! ()
246 "Call all deferred tasks synchronously. For test and debugging."
247 (let (value)
248 (while deferred:queue
249 (setq value (deferred:worker)))
250 value))
251
252 (defun deferred:sync! (d)
253 "Wait for the given deferred task. For test and debugging.
254 Error is raised if it is not processed within deferred chain D."
255 (progn
256 (lexical-let ((last-value 'deferred:undefined*)
257 uncaught-error)
258 (deferred:try
259 (deferred:nextc d
260 (lambda (x) (setq last-value x)))
261 :catch
262 (lambda (err) (setq uncaught-error err)))
263 (while (and (eq 'deferred:undefined* last-value)
264 (not uncaught-error))
265 (sit-for 0.05)
266 (sleep-for 0.05))
267 (when uncaught-error
268 (deferred:resignal uncaught-error))
269 last-value)))
270
271
272
273 ;; Struct: deferred
274 ;;
275 ;; callback : a callback function (default `deferred:default-callback')
276 ;; errorback : an errorback function (default `deferred:default-errorback')
277 ;; cancel : a canceling function (default `deferred:default-cancel')
278 ;; next : a next chained deferred object (default nil)
279 ;; status : if 'ok or 'ng, this deferred has a result (error) value. (default nil)
280 ;; value : saved value (default nil)
281 ;;
282 (defstruct deferred
283 (callback 'deferred:default-callback)
284 (errorback 'deferred:default-errorback)
285 (cancel 'deferred:default-cancel)
286 next status value)
287
288 (defun deferred:default-callback (i)
289 "[internal] Default callback function."
290 (identity i))
291
292 (defun deferred:default-errorback (err)
293 "[internal] Default errorback function."
294 (deferred:resignal err))
295
296 (defun deferred:resignal (err)
297 "[internal] Safely resignal ERR as an Emacs condition.
298
299 If ERR is a cons (ERROR-SYMBOL . DATA) where ERROR-SYMBOL has an
300 `error-conditions' property, it is re-signaled unchanged. If ERR
301 is a string, it is signaled as a generic error using `error'.
302 Otherwise, ERR is formatted into a string as if by `print' before
303 raising with `error'."
304 (cond ((and (listp err)
305 (symbolp (car err))
306 (get (car err) 'error-conditions))
307 (signal (car err) (cdr err)))
308 ((stringp err)
309 (error "%s" err))
310 (t
311 (error "%S" err))))
312
313 (defun deferred:default-cancel (d)
314 "[internal] Default canceling function."
315 (deferred:message "CANCEL : %s" d)
316 (setf (deferred-callback d) 'deferred:default-callback)
317 (setf (deferred-errorback d) 'deferred:default-errorback)
318 (setf (deferred-next d) nil)
319 d)
320
321 (defun deferred:exec-task (d which &optional arg)
322 "[internal] Executing deferred task. If the deferred object has
323 next deferred task or the return value is a deferred object, this
324 function adds the task to the execution queue.
325 D is a deferred object. WHICH is a symbol, `ok' or `ng'. ARG is
326 an argument value for execution of the deferred task."
327 (deferred:message "EXEC : %s / %s / %s" d which arg)
328 (when (null d) (error "deferred:exec-task was given a nil."))
329 (let ((callback (if (eq which 'ok)
330 (deferred-callback d)
331 (deferred-errorback d)))
332 (next-deferred (deferred-next d)))
333 (cond
334 (callback
335 (deferred:condition-case err
336 (let ((value (deferred:call-lambda callback arg)))
337 (cond
338 ((deferred-p value)
339 (deferred:message "WAIT NEST : %s" value)
340 (if next-deferred
341 (deferred:set-next value next-deferred)
342 value))
343 (t
344 (if next-deferred
345 (deferred:post-task next-deferred 'ok value)
346 (setf (deferred-status d) 'ok)
347 (setf (deferred-value d) value)
348 value))))
349 (error
350 (cond
351 (next-deferred
352 (deferred:post-task next-deferred 'ng err))
353 (deferred:onerror
354 (deferred:call-lambda deferred:onerror err))
355 (t
356 (deferred:message "ERROR : %S" err)
357 (message "deferred error : %S" err)
358 (setf (deferred-status d) 'ng)
359 (setf (deferred-value d) err)
360 err)))))
361 (t ; <= (null callback)
362 (cond
363 (next-deferred
364 (deferred:exec-task next-deferred which arg))
365 ((eq which 'ok) arg)
366 (t ; (eq which 'ng)
367 (deferred:resignal arg)))))))
368
369 (defun deferred:set-next (prev next)
370 "[internal] Connect deferred objects."
371 (setf (deferred-next prev) next)
372 (cond
373 ((eq 'ok (deferred-status prev))
374 (setf (deferred-status prev) nil)
375 (let ((ret (deferred:exec-task
376 next 'ok (deferred-value prev))))
377 (if (deferred-p ret) ret
378 next)))
379 ((eq 'ng (deferred-status prev))
380 (setf (deferred-status prev) nil)
381 (let ((ret (deferred:exec-task next 'ng (deferred-value prev))))
382 (if (deferred-p ret) ret
383 next)))
384 (t
385 next)))
386
387
388
389 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
390 ;; Basic functions for deferred objects
391
392 (defun deferred:new (&optional callback)
393 "Create a deferred object."
394 (if callback
395 (make-deferred :callback callback)
396 (make-deferred)))
397
398 (defun deferred:callback (d &optional arg)
399 "Start deferred chain with a callback message."
400 (deferred:exec-task d 'ok arg))
401
402 (defun deferred:errorback (d &optional arg)
403 "Start deferred chain with an errorback message."
404 (deferred:exec-task d 'ng arg))
405
406 (defun deferred:callback-post (d &optional arg)
407 "Add the deferred object to the execution queue."
408 (deferred:post-task d 'ok arg))
409
410 (defun deferred:errorback-post (d &optional arg)
411 "Add the deferred object to the execution queue."
412 (deferred:post-task d 'ng arg))
413
414 (defun deferred:cancel (d)
415 "Cancel all callbacks and deferred chain in the deferred object."
416 (deferred:message "CANCEL : %s" d)
417 (funcall (deferred-cancel d) d)
418 d)
419
420 (defun deferred:status (d)
421 "Return a current status of the deferred object. The returned value means following:
422 `ok': the callback was called and waiting for next deferred.
423 `ng': the errorback was called and waiting for next deferred.
424 nil: The neither callback nor errorback was not called."
425 (deferred-status d))
426
427 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
428 ;; Basic utility functions
429
430 (defvar deferred:onerror nil
431 "Default error handler. This value is nil or a function that
432 have one argument for the error message.")
433
434 (defun deferred:succeed (&optional arg)
435 "Create a synchronous deferred object."
436 (let ((d (deferred:new)))
437 (deferred:exec-task d 'ok arg)
438 d))
439
440 (defun deferred:fail (&optional arg)
441 "Create a synchronous deferred object."
442 (let ((d (deferred:new)))
443 (deferred:exec-task d 'ng arg)
444 d))
445
446 (defun deferred:next (&optional callback arg)
447 "Create a deferred object and schedule executing. This function
448 is a short cut of following code:
449 (deferred:callback-post (deferred:new callback))."
450 (let ((d (if callback
451 (make-deferred :callback callback)
452 (make-deferred))))
453 (deferred:callback-post d arg)
454 d))
455
456 (defun deferred:nextc (d callback)
457 "Create a deferred object with OK callback and connect it to the given deferred object."
458 (let ((nd (make-deferred :callback callback)))
459 (deferred:set-next d nd)))
460
461 (defun deferred:error (d callback)
462 "Create a deferred object with errorback and connect it to the given deferred object."
463 (let ((nd (make-deferred :errorback callback)))
464 (deferred:set-next d nd)))
465
466 (defun deferred:watch (d callback)
467 "Create a deferred object with watch task and connect it to the given deferred object.
468 The watch task CALLBACK can not affect deferred chains with
469 return values. This function is used in following purposes,
470 simulation of try-finally block in asynchronous tasks, progress
471 monitoring of tasks."
472 (lexical-let*
473 ((callback callback)
474 (normal (lambda (x) (ignore-errors (deferred:call-lambda callback x)) x))
475 (err (lambda (e)
476 (ignore-errors (deferred:call-lambda callback e))
477 (deferred:resignal e))))
478 (let ((nd (make-deferred :callback normal :errorback err)))
479 (deferred:set-next d nd))))
480
481 (defun deferred:wait (msec)
482 "Return a deferred object scheduled at MSEC millisecond later."
483 (lexical-let
484 ((d (deferred:new)) (start-time (float-time)) timer)
485 (deferred:message "WAIT : %s" msec)
486 (setq timer (deferred:setTimeout
487 (lambda ()
488 (deferred:exec-task d 'ok
489 (* 1000.0 (- (float-time) start-time)))
490 nil) msec))
491 (setf (deferred-cancel d)
492 (lambda (x)
493 (deferred:cancelTimeout timer)
494 (deferred:default-cancel x)))
495 d))
496
497 (defun deferred:wait-idle (msec)
498 "Return a deferred object which will run when Emacs has been
499 idle for MSEC millisecond."
500 (lexical-let
501 ((d (deferred:new)) (start-time (float-time)) timer)
502 (deferred:message "WAIT-IDLE : %s" msec)
503 (setq timer
504 (deferred:run-with-idle-timer
505 (/ msec 1000.0)
506 (lambda ()
507 (deferred:exec-task d 'ok
508 (* 1000.0 (- (float-time) start-time)))
509 nil)))
510 (setf (deferred-cancel d)
511 (lambda (x)
512 (deferred:cancelTimeout timer)
513 (deferred:default-cancel x)))
514 d))
515
516 (defun deferred:call (f &rest args)
517 "Call the given function asynchronously."
518 (lexical-let ((f f) (args args))
519 (deferred:next
520 (lambda (_x)
521 (apply f args)))))
522
523 (defun deferred:apply (f &optional args)
524 "Call the given function asynchronously."
525 (lexical-let ((f f) (args args))
526 (deferred:next
527 (lambda (_x)
528 (apply f args)))))
529
530
531
532 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
533 ;; Utility functions
534
535 (defun deferred:empty-p (times-or-seq)
536 "[internal] Return non-nil if TIMES-OR-SEQ is the number zero or nil."
537 (or (and (numberp times-or-seq) (<= times-or-seq 0))
538 (and (sequencep times-or-seq) (= (length times-or-seq) 0))))
539
540 (defun deferred:loop (times-or-seq func)
541 "Return a iteration deferred object."
542 (deferred:message "LOOP : %s" times-or-seq)
543 (if (deferred:empty-p times-or-seq) (deferred:next)
544 (lexical-let*
545 (items (rd
546 (cond
547 ((numberp times-or-seq)
548 (loop for i from 0 below times-or-seq
549 with ld = (deferred:next)
550 do
551 (push ld items)
552 (setq ld
553 (lexical-let ((i i) (func func))
554 (deferred:nextc ld (lambda (_x) (deferred:call-lambda func i)))))
555 finally return ld))
556 ((sequencep times-or-seq)
557 (loop for i in (append times-or-seq nil) ; seq->list
558 with ld = (deferred:next)
559 do
560 (push ld items)
561 (setq ld
562 (lexical-let ((i i) (func func))
563 (deferred:nextc ld (lambda (_x) (deferred:call-lambda func i)))))
564 finally return ld)))))
565 (setf (deferred-cancel rd)
566 (lambda (x) (deferred:default-cancel x)
567 (loop for i in items
568 do (deferred:cancel i))))
569 rd)))
570
571 (defun deferred:trans-multi-args (args self-func list-func main-func)
572 "[internal] Check the argument values and dispatch to methods."
573 (cond
574 ((and (= 1 (length args)) (consp (car args)) (not (functionp (car args))))
575 (let ((lst (car args)))
576 (cond
577 ((or (null lst) (null (car lst)))
578 (deferred:next))
579 ((deferred:aand lst (car it) (or (functionp it) (deferred-p it)))
580 ;; a list of deferred objects
581 (funcall list-func lst))
582 ((deferred:aand lst (consp it))
583 ;; an alist of deferred objects
584 (funcall main-func lst))
585 (t (error "Wrong argument type. %s" args)))))
586 (t (funcall self-func args))))
587
588 (defun deferred:parallel-array-to-alist (lst)
589 "[internal] Translation array to alist."
590 (loop for d in lst
591 for i from 0 below (length lst)
592 collect (cons i d)))
593
594 (defun deferred:parallel-alist-to-array (alst)
595 "[internal] Translation alist to array."
596 (loop for pair in
597 (sort alst (lambda (x y)
598 (< (car x) (car y))))
599 collect (cdr pair)))
600
601 (defun deferred:parallel-func-to-deferred (alst)
602 "[internal] Normalization for parallel and earlier arguments."
603 (loop for pair in alst
604 for d = (cdr pair)
605 collect
606 (progn
607 (unless (deferred-p d)
608 (setf (cdr pair) (deferred:next d)))
609 pair)))
610
611 (defun deferred:parallel-main (alst)
612 "[internal] Deferred alist implementation for `deferred:parallel'. "
613 (deferred:message "PARALLEL<KEY . VALUE>" )
614 (lexical-let ((nd (deferred:new))
615 (len (length alst))
616 values)
617 (loop for pair in
618 (deferred:parallel-func-to-deferred alst)
619 with cd ; current child deferred
620 do
621 (lexical-let ((name (car pair)))
622 (setq cd
623 (deferred:nextc (cdr pair)
624 (lambda (x)
625 (push (cons name x) values)
626 (deferred:message "PARALLEL VALUE [%s/%s] %s"
627 (length values) len (cons name x))
628 (when (= len (length values))
629 (deferred:message "PARALLEL COLLECTED")
630 (deferred:post-task nd 'ok (nreverse values)))
631 nil)))
632 (deferred:error cd
633 (lambda (e)
634 (push (cons name e) values)
635 (deferred:message "PARALLEL ERROR [%s/%s] %s"
636 (length values) len (cons name e))
637 (when (= (length values) len)
638 (deferred:message "PARALLEL COLLECTED")
639 (deferred:post-task nd 'ok (nreverse values)))
640 nil))))
641 nd))
642
643 (defun deferred:parallel-list (lst)
644 "[internal] Deferred list implementation for `deferred:parallel'. "
645 (deferred:message "PARALLEL<LIST>" )
646 (lexical-let*
647 ((pd (deferred:parallel-main (deferred:parallel-array-to-alist lst)))
648 (rd (deferred:nextc pd 'deferred:parallel-alist-to-array)))
649 (setf (deferred-cancel rd)
650 (lambda (x) (deferred:default-cancel x)
651 (deferred:cancel pd)))
652 rd))
653
654 (defun deferred:parallel (&rest args)
655 "Return a deferred object that calls given deferred objects or
656 functions in parallel and wait for all callbacks. The following
657 deferred task will be called with an array of the return
658 values. ARGS can be a list or an alist of deferred objects or
659 functions."
660 (deferred:message "PARALLEL : %s" args)
661 (deferred:trans-multi-args args
662 'deferred:parallel 'deferred:parallel-list 'deferred:parallel-main))
663
664 (defun deferred:earlier-main (alst)
665 "[internal] Deferred alist implementation for `deferred:earlier'. "
666 (deferred:message "EARLIER<KEY . VALUE>" )
667 (lexical-let ((nd (deferred:new))
668 (len (length alst))
669 value results)
670 (loop for pair in
671 (deferred:parallel-func-to-deferred alst)
672 with cd ; current child deferred
673 do
674 (lexical-let ((name (car pair)))
675 (setq cd
676 (deferred:nextc (cdr pair)
677 (lambda (x)
678 (push (cons name x) results)
679 (cond
680 ((null value)
681 (setq value (cons name x))
682 (deferred:message "EARLIER VALUE %s" (cons name value))
683 (deferred:post-task nd 'ok value))
684 (t
685 (deferred:message "EARLIER MISS [%s/%s] %s" (length results) len (cons name value))
686 (when (eql (length results) len)
687 (deferred:message "EARLIER COLLECTED"))))
688 nil)))
689 (deferred:error cd
690 (lambda (e)
691 (push (cons name e) results)
692 (deferred:message "EARLIER ERROR [%s/%s] %s" (length results) len (cons name e))
693 (when (and (eql (length results) len) (null value))
694 (deferred:message "EARLIER FAILED")
695 (deferred:post-task nd 'ok nil))
696 nil))))
697 nd))
698
699 (defun deferred:earlier-list (lst)
700 "[internal] Deferred list implementation for `deferred:earlier'. "
701 (deferred:message "EARLIER<LIST>" )
702 (lexical-let*
703 ((pd (deferred:earlier-main (deferred:parallel-array-to-alist lst)))
704 (rd (deferred:nextc pd (lambda (x) (cdr x)))))
705 (setf (deferred-cancel rd)
706 (lambda (x) (deferred:default-cancel x)
707 (deferred:cancel pd)))
708 rd))
709
710
711 (defun deferred:earlier (&rest args)
712 "Return a deferred object that calls given deferred objects or
713 functions in parallel and wait for the first callback. The
714 following deferred task will be called with the first return
715 value. ARGS can be a list or an alist of deferred objects or
716 functions."
717 (deferred:message "EARLIER : %s" args)
718 (deferred:trans-multi-args args
719 'deferred:earlier 'deferred:earlier-list 'deferred:earlier-main))
720
721 (defmacro deferred:timeout (timeout-msec timeout-form d)
722 "Time out macro on a deferred task D. If the deferred task D
723 does not complete within TIMEOUT-MSEC, this macro cancels the
724 deferred task and return the TIMEOUT-FORM."
725 `(deferred:earlier
726 (deferred:nextc (deferred:wait ,timeout-msec)
727 (lambda (x) ,timeout-form))
728 ,d))
729
730
731
732 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
733 ;; Application functions
734
735 (defvar deferred:uid 0 "[internal] Sequence number for some utilities. See the function `deferred:uid'.")
736
737 (defun deferred:uid ()
738 "[internal] Generate a sequence number."
739 (incf deferred:uid))
740
741 (defun deferred:buffer-string (strformat buf)
742 "[internal] Return a string in the buffer with the given format."
743 (format strformat
744 (with-current-buffer buf (buffer-string))))
745
746 (defun deferred:process (command &rest args)
747 "A deferred wrapper of `start-process'. Return a deferred
748 object. The process name and buffer name of the argument of the
749 `start-process' are generated by this function automatically.
750 The next deferred object receives stdout string from the command
751 process."
752 (deferred:process-gen 'start-process command args))
753
754 (defun deferred:process-shell (command &rest args)
755 "A deferred wrapper of `start-process-shell-command'. Return a deferred
756 object. The process name and buffer name of the argument of the
757 `start-process-shell-command' are generated by this function automatically.
758 The next deferred object receives stdout string from the command
759 process."
760 (deferred:process-gen 'start-process-shell-command command args))
761
762 (defun deferred:process-buffer (command &rest args)
763 "A deferred wrapper of `start-process'. Return a deferred
764 object. The process name and buffer name of the argument of the
765 `start-process' are generated by this function automatically.
766 The next deferred object receives stdout buffer from the command
767 process."
768 (deferred:process-buffer-gen 'start-process command args))
769
770 (defun deferred:process-shell-buffer (command &rest args)
771 "A deferred wrapper of `start-process-shell-command'. Return a deferred
772 object. The process name and buffer name of the argument of the
773 `start-process-shell-command' are generated by this function automatically.
774 The next deferred object receives stdout buffer from the command
775 process."
776 (deferred:process-buffer-gen 'start-process-shell-command command args))
777
778 (defun deferred:process-gen (f command args)
779 "[internal]"
780 (lexical-let
781 ((pd (deferred:process-buffer-gen f command args)) d)
782 (setq d (deferred:nextc pd
783 (lambda (buf)
784 (prog1
785 (with-current-buffer buf (buffer-string))
786 (kill-buffer buf)))))
787 (setf (deferred-cancel d)
788 (lambda (_x)
789 (deferred:default-cancel d)
790 (deferred:default-cancel pd)))
791 d))
792
793 (defun deferred:process-buffer-gen (f command args)
794 "[internal]"
795 (let ((d (deferred:next)) (uid (deferred:uid)))
796 (lexical-let
797 ((f f) (command command) (args args)
798 (proc-name (format "*deferred:*%s*:%s" command uid))
799 (buf-name (format " *deferred:*%s*:%s" command uid))
800 (pwd default-directory)
801 (env process-environment)
802 (con-type process-connection-type)
803 (nd (deferred:new)) proc-buf proc)
804 (deferred:nextc d
805 (lambda (_x)
806 (setq proc-buf (get-buffer-create buf-name))
807 (condition-case err
808 (let ((default-directory pwd)
809 (process-environment env)
810 (process-connection-type con-type))
811 (setq proc
812 (if (null (car args))
813 (apply f proc-name buf-name command nil)
814 (apply f proc-name buf-name command args)))
815 (set-process-sentinel
816 proc
817 (lambda (_proc event)
818 (cond
819 ((string-match "exited abnormally" event)
820 (let ((msg (if (buffer-live-p proc-buf)
821 (format "Process [%s] exited abnormally : %s"
822 command
823 (with-current-buffer proc-buf (buffer-string)))
824 (concat "Process exited abnormally: " proc-name))))
825 (kill-buffer proc-buf)
826 (deferred:post-task nd 'ng msg)))
827 ((equal event "finished\n")
828 (deferred:post-task nd 'ok proc-buf)))))
829 (setf (deferred-cancel nd)
830 (lambda (x) (deferred:default-cancel x)
831 (when proc
832 (kill-process proc)
833 (kill-buffer proc-buf)))))
834 (error (deferred:post-task nd 'ng err)))
835 nil))
836 nd)))
837
838 (defmacro deferred:processc (d command &rest args)
839 "Process chain of `deferred:process'."
840 `(deferred:nextc ,d
841 (lambda (,(gensym)) (deferred:process ,command ,@args))))
842
843 (defmacro deferred:process-bufferc (d command &rest args)
844 "Process chain of `deferred:process-buffer'."
845 `(deferred:nextc ,d
846 (lambda (,(gensym)) (deferred:process-buffer ,command ,@args))))
847
848 (defmacro deferred:process-shellc (d command &rest args)
849 "Process chain of `deferred:process'."
850 `(deferred:nextc ,d
851 (lambda (,(gensym)) (deferred:process-shell ,command ,@args))))
852
853 (defmacro deferred:process-shell-bufferc (d command &rest args)
854 "Process chain of `deferred:process-buffer'."
855 `(deferred:nextc ,d
856 (lambda (,(gensym)) (deferred:process-shell-buffer ,command ,@args))))
857
858 (eval-after-load "url"
859 ;; for url package
860 ;; TODO: proxy, charaset
861 ;; List of gloabl variables to preserve and restore before url-retrieve call
862 '(lexical-let ((url-global-variables '(url-request-data
863 url-request-method
864 url-request-extra-headers)))
865
866 (defun deferred:url-retrieve (url &optional cbargs silent inhibit-cookies)
867 "A wrapper function for url-retrieve. The next deferred
868 object receives the buffer object that URL will load
869 into. Values of dynamically bound 'url-request-data', 'url-request-method' and
870 'url-request-extra-headers' are passed to url-retrieve call."
871 (lexical-let ((nd (deferred:new)) (url url)
872 (cbargs cbargs) (silent silent) (inhibit-cookies inhibit-cookies) buf
873 (local-values (mapcar (lambda (symbol) (symbol-value symbol)) url-global-variables)))
874 (deferred:next
875 (lambda (_x)
876 (progv url-global-variables local-values
877 (condition-case err
878 (setq buf
879 (url-retrieve
880 url (lambda (_xx) (deferred:post-task nd 'ok buf))
881 cbargs silent inhibit-cookies))
882 (error (deferred:post-task nd 'ng err)))
883 nil)))
884 (setf (deferred-cancel nd)
885 (lambda (_x)
886 (when (buffer-live-p buf)
887 (kill-buffer buf))))
888 nd))
889
890 (defun deferred:url-delete-header (buf)
891 (with-current-buffer buf
892 (let ((pos (url-http-symbol-value-in-buffer
893 'url-http-end-of-headers buf)))
894 (when pos
895 (delete-region (point-min) (1+ pos)))))
896 buf)
897
898 (defun deferred:url-delete-buffer (buf)
899 (when (and buf (buffer-live-p buf))
900 (kill-buffer buf))
901 nil)
902
903 (defun deferred:url-get (url &optional params &rest args)
904 "Perform a HTTP GET method with `url-retrieve'. PARAMS is
905 a parameter list of (key . value) or key. ARGS will be appended
906 to deferred:url-retrieve args list. The next deferred
907 object receives the buffer object that URL will load into."
908 (when params
909 (setq url
910 (concat url "?" (deferred:url-param-serialize params))))
911 (let ((d (deferred:$
912 (apply 'deferred:url-retrieve url args)
913 (deferred:nextc it 'deferred:url-delete-header))))
914 (deferred:set-next
915 d (deferred:new 'deferred:url-delete-buffer))
916 d))
917
918 (defun deferred:url-post (url &optional params &rest args)
919 "Perform a HTTP POST method with `url-retrieve'. PARAMS is
920 a parameter list of (key . value) or key. ARGS will be appended
921 to deferred:url-retrieve args list. The next deferred
922 object receives the buffer object that URL will load into."
923 (let ((url-request-method "POST")
924 (url-request-extra-headers
925 (append url-request-extra-headers
926 '(("Content-Type" . "application/x-www-form-urlencoded"))))
927 (url-request-data (deferred:url-param-serialize params)))
928 (let ((d (deferred:$
929 (apply 'deferred:url-retrieve url args)
930 (deferred:nextc it 'deferred:url-delete-header))))
931 (deferred:set-next
932 d (deferred:new 'deferred:url-delete-buffer))
933 d)))
934
935 (defun deferred:url-escape (val)
936 "[internal] Return a new string that is VAL URI-encoded."
937 (unless (stringp val)
938 (setq val (format "%s" val)))
939 (url-hexify-string
940 (encode-coding-string val 'utf-8)))
941
942 (defun deferred:url-param-serialize (params)
943 "[internal] Serialize a list of (key . value) cons cells
944 into a query string."
945 (when params
946 (mapconcat
947 'identity
948 (loop for p in params
949 collect
950 (cond
951 ((consp p)
952 (concat
953 (deferred:url-escape (car p)) "="
954 (deferred:url-escape (cdr p))))
955 (t
956 (deferred:url-escape p))))
957 "&")))
958 ))
959
960
961 (provide 'deferred)
962 ;;; deferred.el ends here
+183
-0
sample/concurrent-sample.el less more
0 ;;; Sample code for concurrent.el
1
2 ;; Evaluate following code in the scratch buffer.
3
4 ;;==================================================
5 ;;; generator
6
7 (setq fib-list nil)
8
9 (setq fib-gen ; Create a generator object.
10 (lexical-let ((a1 0) (a2 1))
11 (cc:generator
12 (lambda (x) (push x fib-list)) ; receiving values
13 (yield a1)
14 (yield a2)
15 (while t
16 (let ((next (+ a1 a2)))
17 (setq a1 a2
18 a2 next)
19 (yield next))))))
20
21 (funcall fib-gen) ; Generate 5 times
22 (funcall fib-gen) (funcall fib-gen)
23 (funcall fib-gen) (funcall fib-gen)
24
25 fib-list ;=> (3 2 1 1 0)
26
27
28 ;;==================================================
29 ;;; thread
30
31 (lexical-let
32 ((count 0) (anm "-/|\\-")
33 (end 50) (pos (point)))
34 (cc:thread
35 60
36 (message "Animation started.")
37 (while (> end (incf count))
38 (save-excursion
39 (when (< 1 count)
40 (goto-char pos) (delete-char 1))
41 (insert (char-to-string
42 (aref anm (% count (length anm)))))))
43 (save-excursion
44 (goto-char pos) (delete-char 1))
45 (message "Animation finished.")))
46
47 ;; Play the simple character animation here.
48
49
50 ;;==================================================
51 ;;; semaphore
52
53 ;; create a semaphore object with permit=1.
54 (setq smp (cc:semaphore-create 1))
55
56 ;; executing three tasks...
57 (deferred:nextc (cc:semaphore-acquire smp)
58 (lambda(x)
59 (message "go1")))
60 (deferred:nextc (cc:semaphore-acquire smp)
61 (lambda(x)
62 (message "go2")))
63 (deferred:nextc (cc:semaphore-acquire smp)
64 (lambda(x)
65 (message "go3")))
66
67 ;; => Only the fist task is executed and displays "go1".
68
69 (cc:semaphore-release smp)
70
71 ;; => The second task is executed and displays "go2".
72
73 (cc:semaphore-waiting-deferreds smp) ; return the deferred object that displays "go3".
74
75 (cc:semaphore-release-all smp) ; => reset permit count and return the deferred object that displays "go3".
76
77 (cc:semaphore-waiting-deferreds smp) ; => nil
78
79
80 ;;==================================================
81 ;; Dataflow
82
83 ;; create a parent environment and bind "aaa" to 256.
84 (setq dfenv-parent (cc:dataflow-environment))
85 (cc:dataflow-set dfenv-parent "aaa" 256)
86
87 ;; create an environment with the parent one.
88 (setq dfenv (cc:dataflow-environment dfenv-parent))
89
90 ;; Return the parent value.
91 (cc:dataflow-get-sync dfenv "aaa") ; => 256
92
93 (deferred:$
94 (cc:dataflow-get dfenv "abc")
95 (deferred:nextc it
96 (lambda (x) (message "Got abc : %s" x))))
97 ;; => This task is blocked
98
99 (cc:dataflow-set dfenv "abc" 256) ; bind 256 to "abc"
100
101 ;; => The blocked task is executed and displays "Got abc : 256".
102
103 (cc:dataflow-get-sync dfenv "abc") ; => 256
104
105 ;; unbind the variable "abc"
106 (cc:dataflow-clear dfenv "abc")
107
108 (cc:dataflow-get-sync dfenv "abc") ; => nil
109
110
111 ;; complicated key (`equal' can compare nested lists.)
112
113 (deferred:$
114 (cc:dataflow-get dfenv '("http://example.com/a.jpg" 300))
115 (deferred:nextc it
116 (lambda (x) (message "a.jpg:300 OK %s" x))))
117
118 (cc:dataflow-set dfenv '("http://example.com/a.jpg" 300) 'jpeg)
119
120 ;; waiting for two variables
121
122 (deferred:$
123 (deferred:parallel
124 (cc:dataflow-get dfenv "abc")
125 (cc:dataflow-get dfenv "def"))
126 (deferred:nextc it
127 (lambda (values)
128 (apply 'message "Got values : %s, %s" values)
129 (apply '+ values)))
130 (deferred:nextc it
131 (lambda (x) (insert (format ">> %s" x)))))
132
133 (cc:dataflow-get-waiting-keys dfenv) ; => ("def" "abc")
134 (cc:dataflow-get-avalable-pairs dfenv) ; => (("aaa" . 256))
135
136 (cc:dataflow-set dfenv "abc" 128)
137 (cc:dataflow-set dfenv "def" 256)
138
139 ;; => "Got values : 128, 256"
140 ;; inserted ">> 384"
141
142 (cc:dataflow-get-avalable-pairs dfenv)
143
144 (cc:dataflow-clear-all dfenv)
145
146 (cc:dataflow-get-avalable-pairs dfenv)
147
148
149 ;;==================================================
150 ;; Signal
151
152 (progn
153 (setq parent-channel (cc:signal-channel "parent"))
154 (cc:signal-connect
155 parent-channel 'parent-load
156 (lambda (event) (message "Parent Signal : %s" event)))
157 (cc:signal-connect
158 parent-channel t
159 (lambda (event) (message "Parent Listener : %s" event)))
160
161 (setq channel (cc:signal-channel "child" parent-channel))
162 (cc:signal-connect
163 channel 'window-load
164 (lambda (event) (message "Signal : %s" event)))
165 (cc:signal-connect
166 channel t
167 (lambda (event) (message "Listener : %s" event)))
168 (deferred:$
169 (cc:signal-connect channel 'window-load)
170 (deferred:nextc it
171 (lambda (x) (message "Deferred Signal : %s" x))))
172 )
173
174 (cc:signal-send channel 'window-load "hello signal!")
175 (cc:signal-send channel 'some "some signal!")
176
177 (cc:signal-send parent-channel 'parent-load "parent hello!")
178 (cc:signal-send parent-channel 'window-load "parent hello!")
179 (cc:signal-send parent-channel 'some "parent some hello!")
180 (cc:signal-send-global channel 'some "parent some hello!")
181
182 (cc:signal-disconnect-all channel)
+165
-0
sample/deferred-samples.el less more
0 ;; deferred.el samples
1
2 (require 'deferred)
3
4 ;;; Basic Chain
5
6 (deferred:$
7 (deferred:next
8 (lambda () (message "deferred start")))
9 (deferred:nextc it
10 (lambda ()
11 (message "chain 1")
12 1))
13 (deferred:nextc it
14 (lambda (x)
15 (message "chain 2 : %s" x)))
16 (deferred:nextc it
17 (lambda ()
18 (read-minibuffer "Input a number: ")))
19 (deferred:nextc it
20 (lambda (x)
21 (message "Got the number : %i" x)))
22 (deferred:error it
23 (lambda (err)
24 (message "Wrong input : %s" err))))
25
26
27 ;;; Timer
28
29 (deferred:$
30 (deferred:wait 1000) ; 1000msec
31 (deferred:nextc it
32 (lambda (x)
33 (message "Timer sample! : %s msec" x))))
34
35
36 ;;; Command process
37
38 (deferred:$
39 (deferred:process "ls" "-la")
40 (deferred:nextc it
41 (lambda (x) (insert x))))
42
43
44 ;;; Web Access
45
46 ;; Simple web access
47
48 (require 'url)
49
50 (deferred:$
51 (deferred:url-retrieve "http://www.gnu.org")
52 (deferred:nextc it
53 (lambda (buf)
54 (insert (with-current-buffer buf (buffer-string)))
55 (kill-buffer buf))))
56
57 ;; Get an image
58
59 (deferred:$
60 (deferred:url-retrieve "http://www.google.co.jp/intl/en_com/images/srpr/logo1w.png")
61 (deferred:nextc it
62 (lambda (buf)
63 (insert-image
64 (create-image
65 (let ((data (with-current-buffer buf (buffer-string))))
66 (substring data (+ (string-match "\n\n" data) 2)))
67 'png t))
68 (kill-buffer buf))))
69
70 ;; HTTP POST
71
72 (deferred:$
73 (deferred:url-post
74 "http://127.0.0.1:8080/post-test.cgi"
75 '(('a . "test") ('param . "OK")))
76 (deferred:nextc it
77 (lambda (buf)
78 (insert (with-current-buffer buf (buffer-string)))
79 (kill-buffer buf))))
80
81
82 ;; Parallel deferred
83
84 (deferred:$
85 (deferred:parallel
86 (lambda ()
87 (deferred:url-retrieve "http://www.google.co.jp/intl/en_com/images/srpr/logo1w.png"))
88 (lambda ()
89 (deferred:url-retrieve "http://www.google.co.jp/images/srpr/nav_logo14.png")))
90 (deferred:nextc it
91 (lambda (buffers)
92 (loop for i in buffers
93 do
94 (insert
95 (format
96 "size: %s\n"
97 (with-current-buffer i (length (buffer-string)))))
98 (kill-buffer i)))))
99
100 ;; Get an image by wget and resize by ImageMagick
101
102 (deferred:$
103
104 ;; try
105 (deferred:$
106 (deferred:process "wget" "-O" "a.jpg" "http://www.gnu.org/software/emacs/tour/images/splash.png")
107 (deferred:nextc it
108 (lambda () (deferred:process "convert" "a.jpg" "-resize" "100x100" "jpg:b.jpg")))
109 (deferred:nextc it
110 (lambda ()
111 (clear-image-cache)
112 (insert-image (create-image (expand-file-name "b.jpg") 'jpeg nil)))))
113
114 ;; catch
115 (deferred:error it ;
116 (lambda (err)
117 (insert "Can not get a image! : " err)))
118
119 ;; finally
120 (deferred:nextc it
121 (lambda ()
122 (deferred:parallel
123 (lambda () (delete-file "a.jpg"))
124 (lambda () (delete-file "b.jpg")))))
125 (deferred:nextc it
126 (lambda (x) (message ">> %s" x))))
127
128
129 ;; Timeout Process
130
131 (deferred:$
132 (deferred:earlier
133 (deferred:process "sh" "-c" "sleep 3 | echo 'hello!'")
134 (deferred:$
135 (deferred:wait 1000) ; timeout msec
136 (deferred:nextc it (lambda () "canceled!"))))
137 (deferred:nextc it
138 (lambda (x) (insert x))))
139
140
141 ;; Loop and animation
142
143 (lexical-let ((count 0) (anm "-/|\\-")
144 (end 50) (pos (point))
145 (wait-time 50))
146 (deferred:$
147 (deferred:next
148 (lambda (x) (message "Animation started.")))
149
150 (deferred:nextc it
151 (deferred:lambda (x)
152 (save-excursion
153 (when (< 0 count)
154 (goto-char pos) (delete-char 1))
155 (insert (char-to-string
156 (aref anm (% count (length anm))))))
157 (if (> end (incf count))
158 (deferred:nextc (deferred:wait wait-time) self))))
159
160 (deferred:nextc it
161 (lambda (x)
162 (save-excursion
163 (goto-char pos) (delete-char 1))
164 (message "Animation finished.")))))
+620
-0
test/concurrent-test.el less more
0 ;;; test code for concurrent.el
1
2 ;; Copyright (C) 2010 SAKURAI Masashi
3 ;; Author: SAKURAI Masashi <m.sakurai at kiwanami.net>
4
5 ;; This program is free software; you can redistribute it and/or modify
6 ;; it under the terms of the GNU General Public License as published by
7 ;; the Free Software Foundation, either version 3 of the License, or
8 ;; (at your option) any later version.
9
10 ;; This program is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 ;; GNU General Public License for more details.
14
15 ;; You should have received a copy of the GNU General Public License
16 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
17
18 ;; How to run this test ?
19 ;; $ emacs -L . -L $HOME/.emacs.d/elisp -batch -l deferred -l concurrent -l test-concurrent -f cc:test-all
20
21 (require 'undercover)
22 (undercover "concurrent.el"
23 (:send-report nil)
24 (:report-file "/tmp/undercover-report.json"))
25 (require 'concurrent)
26 (require 'cl)
27 (require 'pp)
28 (require 'ert)
29
30 (defmacro cc:debug (d msg &rest args)
31 `(deferred:nextc ,d
32 (lambda (x) (funcall 'message ,msg ,@args) x)))
33
34 ;; generator
35
36 (defun cc:fib-gen (callback)
37 (lexical-let ((a1 0) (a2 1)
38 (callback callback))
39 (cc:generator
40 callback
41 (yield a1)
42 (yield a2)
43 (while t
44 (let ((next (+ a1 a2)))
45 (setq a1 a2
46 a2 next)
47 (yield next))))))
48
49 (defun cc:test-fib-gen ()
50 (lexical-let*
51 ((count 0)
52 (dfinish (deferred:new))
53 gen
54 (cc (lambda (x)
55 (cond
56 ((= count 10)
57 (deferred:callback
58 dfinish
59 (if (= x 55) t
60 (format "Fib 10 = 55 -> %s" x))))
61 (t
62 (incf count)
63 (deferred:call gen))))))
64 (setq gen (cc:fib-gen cc))
65 (deferred:call gen)
66 dfinish))
67
68 ;; (cc:debug (cc:test-fib-gen) "Fib10 : %s" x)
69
70 ;; thread
71
72 (defun cc:test-thread ()
73 (lexical-let
74 ((dfinish (deferred:new))
75 (result nil) (start-time (float-time))
76 (count 0) (end 20))
77 (push 1 result)
78 (cc:thread
79 60
80 (push 2 result)
81 (while (> end (incf count))
82 (when (= 0 (% count 10))
83 (push count result)))
84 (push 99 result)
85 (setq result (reverse result))
86 (deferred:callback dfinish
87 (and (or (equal '(1 2 10 99) result) result)
88 (let ((elapsed-time (- (float-time) start-time)))
89 (or (and (< 1.0 elapsed-time) (< elapsed-time 6)) elapsed-time)))))
90 dfinish))
91
92 ;; (cc:debug (cc:test-thread) "Thread : %s" x)
93
94 ;; semaphore
95
96 (defun cc:test-semaphore1 ()
97 (lexical-let*
98 ((result nil)
99 (dfinish (deferred:new
100 (lambda (x)
101 (setq result (reverse result))
102 (or (equal '(1 2 5 6 (size . 1) 3 7 8 canceled (size . 0)) result)
103 result))))
104 (smp (cc:semaphore-create 1)))
105
106 (push 1 result)
107
108 (deferred:nextc (cc:semaphore-acquire smp)
109 (lambda(x) (push 2 result)))
110 (deferred:nextc (cc:semaphore-acquire smp)
111 (lambda(x) (push 3 result)))
112 (deferred:nextc (cc:semaphore-acquire smp)
113 (lambda(x) (push x result)))
114
115 (deferred:$
116 (deferred:next
117 (lambda (x)
118 (push 5 result)
119 (cc:semaphore-release smp)
120 (push 6 result)))
121 (deferred:nextc it
122 (lambda (x)
123 (push (cons 'size (length (cc:semaphore-waiting-deferreds smp))) result)))
124 (deferred:nextc it
125 (lambda (x)
126 (push 7 result)
127 (loop for i in (cc:semaphore-release-all smp)
128 do (deferred:callback i 'canceled))
129 (push 8 result)))
130 (deferred:nextc it
131 (lambda (x)
132 (push (cons 'size (length (cc:semaphore-waiting-deferreds smp))) result)))
133 (deferred:nextc it
134 (lambda (x) (deferred:callback dfinish))))
135
136 dfinish))
137
138 ;; (cc:debug (cc:test-semaphore1) "Semaphore1 : %s" x)
139
140 (defun cc:test-semaphore2 ()
141 (lexical-let*
142 ((result nil)
143 (dfinish (deferred:new
144 (lambda (x)
145 (setq result (reverse result))
146 (or (equal '(0 a b c d e f g) result)
147 result))))
148 (smp (cc:semaphore-create 1)))
149
150 (push 0 result)
151
152 (cc:semaphore-with
153 smp (lambda (x)
154 (deferred:nextc (cc:semaphore-acquire smp)
155 (lambda (x)
156 (push 'c result)
157 (cc:semaphore-release smp)))
158 (push 'a result)
159 (deferred:nextc
160 (deferred:wait 100)
161 (lambda (x) (push 'b result)))))
162
163 (cc:semaphore-with
164 smp (lambda (x)
165 (deferred:nextc (cc:semaphore-acquire smp)
166 (lambda (x)
167 (push 'g result)
168 (cc:semaphore-release smp)
169 (deferred:callback dfinish)))
170 (push 'd result)
171 (deferred:nextc
172 (deferred:wait 100)
173 (lambda (x)
174 (push 'e result)
175 (error "SMP CC ERR"))))
176 (lambda (e)
177 (destructuring-bind (sym msg) e
178 (when (and (eq 'error sym) (equal "SMP CC ERR" msg))
179 (push 'f result)))))
180
181 dfinish))
182
183 ;; (cc:debug (cc:test-semaphore2) "Semaphore2 : %s" x)
184
185 ;; Dataflow
186
187 (defun cc:test-dataflow-simple1 ()
188 (lexical-let*
189 ((result '(1))
190 (dfinish (deferred:new
191 (lambda (x)
192 (setq result (reverse result))
193 (or (equal '(1 (2 . nil) 4 5 (3 . 256) (6 . 256) (7 . nil)) result)
194 result))))
195 (dfenv (cc:dataflow-environment)))
196
197 (push (cons 2 (cc:dataflow-get-sync dfenv "aaa")) result)
198
199 (deferred:$
200 (deferred:parallel
201 (deferred:$
202 (cc:dataflow-get dfenv "abc")
203 (deferred:nextc it
204 (lambda (x) (push (cons 3 x) result))))
205 (deferred:$
206 (deferred:next
207 (lambda (x)
208 (push 4 result)
209 (cc:dataflow-set dfenv "abc" 256)
210 (push 5 result)))))
211 (deferred:nextc it
212 (lambda (x)
213 (push (cons 6 (cc:dataflow-get-sync dfenv "abc")) result)
214 (cc:dataflow-clear dfenv "abc")
215 (push (cons 7 (cc:dataflow-get-sync dfenv "abc")) result)))
216 (deferred:nextc it
217 (lambda (x)
218 (deferred:callback dfinish))))
219
220 dfinish))
221
222 ;; (cc:debug (cc:test-dataflow-simple1) "Dataflow1 : %s" x)
223
224 (defun cc:test-dataflow-simple2 ()
225 (lexical-let*
226 ((result nil)
227 (dfinish (deferred:new
228 (lambda (x)
229 (or (equal '("a.jpg:300 OK jpeg") result)
230 result))))
231 (dfenv (cc:dataflow-environment)))
232
233 (deferred:$
234 (cc:dataflow-get dfenv '("http://example.com/a.jpg" 300))
235 (deferred:nextc it
236 (lambda (x) (push (format "a.jpg:300 OK %s" x) result)))
237 (deferred:nextc it
238 (lambda (x)
239 (deferred:callback dfinish))))
240
241 (cc:dataflow-set dfenv '("http://example.com/a.jpg" 300) 'jpeg)
242
243 dfinish))
244
245 ;; (cc:debug (cc:test-dataflow-simple2) "Dataflow2 : %s" x)
246
247 (defun cc:test-dataflow-simple3 ()
248 (lexical-let*
249 ((result nil)
250 (dfinish (deferred:new
251 (lambda (x)
252 (or (equal '(">> 384") result)
253 result))))
254 (dfenv (cc:dataflow-environment)))
255
256 (deferred:$
257 (deferred:parallel
258 (cc:dataflow-get dfenv "def")
259 (cc:dataflow-get dfenv "abc"))
260 (deferred:nextc it
261 (lambda (values)
262 (apply '+ values)))
263 (deferred:nextc it
264 (lambda (x) (push (format ">> %s" x) result)))
265 (deferred:nextc it
266 (lambda (x)
267 (deferred:callback dfinish))))
268
269 (deferred:nextc (deferred:wait 0.2)
270 (lambda (x)
271 (cc:dataflow-set dfenv "def" 128)
272 (cc:dataflow-set dfenv "abc" 256)
273 (cc:dataflow-set dfenv "aaa" 512)
274 ))
275
276 dfinish))
277
278 ;; (cc:debug (cc:test-dataflow-simple3) "Dataflow3 : %s" x)
279
280 (defun cc:test-dataflow-simple4 ()
281 (lexical-let*
282 ((result nil)
283 (dfinish (deferred:new
284 (lambda (x)
285 (or (equal '(">> 3") result)
286 result))))
287 (dfenv (cc:dataflow-environment)))
288
289 (deferred:$
290 (deferred:parallel
291 (cc:dataflow-get dfenv "abc")
292 (cc:dataflow-get dfenv "abc")
293 (cc:dataflow-get dfenv "abc"))
294 (deferred:nextc it
295 (lambda (values)
296 (apply '+ values)))
297 (deferred:nextc it
298 (lambda (x) (push (format ">> %s" x) result)))
299 (deferred:nextc it
300 (lambda (x)
301 (deferred:callback dfinish))))
302
303 (deferred:nextc (deferred:wait 0.2)
304 (lambda (x)
305 (cc:dataflow-set dfenv "abc" 1)
306 ))
307
308 dfinish))
309
310 ;; (cc:debug (cc:test-dataflow-simple4) "Dataflow4 : %s" x)
311
312 (defun cc:test-dataflow-signal ()
313 (lexical-let*
314 ((result '(1))
315 (dfinish (deferred:new
316 (lambda (x)
317 (setq result (reverse result))
318 (or (equal
319 '(1
320 (2 . nil)
321 (get-first ("abc"))
322 (get-waiting ("abc"))
323 4 5
324 (set ("abc"))
325 (3 . 256)
326 6 7
327 (get ("abc"))
328 (8 . 256)
329 (9 . nil)
330 (clear ("abc"))
331 (clear-all (nil))
332 ) result)
333 result))))
334 (dfenv (cc:dataflow-environment)))
335
336 (loop for i in '(get get-first get-waiting set clear clear-all)
337 do (cc:dataflow-connect dfenv i (lambda (ev) (push ev result))))
338
339 (push (cons 2 (cc:dataflow-get-sync dfenv "aaa")) result)
340
341 (deferred:$
342 (deferred:parallel
343 (deferred:$
344 (cc:dataflow-get dfenv "abc")
345 (deferred:nextc it
346 (lambda (x) (push (cons 3 x) result))))
347 (deferred:$
348 (deferred:next
349 (lambda (x)
350 (push 4 result)
351 (cc:dataflow-set dfenv "abc" 256)
352 (push 5 result)))))
353 (deferred:nextc it
354 (lambda (x)
355 (push 6 result)
356 (cc:dataflow-get dfenv "abc")
357 (push 7 result)))
358 (deferred:nextc it
359 (lambda (x)
360 (push (cons 8 (cc:dataflow-get-sync dfenv "abc")) result)
361 (cc:dataflow-clear dfenv "abc")
362 (push (cons 9 (cc:dataflow-get-sync dfenv "abc")) result)))
363 (deferred:nextc it
364 (lambda (x)
365 (cc:dataflow-clear-all dfenv)))
366 (deferred:nextc it
367 (lambda (x)
368 (deferred:callback dfinish))))
369
370 dfinish))
371
372 ;; (cc:debug (cc:test-dataflow-signal) "Dataflow Signal : %s" x)
373
374
375 (defun cc:test-dataflow-parent1 ()
376 (lexical-let*
377 ((result '(1))
378 (dfinish (deferred:new
379 (lambda (x)
380 (setq result (reverse result))
381 (or (equal
382 '(1
383 (available-parent . (("abc" . 128)))
384 (available-child . (("abc" . 128)))
385 (waiting-parent . nil)
386 (waiting-child . ("aaa"))
387 (get-sync . 256)
388 (get . 256)
389 ) result)
390 result))))
391 (dfenv-parent (cc:dataflow-environment))
392 (dfenv (cc:dataflow-environment dfenv-parent)))
393
394 (cc:dataflow-set dfenv-parent "abc" 128)
395
396 (deferred:$
397 (deferred:parallel
398 (deferred:$
399 (cc:dataflow-get dfenv "aaa")
400 (deferred:nextc it
401 (lambda (x) (push (cons 'get x) result))))
402 (deferred:$
403 (deferred:next
404 (lambda (x)
405 (push (cons 'available-parent (cc:dataflow-get-avalable-pairs dfenv-parent)) result)
406 (push (cons 'available-child (cc:dataflow-get-avalable-pairs dfenv)) result)
407 (push (cons 'waiting-parent (cc:dataflow-get-waiting-keys dfenv-parent)) result)
408 (push (cons 'waiting-child (cc:dataflow-get-waiting-keys dfenv)) result)))
409 (deferred:next
410 (lambda (x)
411 (cc:dataflow-set dfenv-parent "aaa" 256)
412 (push (cons 'get-sync (cc:dataflow-get-sync dfenv "aaa")) result)))))
413 (deferred:nextc it
414 (lambda (x) (deferred:callback dfinish))))
415
416 dfinish))
417
418 ;; (cc:debug (cc:test-dataflow-parent1) "Dataflow Parent1 : %s" x)
419
420 (defun cc:test-dataflow-parent2 ()
421 (lexical-let*
422 ((result '())
423 (dfinish (deferred:new
424 (lambda (x)
425 (setq result (reverse result))
426 (or (equal
427 '("parent get 256" "child get 256") result)
428 result))))
429 (dfenv-parent (cc:dataflow-environment))
430 (dfenv (cc:dataflow-environment dfenv-parent)))
431
432 (deferred:$
433 (deferred:parallel
434 (deferred:$
435 (cc:dataflow-get dfenv-parent "abc")
436 (deferred:nextc it
437 (lambda (x) (push (format "parent get %s" x) result))))
438 (deferred:$
439 (cc:dataflow-get dfenv "abc")
440 (deferred:nextc it
441 (lambda (x) (push (format "child get %s" x) result))))
442 (deferred:nextc (deferred:wait 0.2)
443 (lambda (x) (cc:dataflow-set dfenv-parent "abc" 256))))
444 (deferred:nextc it
445 (lambda (x) (deferred:callback dfinish))))
446
447 dfinish))
448
449 ;; (cc:debug (cc:test-dataflow-parent2) "Dataflow Parent : %s" x)
450
451
452 ;; Signal
453
454 (defun cc:test-signal1 ()
455 (lexical-let*
456 ((result '())
457 (dfinish (deferred:new
458 (lambda (x)
459 (setq result (reverse result))
460 (or (equal
461 '(
462 (ls ev1 (1))
463 (sig ev1 (1))
464 (ls ev2 (2))
465 (def ev1 (1))
466 ) result)
467 result))))
468 (channel (cc:signal-channel "child")))
469
470 (cc:signal-connect channel 'ev1
471 (lambda (event)
472 (push (cons 'sig event) result)))
473 (cc:signal-connect channel t
474 (lambda (event)
475 (push (cons 'ls event) result)))
476 (deferred:$
477 (cc:signal-connect channel 'ev1)
478 (deferred:nextc it
479 (lambda (x) (push (cons 'def x) result))))
480
481 (deferred:$
482 (deferred:next
483 (lambda (x)
484 (cc:signal-send channel 'ev1 1)
485 (cc:signal-send channel 'ev2 2)))
486 (deferred:nextc it
487 (lambda (x) (deferred:wait 300)))
488 (deferred:nextc it
489 (lambda (x)
490 (deferred:callback dfinish))))
491
492 dfinish))
493
494 ;; (cc:debug (cc:test-signal1) "Signal1 : %s" x)
495
496 ;; (cc:debug (cc:test-signal2) "Signal2 : %s" x)
497
498 (defun cc:test-signal2 ()
499 (lexical-let*
500 ((result nil)
501 (dfinish (deferred:new
502 (lambda (x)
503 (setq result (reverse result))
504 (or (equal
505 '(
506 (pls pev1 (1))
507 (psig pev1 (1))
508 (pls ev1 (2))
509 (ls ev1 (3))
510 (sig ev1 (3))
511 (pls ev2 (4))
512 (pls ev2 (5))
513
514 (ls pev1 (1))
515 (ls ev1 (2))
516
517 (sig ev1 (2))
518 (def ev1 (3))
519 (ls ev2 (4))
520 (ls ev2 (5))
521
522 (def ev1 (2))
523 )
524 result)
525 result))))
526 (parent-channel (cc:signal-channel "parent"))
527 (channel (cc:signal-channel "child" parent-channel)))
528
529 (cc:signal-connect parent-channel 'pev1
530 (lambda (event)
531 (push (cons 'psig event) result)))
532 (cc:signal-connect parent-channel t
533 (lambda (event)
534 (push (cons 'pls event) result)))
535 (cc:signal-connect channel 'ev1
536 (lambda (event)
537 (push (cons 'sig event) result)))
538 (cc:signal-connect channel t
539 (lambda (event)
540 (push (cons 'ls event) result)))
541 (deferred:$
542 (cc:signal-connect channel 'ev1)
543 (deferred:nextc it
544 (lambda (x)
545 (push (cons 'def x) result))))
546
547 (deferred:$
548 (deferred:next
549 (lambda (x)
550 (cc:signal-send parent-channel 'pev1 1)
551 (cc:signal-send parent-channel 'ev1 2)
552 (cc:signal-send channel 'ev1 3)
553 (cc:signal-send parent-channel 'ev2 4)
554 (cc:signal-send-global channel 'ev2 5)))
555 (deferred:nextc it
556 (lambda (x) (deferred:wait 300)))
557 (deferred:nextc it
558 (lambda (x)
559 (deferred:callback-post dfinish))))
560
561 dfinish))
562
563 ;; (cc:debug (cc:test-signal2) "Signal2 : %s" x)
564
565 (defvar cc:test-finished-flag nil)
566 (defvar cc:test-fails 0)
567
568 (defun cc:test-all ()
569 (interactive)
570 (setq cc:test-finished-flag nil)
571 (setq cc:test-fails 0)
572 (deferred:$
573 (deferred:parallel
574 (loop for i in '(cc:test-fib-gen
575 cc:test-thread
576 cc:test-semaphore1
577 cc:test-semaphore2
578 cc:test-dataflow-simple1
579 cc:test-dataflow-simple2
580 cc:test-dataflow-simple3
581 cc:test-dataflow-simple4
582 cc:test-dataflow-signal
583 cc:test-dataflow-parent1
584 cc:test-dataflow-parent2
585 cc:test-signal1
586 cc:test-signal2
587 )
588 collect (cons i (deferred:timeout 5000 "timeout" (funcall i)))))
589 (deferred:nextc it
590 (lambda (results)
591 (pop-to-buffer
592 (with-current-buffer (get-buffer-create "*cc:test*")
593 (erase-buffer)
594 (loop for i in results
595 for name = (car i)
596 for result = (cdr i)
597 with fails = 0
598 do (insert (format "%s : %s\n" name
599 (if (eq t result) "OK"
600 (format "FAIL > %s" result))))
601 (unless (eq t result) (incf fails))
602 finally
603 (goto-char (point-min))
604 (insert (format "Test Finished : %s\nTests Fails: %s / %s\n"
605 (format-time-string "%Y/%m/%d %H:%M:%S" (current-time))
606 fails (length results)))
607 (setq cc:test-fails fails))
608 (message (buffer-string))
609 (current-buffer)))
610 (setq cc:test-finished-flag t))))
611
612 (while (null cc:test-finished-flag)
613 (sleep-for 0 100) (sit-for 0 100))
614 (when (and noninteractive
615 (> cc:test-fails 0))
616 (error "Test failed")))
617
618 (ert-deftest concurrent-all-the-thing ()
619 (should-not (cc:test-all)))
+1021
-0
test/deferred-test.el less more
0 ;;; test code for deferred.el
1
2 ;; Copyright (C) 2010, 2011 SAKURAI Masashi
3 ;; Author: SAKURAI Masashi <m.sakurai at kiwanami.net>
4
5 ;; This program is free software; you can redistribute it and/or modify
6 ;; it under the terms of the GNU General Public License as published by
7 ;; the Free Software Foundation, either version 3 of the License, or
8 ;; (at your option) any later version.
9
10 ;; This program is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 ;; GNU General Public License for more details.
14
15 ;; You should have received a copy of the GNU General Public License
16 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
17
18 ;;; Commentary:
19
20 ;; Run tests:
21 ;; $ emacs -batch -l test-deferred.el -f ert-run-tests-batch-and-exit
22
23
24 (require 'ert)
25 (require 'undercover)
26 (undercover "deferred.el"
27 (:send-report nil)
28 (:report-file "/tmp/undercover-report.json"))
29 (require 'deferred)
30 (require 'cl)
31 (require 'pp)
32
33 (defmacro should= (a &rest b)
34 `(should (equal ,a (progn ,@b)))
35 )
36
37 (defmacro aand (test &rest rest)
38 `(let ((it ,test))
39 (if it ,(if rest (macroexpand-all `(aand ,@rest)) 'it))))
40
41 (defmacro $ (&rest elements)
42 `(let (it)
43 ,@(loop for i in elements
44 with it = nil
45 collect
46 `(setq it ,i))
47 it))
48
49 (defmacro dnew(&rest aforms)
50 (if aforms
51 `(deferred:new (lambda (x) ,@aforms))
52 `(deferred:new)))
53
54 (defmacro next(&rest aforms)
55 `(deferred:next (lambda (x) ,@aforms)))
56
57 (defmacro nextc(d &rest aforms)
58 `(deferred:nextc ,d (lambda (x) ,@aforms)))
59
60 (defmacro errorc(d &rest aforms)
61 `(deferred:error ,d (lambda (e) ,@aforms)))
62
63 (defmacro errorf(d formatstr)
64 `(deferred:error ,d (lambda (e) (error ,formatstr e))))
65
66 (defmacro cancelc(d)
67 `(deferred:cancel ,d))
68
69 (defmacro wait(msec)
70 `(deferred:wait ,msec))
71
72 (defmacro dloop(&rest body)
73 `(deferred:loop ,@body))
74
75 (defmacro parallel(&rest args)
76 `(deferred:parallel ,@args))
77
78 (defmacro earlier(&rest args)
79 `(deferred:earlier ,@args))
80
81 (defmacro flush ()
82 `(deferred:flush-queue!))
83
84 (defmacro clear ()
85 `(setq deferred:queue nil))
86
87 (defmacro dtest (&rest form)
88 `(progn
89 (clear)
90 (lexical-let (last-value)
91 (nextc
92 ($
93 ,@form)
94 (setq last-value x))
95 (flush)
96 last-value)))
97
98 (defmacro wtest (time &rest form)
99 `(progn
100 (clear)
101 (lexical-let (last-value)
102 (nextc
103 ($
104 ,@form)
105 (setq last-value x))
106 (while (null last-value)
107 (sit-for ,time))
108 (flush)
109 last-value)))
110
111 (defun deferred:setTimeout (f msec)
112 "overrided for test"
113 (deferred:call f))
114
115 (defun deferred:cancelTimeout (id)
116 "overrided for test"
117 (when (deferred-p id)
118 (deferred:cancel id)))
119
120 (defun deferred:run-with-idle-timer (sec f)
121 "overrided for test"
122 (deferred:call f))
123
124 (defun deferred:not-called-func (&optional m)
125 (error "Must not be called!! %s" m))
126
127
128
129 (ert-deftest deferred-primitive-simple ()
130 "> call-lambda simple"
131 (should= 1 (deferred:call-lambda (lambda () 1)))
132 (should= 1 (deferred:call-lambda (lambda () 1) 1))
133 (should= 1 (deferred:call-lambda (lambda (x) 1)))
134 (should= 1 (deferred:call-lambda (lambda (x) 1) 1))
135 (should= 1 (deferred:call-lambda (deferred:lambda () 1)))
136 (should= 1 (deferred:call-lambda (deferred:lambda () 1) 1))
137 (should= nil (deferred:call-lambda 'car))
138 (should= 2 (deferred:call-lambda 'car '(2 1)))
139 (should= nil (deferred:call-lambda (symbol-function 'car)))
140 (should= 2 (deferred:call-lambda (symbol-function 'car) '(2 1))))
141
142 (ert-deftest deferred-primitive-scope ()
143 "> call-lambda lexical-scope"
144 (should= 3 (lexical-let ((st 1))
145 (deferred:call-lambda
146 (lambda () (+ st 2)))))
147 (should= 3 (lexical-let ((st 1))
148 (deferred:call-lambda
149 (lambda () (+ st 2)) 0)))
150 (should= 3 (lexical-let ((st 1))
151 (deferred:call-lambda
152 (lambda (x) (+ st 2)))))
153 (should= 3 (lexical-let ((st 1))
154 (deferred:call-lambda
155 (lambda (x) (+ st 2)) 0))))
156
157 (ert-deftest deferred-primitive-compile ()
158 "> call-lambda byte-compile"
159 (should= 1 (deferred:call-lambda (byte-compile (lambda (x) 1))))
160 (should= 1 (deferred:call-lambda (byte-compile (lambda (x) 1)) 1))
161 (should= 1 (deferred:call-lambda (byte-compile (lambda () 1))))
162 (should= 1 (deferred:call-lambda (byte-compile (lambda () 1)) 1))
163
164 (should= 3 (lexical-let ((st 1))
165 (deferred:call-lambda
166 (byte-compile (lambda () (+ st 2))))))
167 (should= 3 (lexical-let ((st 1)) ;ng
168 (deferred:call-lambda
169 (byte-compile (lambda () (+ st 2))) 0)))
170 (should= 3 (lexical-let ((st 1))
171 (deferred:call-lambda
172 (byte-compile (lambda (x) (+ st 2))))))
173 (should= 3 (lexical-let ((st 1)) ;ng
174 (deferred:call-lambda
175 (byte-compile (lambda (x) (+ st 2))) 0)))
176
177 (should-error
178 (deferred:call-lambda
179 (lambda (x) (signal 'wrong-number-of-arguments '("org"))))
180 :type 'wrong-number-of-arguments))
181
182 (ert-deftest deferred-basic ()
183 "Basic test for deferred functions."
184 (should (deferred-p
185 ;; function test
186 (deferred:new)))
187 (should (null
188 ;; basic cancel test
189 (let ((d (deferred:next 'deferred:not-called-func)))
190 (cancelc d)
191 (flush))))
192 (should (deferred-p
193 ;; basic post function test
194 (progn
195 (clear)
196 (lexical-let ((d (dnew)))
197 (nextc d x)
198 (deferred:exec-task d 'ok "ok!")))))
199 (should (deferred-p
200 ;; basic error post function test
201 (progn
202 (clear)
203 (lexical-let ((d (dnew)))
204 (deferred:error d (lambda (e) e))
205 (deferred:exec-task d 'ng "error"))))))
206
207 (ert-deftest deferred-basic-result-propagation ()
208 "> result propagation"
209 (should= 'ok
210 ;; value saving test
211 (let ((d (deferred:succeed 1)))
212 (deferred:status d)))
213
214 (should= 1
215 ;; value saving test
216 (let ((d (deferred:succeed 1)))
217 (deferred-value d)))
218
219 (should= nil
220 ;; value clearing test
221 (let ((d (deferred:succeed 1)))
222 (deferred:set-next d (dnew))
223 (deferred:status d)))
224
225 (should= 1
226 ;; value propagating test
227 (let ((d (deferred:succeed 1))
228 (nd (dnew)))
229 (deferred:set-next d nd)
230 (deferred-value nd))))
231
232 (ert-deftest deferred-basic-error-propagation ()
233 "> error propagation"
234 (should= 'ok
235 ;; value saving test
236 (let ((d (deferred:succeed 1)))
237 (deferred:status d)))
238
239 (should= 1
240 ;; value saving test
241 (let ((d (deferred:succeed 1)))
242 (deferred-value d)))
243
244 (should= nil
245 ;; value clearing test
246 (let ((d (deferred:succeed 1)))
247 (deferred:set-next d (dnew))
248 (deferred:status d)))
249
250 (should= 1
251 ;; value propagating test
252 (let ((d (deferred:succeed 1))
253 (nd (dnew)))
254 (deferred:set-next d nd)
255 (deferred-value nd))))
256
257 (ert-deftest deferred-main-chain ()
258 ">>> Main Test / Chaining"
259
260 (should= '(2 1 0)
261 ;; basic deferred chain test
262 (clear)
263 (lexical-let (vs)
264 ($ (next (push 1 vs))
265 (nextc it (push 2 vs)))
266 (push 0 vs)
267 (flush)
268 vs))
269
270 (should= "errorback called"
271 ;; basic errorback test
272 (dtest (next (error "errorback"))
273 (errorc it (concat (cadr e) " called"))))
274
275 (should= "next callback called"
276 ;; error recovery test
277 (dtest
278 (next (error "callback called"))
279 (errorc it (cadr e))
280 (nextc it (concat "next " x))))
281
282 (should= '(error "second errorback called")
283 ;; error recovery test 2
284 (dtest
285 (next (error "callback called"))
286 (nextc it (deferred:not-called-func "second errorback1"))
287 (errorc it e)
288 (errorc it (deferred:not-called-func "second errorback2"))
289 (nextc it (error "second errorback called"))
290 (nextc it "skipped")
291 (errorc it e)))
292
293 (should= "start errorback ok1"
294 ;; start errorback test1
295 (let (message-log-max)
296 (cl-letf (((symbol-function 'message) (lambda (&rest args) args)))
297 (let ((d (dnew)))
298 (dtest
299 (progn
300 (deferred:errorback d "start errorback") d)
301 (nextc it (deferred:not-called-func "ERROR : start errorback"))
302 (errorc it (cadr e))
303 (nextc it (concat x " ok1")))))))
304
305 (should= "post errorback ok2"
306 ;; start errorback test1
307 (let ((d (dnew)))
308 (dtest
309 (progn (deferred:errorback-post d "post errorback") d)
310 (nextc it (deferred:not-called-func "ERROR : post errorback"))
311 (errorc it (cadr e))
312 (nextc it (concat x " ok2")))))
313
314 (should= "Child deferred chain"
315 ;; child deferred chain test
316 (dtest
317 (next
318 (next "Child deferred chain"))
319 (errorf it "Error on simple chain : %s")))
320
321 (should= "chain watch ok"
322 ;; watch chain: normal
323 (let ((val "><"))
324 (dtest
325 (next "chain")
326 (deferred:watch it
327 (lambda (x) (setq val " watch") nil))
328 (nextc it (concat x val " ok")))))
329
330 (should= "error!! watch ok"
331 ;; watch chain: error
332 (let ((val "><"))
333 (dtest
334 (next "chain")
335 (nextc it (error "error!!"))
336 (deferred:watch it (lambda (x) (setq val " watch") nil))
337 (errorc it (concat (cadr e) val " ok")))))
338
339 (should= "chain watch ok2"
340 ;; watch chain: normal
341 (let ((val "><"))
342 (dtest
343 (next "chain")
344 (deferred:watch it
345 (lambda (x) (error "ERROR")))
346 (nextc it (concat x " watch ok2"))))))
347
348 (ert-deftest deferred-async-connect ()
349 "> async connect"
350 (should= "saved result!"
351 ;; asynchronously connect deferred and propagate a value
352 (let (d ret)
353 (clear)
354 (setq d (next "saved "))
355 (deferred:callback d)
356 (flush)
357 (setq d (nextc d (concat x "result")))
358 (nextc d (setq ret (concat x "!")))
359 ret)))
360
361 (ert-deftest deferred-global-onerror ()
362 "> global onerror"
363 (should= "ONERROR"
364 ;; default onerror handler test
365 (lexical-let (ret)
366 (let ((deferred:onerror
367 (lambda (e) (setq ret (concat "ON" (error-message-string e))))))
368 (dtest
369 (next (error "ERROR")))
370 ret))))
371
372 (ert-deftest deferred-async-call ()
373 "> async call"
374 (should= "ASYNC CALL"
375 ;; basic async 'call' test
376 (dtest
377 (deferred:call 'concat "ASYNC" " " "CALL")))
378
379 (should= "ASYNC APPLY"
380 ;; basic async 'apply' test
381 (dtest
382 (deferred:apply 'concat '("ASYNC" " " "APPLY")))))
383
384 (ert-deftest deferred-wait ()
385 "> wait"
386 (should= "wait ok"
387 ;; basic wait test
388 (dtest
389 (wait 1)
390 (nextc it (if (< x 300) "wait ok" x))
391 (errorf it "Error on simple wait : %s")))
392
393 (should= "waitc ok"
394 ;; wait chain test
395 (dtest
396 (wait 1)
397 (nextc it "wait")
398 (nextc it (wait 1))
399 (nextc it (if (< x 300) "waitc ok" x))
400 (errorf it "Error on simple wait chain : %s")))
401
402 (should= nil
403 ;; wait cancel test
404 (dtest
405 (wait 1000)
406 (cancelc it)
407 (nextc it (deferred:not-called-func "wait cancel"))))
408
409 (should= "wait-idle ok"
410 ;; basic wait test
411 (dtest
412 (deferred:wait-idle 1)
413 (nextc it (if (< x 300) "wait-idle ok" x))
414 (errorf it "Error on simple wait-idle : %s")))
415
416 (should= "wait-idlec ok"
417 ;; wait chain test
418 (dtest
419 (deferred:wait-idle 1)
420 (nextc it "wait")
421 (nextc it (deferred:wait-idle 1))
422 (nextc it (if (< x 300) "wait-idlec ok" x))
423 (errorf it "Error on simple wait-idle chain : %s")))
424
425 (should= nil
426 ;; wait cancel test
427 (dtest
428 (deferred:wait-idle 1000)
429 (cancelc it)
430 (nextc it (deferred:not-called-func "wait-idle cancel")))))
431
432 (ert-deftest deferred-sync-connect ()
433 "> synchronized connection and wait a value"
434 (should= "sync connect1"
435 ;; real time connection1
436 (dtest
437 (deferred:succeed "sync ")
438 (nextc it
439 (concat x "connect1"))))
440
441 (should= "sync connect11"
442 ;; real time connection11
443 (dtest
444 (deferred:succeed "sync ")
445 (nextc it
446 (concat x "connect1"))
447 (nextc it
448 (concat x "1"))))
449
450 (should= "connect2"
451 ;; real time connection1
452 (dtest
453 (deferred:succeed "sync ")
454 (nextc it
455 (next "connect"))
456 (nextc it
457 (concat x "2"))))
458
459 (should= "connect!! GO"
460 ;; real time connection2
461 (dtest
462 (deferred:succeed "sync ")
463 (nextc it
464 ($
465 (next "connect")
466 (nextc it (concat x "!!"))))
467 (nextc it
468 (concat x " GO")))))
469
470 (ert-deftest deferred-try ()
471 "> try-catch-finally"
472
473 (should= "try"
474 ;; try block
475 (dtest
476 (deferred:try
477 (next "try"))))
478
479 (should= "try"
480 ;; try catch block
481 (dtest
482 (deferred:try
483 (next "try")
484 :catch
485 (lambda (e) (concat "CATCH:" e)))))
486
487 (should= "try-finally"
488 ;; try catch finally block
489 (let (val)
490 (dtest
491 (deferred:try
492 (next "try")
493 :finally
494 (lambda (x) (setq val "finally")))
495 (nextc it (concat x "-" val)))))
496
497 (should= "try-finally2"
498 ;; try catch finally block
499 (let (val)
500 (dtest
501 (deferred:try
502 (next "try")
503 :catch
504 (lambda (e) (concat "CATCH:" e))
505 :finally
506 (lambda (x) (setq val "finally2")))
507 (nextc it (concat x "-" val)))))
508
509 (should= "try-catch:err"
510 ;; try block
511 (dtest
512 (deferred:try
513 ($ (next "start")
514 (nextc it (error "err"))
515 (nextc it (deferred:not-called-func x)))
516 :catch
517 (lambda (e) (concat "catch:" (cadr e))))
518 (nextc it (concat "try-" x))))
519
520 (should= "try-catch:err-finally"
521 ;; try catch finally block
522 (let (val)
523 (dtest
524 (deferred:try
525 ($ (next "start")
526 (nextc it (error "err"))
527 (nextc it (deferred:not-called-func x)))
528 :catch
529 (lambda (e) (concat "catch:" (cadr e)))
530 :finally
531 (lambda (x) (setq val "finally")))
532 (nextc it (concat "try-" x "-" val))))))
533
534
535
536 (ert-deftest deferred-loop ()
537 "> loop"
538 (should= 10
539 ;; basic loop test
540 (lexical-let ((v 0))
541 (dtest
542 (dloop 5 (lambda (i) (setq v (+ v i))))
543 (errorf it "Error on simple loop calling : %s"))
544 v))
545
546 (should= "loop ok 4"
547 ;; return value for a loop
548 (dtest
549 (dloop 5 (lambda (i) i))
550 (nextc it (format "loop ok %i" x))
551 (errorf it "Error on simple loop calling : %s")))
552
553 (should= "nested loop ok (4 nil 3 2 1 0)"
554 ;; nested deferred task in a loop
555 (lexical-let (count)
556 (dtest
557 (dloop 5 (lambda (i)
558 (push i count)
559 (if (eql i 3) (next (push x count)))))
560 (nextc it (format "nested loop ok %s" count))
561 (errorf it "Error on simple loop calling : %s"))
562 )
563 )
564
565 (should= '(6 4 2)
566 ;; do-loop test
567 (lexical-let (count)
568 (dtest
569 (dloop '(1 2 3)
570 (lambda (x) (push (* 2 x) count)))
571 (errorf it "Error on do-loop calling : %s"))))
572
573 (should= nil
574 ;; zero times loop test
575 (dtest
576 (dloop 0 (lambda (i) (deferred:not-called-func "zero loop")))))
577
578 (should= nil
579 ;; loop cancel test
580 (dtest
581 (dloop 3 (lambda (i) (deferred:not-called-func "loop cancel")))
582 (cancelc it)))
583
584 (should= "loop error!"
585 ;; loop error recover test
586 (dtest
587 (deferred:loop 5
588 (lambda (i) (if (= 2 i) (error "loop error"))))
589 (nextc it (deferred:not-called-func))
590 (errorc it (format "%s!" (cadr e)))
591 (nextc it x)))
592
593 (should= "loop error catch ok"
594 ;; try catch finally test
595 (lexical-let ((body (lambda ()
596 (deferred:loop 5
597 (lambda (i) (if (= 2 i) (error "loop error")))))))
598 (dtest
599 (next "try ") ; try
600 (nextc it (funcall body)) ; body
601 (errorc it (format "%s catch " (cadr e))) ; catch
602 (nextc it (concat x "ok"))))) ; finally
603
604 (should= "4 ok"
605 ;; try catch finally test
606 (lexical-let ((body (lambda ()
607 (deferred:loop 5
608 (lambda (i) i)))))
609 (dtest
610 (next "try ") ; try
611 (nextc it (funcall body)) ; body
612 (errorc it (format "%s catch " e)) ; catch
613 (nextc it (format "%s ok" x))))) ; finally
614 )
615
616
617
618 (ert-deftest deferred-parallel ()
619 "> parallel"
620 (should= nil
621 ;; nil test
622 (dtest
623 (parallel '())))
624
625 (should= '(1)
626 ;; single job test: argument
627 (dtest
628 (parallel
629 (next 1))))
630
631 (should= '(1)
632 ;; single job test: function
633 (dtest
634 (parallel
635 (lambda () 1))))
636
637 (should= '(1)
638 ;; single job test: list
639 (dtest
640 (parallel
641 (list (next 1)))))
642
643 (should= '((a . 1))
644 ;; single job test: alist
645 (dtest
646 (parallel
647 (list (cons 'a (next 1))))))
648
649 (should= '(0 1)
650 ;; simple parallel test: just return value
651 (dtest
652 (parallel
653 (next 0) (next 1))))
654
655 (should= '(13 14)
656 ;; simple parallel test: list
657 (dtest
658 (parallel
659 (list (next 13)
660 (next 14)))))
661
662 (should= '((a . 20) (b . 30))
663 ;; simple parallel test: alist
664 (dtest
665 (parallel
666 (list (cons 'a (next 20))
667 (cons 'b (next 30))))))
668
669 (should= '(0 1)
670 ;; simple parallel test: function list
671 (dtest
672 (parallel
673 (lambda () 0) (lambda () 1))))
674
675 (should= '(0 1)
676 ;; nested deferred and order change test
677 (dtest
678 (parallel
679 (lambda () (next 0))
680 (next 1))))
681
682 (should= "((error ERROR) OK (error ERROR2))"
683 ;; error handling
684 (dtest
685 (parallel
686 (next (error "ERROR")) (next "OK") (next (error "ERROR2")))
687 (nextc it (format "%s" x))))
688
689 (should= "((error ERROR) (error ERROR2))"
690 ;; failed test
691 (dtest
692 (parallel
693 (next (error "ERROR")) (next (error "ERROR2")))
694 (nextc it (format "%s" x))))
695
696 (should= "((b . OK) (a error ERROR) (c error ERROR2))"
697 ;; error handling
698 (dtest
699 (parallel
700 (cons 'a (next (error "ERROR")))
701 (cons 'b (next "OK"))
702 (cons 'c (next (error "ERROR2"))))
703 (nextc it (format "%s" x))))
704
705 (should= "((a error ERROR) (b error ERROR2))"
706 ;; failed test
707 (dtest
708 (parallel
709 (cons 'a (next (error "ERROR")))
710 (cons 'b (next (error "ERROR2"))))
711 (nextc it (format "%s" x))))
712
713 (should= nil
714 ;; parallel cancel test
715 (dtest
716 (parallel
717 (list (next (deferred:not-called-func "parallel 1"))
718 (next (deferred:not-called-func "parallel 2"))))
719 (cancelc it)))
720
721 (should= "nest parallel ok"
722 ;; parallel next
723 (lexical-let* ((flow (lambda (x)
724 (parallel
725 (next "nest ")
726 (next "parallel ")))))
727 (dtest
728 (next "start ")
729 (nextc it (funcall flow x))
730 (nextc it (apply 'concat x))
731 (nextc it (concat x "ok")))))
732
733 (should= "arrived (1) ok"
734 ;; arrived one deferred
735 (dtest
736 (parallel (deferred:succeed 1))
737 (nextc it (format "arrived %s ok" x))))
738
739 (should= "arrived (1 2) ok"
740 ;; arrived deferreds
741 (dtest
742 (parallel (deferred:succeed 1) (deferred:succeed 2))
743 (nextc it (format "arrived %s ok" x)))))
744
745
746
747 (ert-deftest deferred-earlier ()
748 "> earlier"
749 (should= nil
750 ;; nil test
751 (dtest
752 (earlier '())))
753
754 (should= 1
755 ;; single job test: argument
756 (dtest
757 (earlier
758 (nextc (wait 10) 1))
759 (nextc it x)))
760
761 (should= 1
762 ;; single job test: function
763 (dtest
764 (earlier
765 (lambda () 1))
766 (nextc it x)))
767
768 (should= 1
769 ;; single job test: list
770 (dtest
771 (earlier
772 (list (next 1)))
773 (nextc it x)))
774
775 (should= '(a . 1)
776 ;; single job test: alist
777 (dtest
778 (earlier
779 (list (cons 'a (next 1))))
780 (nextc it x)))
781
782 (should= '0
783 ;; simple earlier test
784 (dtest
785 (earlier
786 (next 0) (next 1))
787 (nextc it x)))
788
789 (should= '11
790 ;; simple earlier test: argument
791 (dtest
792 (earlier
793 (next 11) (next 12))
794 (nextc it x)))
795
796 (should= '13
797 ;; simple earlier test: list
798 (dtest
799 (earlier
800 (list (next 13) (next 14)))
801 (nextc it x)))
802
803 (should= '(a . 20)
804 ;; simple earlier test: alist
805 (dtest
806 (earlier
807 (list (cons 'a (next 20))
808 (cons 'b (next 30))))
809 (nextc it x)))
810
811 (should= '0
812 ;; simple earlier test: function list
813 (dtest
814 (earlier
815 (lambda () 0) (lambda () 1))
816 (nextc it x)))
817
818 (should= '1
819 ;; nested deferred and order change test
820 (dtest
821 (earlier
822 (lambda () (dnew 0))
823 (next 1))))
824
825 (should= "OK"
826 ;; error handling
827 (dtest
828 (earlier
829 (next (error "ERROR")) (next "OK") (next (error "ERROR2")))
830 (nextc it x)))
831
832 (should= nil
833 ;; failed test
834 (dtest
835 (earlier
836 (next (error "ERROR")) (next (error "ERROR2")))
837 (nextc it x)))
838
839 (should= '(b . "OK")
840 ;; error handling
841 (dtest
842 (earlier
843 (cons 'a (next (error "ERROR")))
844 (cons 'b (next "OK"))
845 (cons 'c (next (error "ERROR2"))))
846 (nextc it x)))
847
848 (should= nil
849 ;; failed test
850 (dtest
851 (earlier
852 (cons 'a (next (error "ERROR")))
853 (cons 'b (next (error "ERROR2"))))
854 (nextc it x)))
855
856 (should= nil
857 ;; cancel test
858 (dtest
859 (earlier
860 (list (next (deferred:not-called-func "earlier 1"))
861 (next (deferred:not-called-func "earlier 2"))))
862 (cancelc it)))
863
864 (should= "arrived 1 ok"
865 ;; arrived one deferred
866 (dtest
867 (earlier (deferred:succeed 1))
868 (nextc it (format "arrived %s ok" x))))
869
870 (should= "arrived 1 ok"
871 ;; arrived deferreds
872 (dtest
873 (earlier (deferred:succeed 1) (deferred:succeed 2))
874 (nextc it (format "arrived %s ok" x)))))
875
876 (ert-deftest deferred-sync! ()
877 (should= "foo"
878 (deferred:$
879 (deferred:next
880 (lambda ()
881 "foo"))
882 (deferred:sync! it))))
883
884 ;; process
885
886 (ert-deftest deferred-process ()
887 "> Process"
888 (should=
889 (with-temp-buffer
890 (call-process "pwd" nil t nil)
891 (buffer-string))
892 (wtest 0.1 ;; maybe fail in some environments...
893 (deferred:process "pwd")))
894
895 (should=
896 (with-temp-buffer
897 (call-process "pwd" nil t nil)
898 (buffer-string))
899 (wtest 0.1 ;; maybe fail in some environments...
900 (deferred:process "pwd" nil)))
901
902 (should=
903 (length (buffer-list))
904 (deferred:cancel (deferred:process "pwd" nil))
905 (length (buffer-list)))
906
907 (should= 0
908 (dtest
909 (deferred:process "pwd---")
910 (nextc it (deferred:not-called-func))
911 (errorc it (string-match "^Searching for program" (cadr e)))))
912
913 (should=
914 (with-temp-buffer (call-process "pwd" nil t nil)
915 (buffer-string))
916 (wtest 0.1
917 (wait 0.1)
918 (deferred:processc it "pwd" nil)))
919
920 (should=
921 (with-temp-buffer
922 (call-process "ls" nil t "-1")
923 (buffer-string))
924 (wtest 0.1 ;; maybe fail in some environments...
925 (deferred:process-buffer "ls" "-1")
926 (nextc it
927 (unless (buffer-live-p x)
928 (error "Not live buffer : %s" x))
929 (with-current-buffer x (buffer-string)))))
930
931 (should=
932 (with-temp-buffer
933 (call-process "ls" nil t "-1")
934 (buffer-string))
935 (wtest 0.1 ;; maybe fail in some environments...
936 (wait 0.1)
937 (deferred:process-bufferc it "ls" "-1")
938 (nextc it
939 (unless (buffer-live-p x)
940 (error "Not live buffer : %s" x))
941 (with-current-buffer x (buffer-string)))))
942
943 (should=
944 (length (buffer-list))
945 (deferred:cancel (deferred:process-buffer "ls" nil))
946 (length (buffer-list)))
947
948 (should= 0
949 (dtest
950 (deferred:process-buffer "pwd---")
951 (nextc it (deferred:not-called-func))
952 (errorc it (string-match "^Searching for program" (cadr e)))))
953
954 ;;shell
955
956 (should=
957 (with-temp-buffer
958 (call-process-shell-command "pwd" nil t nil)
959 (buffer-string))
960 (wtest 0.1 ;; maybe fail in some environments...
961 (deferred:process-shell "pwd")))
962
963 (should=
964 (with-temp-buffer
965 (call-process-shell-command "pwd" nil t nil)
966 (buffer-string))
967 (wtest 0.1 ;; maybe fail in some environments...
968 (deferred:process-shell "pwd" nil)))
969
970 (should=
971 (length (buffer-list))
972 (deferred:cancel (deferred:process-shell "pwd" nil))
973 (length (buffer-list)))
974
975 (should= "ERROR"
976 (wtest 0.1
977 (deferred:process-shell "lsasfdsadf")
978 (nextc it (deferred:not-called-func))
979 (errorc it "ERROR")))
980
981 (should=
982 (with-temp-buffer (call-process-shell-command "pwd" nil t nil)
983 (buffer-string))
984 (wtest 0.1
985 (wait 0.1)
986 (deferred:process-shellc it "pwd" nil)))
987
988 (should=
989 (with-temp-buffer
990 (call-process-shell-command "ls" nil t "-1")
991 (buffer-string))
992 (wtest 0.1 ;; maybe fail in some environments...
993 (deferred:process-shell-buffer "ls" "-1")
994 (nextc it
995 (unless (buffer-live-p x)
996 (error "Not live buffer : %s" x))
997 (with-current-buffer x (buffer-string)))))
998
999 (should=
1000 (with-temp-buffer
1001 (call-process-shell-command "ls" nil t "-1")
1002 (buffer-string))
1003 (wtest 0.1 ;; maybe fail in some environments...
1004 (wait 0.1)
1005 (deferred:process-shell-bufferc it "ls" "-1")
1006 (nextc it
1007 (unless (buffer-live-p x)
1008 (error "Not live buffer : %s" x))
1009 (with-current-buffer x (buffer-string)))))
1010
1011 (should=
1012 (length (buffer-list))
1013 (deferred:cancel (deferred:process-shell-buffer "ls" nil))
1014 (length (buffer-list)))
1015
1016 (should= "ERROR"
1017 (wtest 0.1
1018 (deferred:process-shell-buffer "lssaf")
1019 (nextc it (deferred:not-called-func))
1020 (errorc it "ERROR"))))