ycl

Check-in [d24d8665d0]
Login

Check-in [d24d8665d0]

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:{ycl coro batch} {new package} {ycl coro call} {new package}
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: d24d8665d0111a8f79179ff0ff8bb0055dad3261
User & Date: pooryorick 2017-08-04 18:21:54.935
Context
2017-08-05
20:32
{ycl coro call} {refactor [reply]} check-in: 59c9a72c4e user: pooryorick tags: trunk
2017-08-04
18:21
{ycl coro batch} {new package} {ycl coro call} {new package} check-in: d24d8665d0 user: pooryorick tags: trunk
18:20
{ycl coro async} {removed after transfering to {ycl coro call}} check-in: 49d75f7d27 user: pooryorick tags: trunk
Changes
Unified Diff Ignore Whitespace Patch
Added packages/coro/demo/http_ordertimeout. 


















































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56

#! /bin/env tclsh

package require http

package require {ycl coro relay}
namespace import [yclprefix]::coro::relay

namespace eval doc {}

coroutine geturl apply [list {} {
	while 1 {
		relay accept {deliver url}
		# Because this coroutine uses [yield] directly, [accept] only 1 order
		# should be made to it .
		coroutine geturl_[info cmdcount] apply [list {deliver url} {

			# Synthesize delay for the purpose of the demo
			after 5000 [list [info coroutine]]
			yield

			http::geturl $url -command [info coroutine]
			set token [yield]

			{*}$deliver [http::data $token]
		} [namespace current]] $deliver $url
	}
} [namespace current]]


variable doc::main {
	description {
		Retrieve each URL specified on the command line and print a dictionary
		mapping thee URL to its contents .
	}
}
coroutine main apply [list {argv0 argv} {
	set orders {}
	foreach url $argv {
		dict set orders [relay order [list 0 1000] geturl $url] $url
	}

	foreach unused [dict keys [relay pending]] {
		set result [relay receive]
		lappend results [dict get $orders [relay last]] $result
		dict unset orders [relay last]
	}
	puts $results

	# Cancel any outstanding orders
	puts [list cancelling orders $orders]
	relay cancel orders $orders 

	exit 0
}] $argv0 $argv

vwait forever
Added packages/coro/lib/batch/batch.tcl. 


























































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44

#! /bin/env tclsh

package require {ycl coro call}
namespace import [yclprefix]::coro::call::call
namespace import [yclprefix]::coro::call::final

proc add args {
	variable task
	set id [info cmdcount]
	set after [after idle [list after 0] ::coroutine [namespace current]::[
		info cmdcount] [namespace current]::runner $id [info coroutine] [
			uplevel 1 {namespace current}] $args]
	dict set task $id after $after
	return $id
}

proc cancel args {
	variable task
	foreach arg $args {
		if {[dict exists $task $arg]} {
			after cancel [dict get $task $arg]
			dict unset task $arg
		}
	}
}


proc runner {id caller ns cmd} {
	variable task
	set res [namespace eval $ns [list [namespace which call] {*}$cmd]]
	if {[dict exists $task $id]} {
		dict unset task $id
		tailcall $caller {*}$res
	} else {
		# task was canceled in the meantime
	}
}

proc wait {} {
	return {*}[yieldto return -level 0 [info coroutine]]
}

set task [dict create]
Added packages/coro/lib/batch/test. 
















>
>
>
>
>
>
>

1
2
3
4
5
6
7

#! /bin/env tclsh

package require {ycl coro batch test}
[yclprefix] test main $argv0 $argv {
	[yclprefix]::coro::batch::test::suite_main
}
Added packages/coro/lib/batch/test.tcl. 






























































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46

#! /bin/env tclsh

package require {ycl test}

proc suite_main {} {
	package require {ycl list}
	namespace import [yclprefix]::list::sl
	package require {ycl coro batch}
	namespace import [yclprefix]::coro::batch::add
	namespace import [yclprefix]::coro::batch::wait
	package require {ycl coro call}
	namespace import [yclprefix]::coro::call::call
	namespace import [yclprefix]::coro::call::reply
	namespace import [yclprefix]::coro::call::final

	[yclprefix] test init
	namespace import [yclprefix]::test::cleanup1

	test basic {} -setup {} -body {
		variable res

		proc c1 value {
			coroutine c1_[info cmdcount] ::apply [list value {
				reply
				after 100 [list [info coroutine]]
				reply [expr {$value * $value}] 
			} [namespace current]] $value
		}

		coroutine c2 ::apply [list args {
			yield [info coroutine]
			add [c1 8]
			add [c1 5]
			lappend res [wait]
			lappend res [wait]
			set [namespace current]::res $res
		} [namespace current]]
		after 0 [list [namespace which c2]]
		vwait [namespace current]::res
		return $res
	} -cleanup [cleanup1] -result [sl {
		64 25
	}]

	cleanupTests
}
Added packages/coro/lib/call/call.tcl. 






























































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46

#! /bin/env tclsh

proc call {cmd args} {
	return {*}[uplevel 1 [list yieldto {*}$cmd [info coroutine] {*}$args]]
}

