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