1## -- Tcl Module -- -*- tcl -*-
2# # ## ### ##### ######## #############
3
4# @@ Meta Begin
5# Package coroutine::auto 1.1.2
6# Meta platform        tcl
7# Meta require         {Tcl 8.6}
8# Meta require         {coroutine 1.1}
9# Meta license         BSD
10# Meta as::author      {Andreas Kupries}
11# Meta as::origin      http://wiki.tcl.tk/21555
12# Meta summary         Coroutine Event and Channel Support
13# Meta description     Built on top of coroutine, this
14# Meta description     package intercepts various builtin
15# Meta description     commands to make the code using them
16# Meta description     coroutine-oblivious, i.e. able to run
17# Meta description     inside and outside of a coroutine
18# Meta description     without changes.
19# @@ Meta End
20
21# Copyright (c) 2009-2014 Andreas Kupries
22
23## $Id: coro_auto.tcl,v 1.3 2011/11/17 08:00:45 andreas_kupries Exp $
24# # ## ### ##### ######## #############
25## Requisites, and ensemble setup.
26
27package require Tcl 8.6
28package require coroutine
29
30namespace eval ::coroutine::auto {}
31
32# # ## ### ##### ######## #############
33## API implementations. Uses the coroutine commands where
34## possible.
35
36proc ::coroutine::auto::wrap_global {args} {
37    if {[info coroutine] eq {}} {
38	tailcall ::coroutine::auto::core_global {*}$args
39    }
40
41    tailcall ::coroutine::util::global {*}$args
42}
43
44# - -- --- ----- -------- -------------
45
46proc ::coroutine::auto::wrap_after {delay args} {
47    if {
48	([info coroutine] eq {}) ||
49	([llength $args] > 0)
50    } {
51	# We use the core builtin when called from either outside of a
52	# coroutine, or for an asynchronous delay.
53
54	tailcall ::coroutine::auto::core_after $delay {*}$args
55    }
56
57    # Inside of coroutine, and synchronous delay (args == "").
58    tailcall ::coroutine::util::after $delay
59}
60
61# - -- --- ----- -------- -------------
62
63proc ::coroutine::auto::wrap_exit {{status 0}} {
64    if {[info coroutine] eq {}} {
65	tailcall ::coroutine::auto::core_exit $status
66    }
67
68    tailcall ::coroutine::util::exit $status
69}
70
71# - -- --- ----- -------- -------------
72
73proc ::coroutine::auto::wrap_vwait {varname} {
74    if {[info coroutine] eq {}} {
75	tailcall ::coroutine::auto::core_vwait $varname
76    }
77
78    tailcall ::coroutine::util::vwait $varname
79}
80
81# - -- --- ----- -------- -------------
82
83proc ::coroutine::auto::wrap_update {{what {}}} {
84    if {[info coroutine] eq {}} {
85	tailcall ::coroutine::auto::core_update {*}$what
86    }
87
88    # This is a full re-implementation of mode (1), because the
89    # coroutine-aware part uses the builtin itself for some
90    # functionality, and this part cannot be taken as is.
91
92    if {$what eq "idletasks"} {
93        after idle [info coroutine]
94    } elseif {$what ne {}} {
95        # Force proper error message for bad call.
96        tailcall ::coroutine::auto::core_update $what
97    } else {
98        after 0 [info coroutine]
99    }
100    yield
101    return
102}
103
104# - -- --- ----- -------- -------------
105
106proc ::coroutine::auto::wrap_gets {args} {
107    # Process arguments.
108    # Acceptable syntax:
109    # * gets CHAN ?VARNAME?
110
111    if {[info coroutine] eq {}} {
112	tailcall ::coroutine::auto::core_gets {*}$args
113    }
114
115    # This is a full re-implementation of mode (1), because the
116    # coroutine-aware part uses the builtin itself for some
117    # functionality, and this part cannot be taken as is.
118
119    if {[llength $args] == 2} {
120	# gets CHAN VARNAME
121	lassign $args chan varname
122        upvar 1 $varname line
123    } elseif {[llength $args] == 1} {
124	# gets CHAN
125	lassign $args chan
126    } else {
127	# not enough, or too many arguments (0, or > 2): Calling the
128	# builtin gets command with the bogus arguments gives us the
129	# necessary error with the proper message.
130	tailcall ::coroutine::auto::core_gets {*}$args
131    }
132
133    # Loop until we have a complete line. Yield to the event loop
134    # where necessary. During
135
136    while {1} {
137        set blocking [::chan configure $chan -blocking]
138        ::chan configure $chan -blocking 0
139
140	try {
141	    set result [::coroutine::auto::core_gets $chan line]
142	} on error {result opts} {
143            ::chan configure $chan -blocking $blocking
144            return -code $result -options $opts
145	}
146
147	if {[::chan blocked $chan]} {
148            ::chan event $chan readable [list [info coroutine]]
149            yield
150            ::chan event $chan readable {}
151        } else {
152            ::chan configure $chan -blocking $blocking
153
154            if {[llength $args] == 2} {
155                return $result
156            } else {
157                return $line
158            }
159        }
160    }
161}
162
163# - -- --- ----- -------- -------------
164
165proc ::coroutine::auto::wrap_read {args} {
166    # Process arguments.
167    # Acceptable syntax:
168    # * read ?-nonewline ? CHAN
169    # * read               CHAN ?n?
170
171    if {[info coroutine] eq {}} {
172	tailcall ::coroutine::auto::core_read {*}$args
173    }
174
175    # This is a full re-implementation of mode (1), because the
176    # coroutine-aware part uses the builtin itself for some
177    # functionality, and this part cannot be taken as is.
178
179    if {[llength $args] > 2} {
180	# Calling the builtin read command with the bogus arguments
181	# gives us the necessary error with the proper message.
182	::coroutine::auto::core_read {*}$args
183	return
184    }
185
186    set total Inf ; # Number of characters to read. Here: Until eof.
187    set chop  no  ; # Boolean flag. Determines if we have to trim a
188    #               # \n from the end of the read string.
189
190    if {[llength $args] == 2} {
191	lassign $args a b
192	if {$a eq "-nonewline"} {
193	    set chan $b
194	    set chop yes
195	} else {
196	    lassign $args chan total
197	}
198    } else {
199	lassign $args chan
200    }
201
202    # Run the read loop. Yield to the event loop where
203    # necessary. Differentiate between loop until eof, and loop until
204    # n characters have been read (or eof reached).
205
206    set buf {}
207
208    if {$total eq "Inf"} {
209	# Loop until eof.
210
211	while {1} {
212	    set blocking [::chan configure $chan -blocking]
213	    ::chan configure $chan -blocking 0
214
215	    try {
216		set result [::coroutine::auto::core_read $chan]
217	    } on error {result opts} {
218		::chan configure $chan -blocking $blocking
219		return -code $result -options $opts
220	    }
221
222	    if {[::chan blocked $chan]} {
223		::chan event $chan readable [list [info coroutine]]
224		yield
225		::chan event $chan readable {}
226	    } else {
227		::chan configure $chan -blocking $blocking
228		append buf $result
229
230		if {[::chan eof $chan]} {
231		    ::chan close $chan
232		    break
233		}
234	    }
235	}
236    } else {
237	# Loop until total characters have been read, or eof found,
238	# whichever is first.
239
240	set left $total
241	while {1} {
242	    set blocking [::chan configure $chan -blocking]
243	    ::chan configure $chan -blocking 0
244
245	    try {
246		set result [::coroutine::auto::core_read $chan $left]
247	    } on error {result opts} {
248		::chan configure $chan -blocking $blocking
249		return -code $result -options $opts
250	    }
251
252	    if {[::chan blocked $chan]} {
253		::chan event $chan readable [list [info coroutine]]
254		yield
255		::chan event $chan readable {}
256	    } else {
257		::chan configure $chan -blocking $blocking
258		append buf $result
259		incr   left -[string length $result]
260
261		if {[::chan eof $chan]} {
262		    ::chan close $chan
263		    break
264		} elseif {!$left} {
265		    break
266		}
267	    }
268	}
269    }
270
271    if {$chop && [string index $buf end] eq "\n"} {
272	set buf [string range $buf 0 end-1]
273    }
274
275    return $buf
276}
277
278# # ## ### ##### ######## #############
279## Internal. Setup.
280
281::apply {{} {
282    # Replaces the builtin commands with coroutine-aware
283    # counterparts. We cannot use the coroutine commands directly,
284    # because the replacements have to use the saved builtin commands
285    # when called outside of a coroutine. And some (read, gets,
286    # update) even need full re-implementations, as they use the
287    # builtin command they replace themselves to implement their
288    # functionality.
289
290    foreach cmd {
291	global
292	exit
293	after
294	vwait
295	update
296    } {
297	rename ::$cmd [namespace current]::core_$cmd
298	rename [namespace current]::wrap_$cmd ::$cmd
299    }
300
301    foreach cmd {
302	gets
303	read
304    } {
305	rename ::tcl::chan::$cmd [namespace current]::core_$cmd
306	rename [namespace current]::wrap_$cmd ::tcl::chan::$cmd
307    }
308
309    return
310} ::coroutine::auto}
311
312# # ## ### ##### ######## #############
313## Ready
314
315package provide coroutine::auto 1.1.3
316return
317