proc called cmd {
	set ns [uplevel 1 {namespace current}]
	while 1 {
		set orig ${ns}::${cmd}_[info cmdcount]
		if {[namespace which $orig] eq {}} {
			break
		}
	}
	uplevel 1 [list rename $cmd $orig]
	uplevel 1 [list ::apply [list {cmd orig call} {
		proc $cmd args [string map [list @orig@ [list $orig] @call@ [list $call]] {
			@call@ @orig@ {*}$args
		}]
	} $ns] $cmd $orig [namespace which call]] 
}

proc bye args {
	rename [info coroutine] {}
	uplevel 1 [list [namespace which reply] -code break {*}$args]
}

proc reply args {
	variable callervar
	upvar #1 $callervar caller
	if {[llength $args]} {
		set res [lassign [uplevel 1 [list ::yieldto $caller {*}$args]] caller]
		# debug1
		if 1 {
			if {[string is list $caller] && ![llength $caller] || $caller eq {}} {
				return -code error [list {no caller}]
			}
		}
		return $res
	} else {
		set res [lassign [yieldto return -level 0 [info coroutine]] caller]
		return $res
	}
}

variable callervar 19IWj=dpgH0PAw^d8i41bwaAVkR73mJiIWgPQm8fOp
Added packages/coro/lib/call/test. 
















>
>
>
>
>
>
>

1
2
3
4
5
6
7

#! /bin/env tclsh

package require {ycl coro call test}
[yclprefix] test main $argv0 $argv {
	[yclprefix]::coro::call::test::suite_main
}
Added packages/coro/lib/call/test.tcl. 












































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149


#! /bin/env tclsh

package require {ycl shelf shelf}
namespace import [yclprefix]::shelf::shelf
package require {ycl test}

proc suite_main {} {
	package require {ycl list}
	namespace import [yclprefix]::list::sl
	package require {ycl coro call}
	namespace import [yclprefix]::coro::call::call
	namespace import [yclprefix]::coro::call::bye
	namespace import [yclprefix]::coro::call::reply
	namespace import [yclprefix]::coro::call::called

	[yclprefix] test init
	namespace import [yclprefix]::test::cleanup1

	test called {} -setup {} -body {
		variable res
		coroutine c1 ::apply [list args {
			reply
			after 1000 [list [info coroutine]]
			yield
			reply 5
		} [namespace current]]
		called c1

		coroutine c2 ::apply [list args {
			variable res
			yield
			lappend res [c1]
		} [namespace current]]
		after 0 [list [namespace which c2]]
		vwait [namespace current]::res
		return $res
	} -cleanup [cleanup1] -result [sl {
		5
	}]

	test basic {} -setup {} -body {
		variable res

		coroutine c1 ::apply [list args {
			reply
			after 100 [list [info coroutine]]
			yield
			set args [reply 5]
		} [namespace current]]

		coroutine c2 ::apply [list args {
			variable res
			yield
			set res [call c1]
		} [namespace current]]
		after 0 [list [namespace which c2]]
		vwait [namespace current]::res
		return $res
	} -cleanup [cleanup1] -result [sl {
		5
	}]

	test break {} -setup {} -body {
		variable res

		coroutine c1 ::apply [list args {
			reply 
			after 100 [list [info coroutine]]
			yield
			set args [reply 5]
			bye
		} [namespace current]]

		coroutine c2 ::apply [list args {
			yield
			variable res
			set new {}
			while 1  {
				lappend new [call c1]
			}
			lappend res $new
		} [namespace current]]
		after 0 [list [namespace which c2]]
		vwait [namespace current]::res
		lappend res [namespace which c1]
		return $res
	} -cleanup [cleanup1] -result [sl {
		5 {}
	}]

	test multi {} -setup {} -body {
		variable res
		coroutine c1 ::apply [list args {
			reply
			after 100 [list [info coroutine]]
			yield
			reply 5
			after 100 [list [info coroutine]]
			yield
			reply 10
			reply -code break
			reply 20
			reply -code break
		} [namespace current]]

		coroutine c2 ::apply [list args {
			variable res
			yield
			while 1 {
				lappend new [call c1]
			}
			while 1 {
				lappend new [call c1]
			}
			set res $new
		} [namespace current]]
		after 0 [list [namespace which c2]]
		vwait [namespace current]::res
		return $res
	} -cleanup [cleanup1] -result [sl {
		5 10 20
	}]
	
	test error {} -setup {} -body {
		variable res
		coroutine c1 ::apply [list args {
			reply
			after 100 [list [info coroutine]]
			yield
			catch {abadcommand} cres copts
			reply -options $copts $cres
		} [namespace current]]

		coroutine c2 ::apply [list args {
			variable res
			yield
			catch {call c1} cres opts
			lappend res [dict get $opts -code] $cres
		} [namespace current]]
		after 0 [list [namespace which c2]]
		vwait [namespace current]::res
		return $res
	} -cleanup [cleanup1] -result [sl {
		1 {invalid command name "abadcommand"}
	}]

	cleanupTests
}
Added packages/coro/lib/relay/71.