diff options
Diffstat (limited to 'tcllib/modules/coroutine/coro_auto.tcl')
| -rw-r--r-- | tcllib/modules/coroutine/coro_auto.tcl | 316 |
1 files changed, 316 insertions, 0 deletions
diff --git a/tcllib/modules/coroutine/coro_auto.tcl b/tcllib/modules/coroutine/coro_auto.tcl new file mode 100644 index 0000000..e1e87f5 --- /dev/null +++ b/tcllib/modules/coroutine/coro_auto.tcl @@ -0,0 +1,316 @@ +## -- Tcl Module -- -*- tcl -*- +# # ## ### ##### ######## ############# + +# @@ Meta Begin +# Package coroutine::auto 1.1.2 +# Meta platform tcl +# Meta require {Tcl 8.6} +# Meta require {coroutine 1.1} +# Meta license BSD +# Meta as::author {Andreas Kupries} +# Meta as::origin http://wiki.tcl.tk/21555 +# Meta summary Coroutine Event and Channel Support +# Meta description Built on top of coroutine, this +# Meta description package intercepts various builtin +# Meta description commands to make the code using them +# Meta description coroutine-oblivious, i.e. able to run +# Meta description inside and outside of a coroutine +# Meta description without changes. +# @@ Meta End + +# Copyright (c) 2009-2014 Andreas Kupries + +## $Id: coro_auto.tcl,v 1.3 2011/11/17 08:00:45 andreas_kupries Exp $ +# # ## ### ##### ######## ############# +## Requisites, and ensemble setup. + +package require Tcl 8.6 +package require coroutine + +namespace eval ::coroutine::auto {} + +# # ## ### ##### ######## ############# +## API implementations. Uses the coroutine commands where +## possible. + +proc ::coroutine::auto::wrap_global {args} { + if {[info coroutine] eq {}} { + tailcall ::coroutine::auto::core_global {*}$args + } + + tailcall ::coroutine::util::global {*}$args +} + +# - -- --- ----- -------- ------------- + +proc ::coroutine::auto::wrap_after {delay args} { + if { + ([info coroutine] eq {}) || + ([llength $args] > 0) + } { + # We use the core builtin when called from either outside of a + # coroutine, or for an asynchronous delay. + + tailcall ::coroutine::auto::core_after $delay {*}$args + } + + # Inside of coroutine, and synchronous delay (args == ""). + tailcall ::coroutine::util::after $delay +} + +# - -- --- ----- -------- ------------- + +proc ::coroutine::auto::wrap_exit {{status 0}} { + if {[info coroutine] eq {}} { + tailcall ::coroutine::auto::core_exit $status + } + + tailcall ::coroutine::util::exit $status +} + +# - -- --- ----- -------- ------------- + +proc ::coroutine::auto::wrap_vwait {varname} { + if {[info coroutine] eq {}} { + tailcall ::coroutine::auto::core_vwait $varname + } + + tailcall ::coroutine::util::vwait $varname +} + +# - -- --- ----- -------- ------------- + +proc ::coroutine::auto::wrap_update {{what {}}} { + if {[info coroutine] eq {}} { + tailcall ::coroutine::auto::core_update {*}$what + } + + # This is a full re-implementation of mode (1), because the + # coroutine-aware part uses the builtin itself for some + # functionality, and this part cannot be taken as is. + + if {$what eq "idletasks"} { + after idle [info coroutine] + } elseif {$what ne {}} { + # Force proper error message for bad call. + tailcall ::coroutine::auto::core_update $what + } else { + after 0 [info coroutine] + } + yield + return +} + +# - -- --- ----- -------- ------------- + +proc ::coroutine::auto::wrap_gets {args} { + # Process arguments. + # Acceptable syntax: + # * gets CHAN ?VARNAME? + + if {[info coroutine] eq {}} { + tailcall ::coroutine::auto::core_gets {*}$args + } + + # This is a full re-implementation of mode (1), because the + # coroutine-aware part uses the builtin itself for some + # functionality, and this part cannot be taken as is. + + if {[llength $args] == 2} { + # gets CHAN VARNAME + lassign $args chan varname + upvar 1 $varname line + } elseif {[llength $args] == 1} { + # gets CHAN + lassign $args chan + } else { + # not enough, or too many arguments (0, or > 2): Calling the + # builtin gets command with the bogus arguments gives us the + # necessary error with the proper message. + tailcall ::coroutine::auto::core_gets {*}$args + } + + # Loop until we have a complete line. Yield to the event loop + # where necessary. During + + while {1} { + set blocking [::chan configure $chan -blocking] + ::chan configure $chan -blocking 0 + + try { + set result [::coroutine::auto::core_gets $chan line] + } on error {result opts} { + ::chan configure $chan -blocking $blocking + return -code $result -options $opts + } + + if {[::chan blocked $chan]} { + ::chan event $chan readable [list [info coroutine]] + yield + ::chan event $chan readable {} + } else { + ::chan configure $chan -blocking $blocking + + if {[llength $args] == 2} { + return $result + } else { + return $line + } + } + } +} + +# - -- --- ----- -------- ------------- + +proc ::coroutine::auto::wrap_read {args} { + # Process arguments. + # Acceptable syntax: + # * read ?-nonewline ? CHAN + # * read CHAN ?n? + + if {[info coroutine] eq {}} { + tailcall ::coroutine::auto::core_read {*}$args + } + + # This is a full re-implementation of mode (1), because the + # coroutine-aware part uses the builtin itself for some + # functionality, and this part cannot be taken as is. + + if {[llength $args] > 2} { + # Calling the builtin read command with the bogus arguments + # gives us the necessary error with the proper message. + ::coroutine::auto::core_read {*}$args + return + } + + set total Inf ; # Number of characters to read. Here: Until eof. + set chop no ; # Boolean flag. Determines if we have to trim a + # # \n from the end of the read string. + + if {[llength $args] == 2} { + lassign $args a b + if {$a eq "-nonewline"} { + set chan $b + set chop yes + } else { + lassign $args chan total + } + } else { + lassign $args chan + } + + # Run the read loop. Yield to the event loop where + # necessary. Differentiate between loop until eof, and loop until + # n characters have been read (or eof reached). + + set buf {} + + if {$total eq "Inf"} { + # Loop until eof. + + while {1} { + set blocking [::chan configure $chan -blocking] + ::chan configure $chan -blocking 0 + + try { + set result [::coroutine::auto::core_read $chan] + } on error {result opts} { + ::chan configure $chan -blocking $blocking + return -code $result -options $opts + } + + if {[::chan blocked $chan]} { + ::chan event $chan readable [list [info coroutine]] + yield + ::chan event $chan readable {} + } else { + ::chan configure $chan -blocking $blocking + append buf $result + + if {[::chan eof $chan]} { + ::chan close $chan + break + } + } + } + } else { + # Loop until total characters have been read, or eof found, + # whichever is first. + + set left $total + while {1} { + set blocking [::chan configure $chan -blocking] + ::chan configure $chan -blocking 0 + + try { + set result [::coroutine::auto::core_read $chan $left] + } on error {result opts} { + ::chan configure $chan -blocking $blocking + return -code $result -options $opts + } + + if {[::chan blocked $chan]} { + ::chan event $chan readable [list [info coroutine]] + yield + ::chan event $chan readable {} + } else { + ::chan configure $chan -blocking $blocking + append buf $result + incr left -[string length $result] + + if {[::chan eof $chan]} { + ::chan close $chan + break + } elseif {!$left} { + break + } + } + } + } + + if {$chop && [string index $buf end] eq "\n"} { + set buf [string range $buf 0 end-1] + } + + return $buf +} + +# # ## ### ##### ######## ############# +## Internal. Setup. + +::apply {{} { + # Replaces the builtin commands with coroutine-aware + # counterparts. We cannot use the coroutine commands directly, + # because the replacements have to use the saved builtin commands + # when called outside of a coroutine. And some (read, gets, + # update) even need full re-implementations, as they use the + # builtin command they replace themselves to implement their + # functionality. + + foreach cmd { + global + exit + after + vwait + update + } { + rename ::$cmd [namespace current]::core_$cmd + rename [namespace current]::wrap_$cmd ::$cmd + } + + foreach cmd { + gets + read + } { + rename ::tcl::chan::$cmd [namespace current]::core_$cmd + rename [namespace current]::wrap_$cmd ::tcl::chan::$cmd + } + + return +} ::coroutine::auto} + +# # ## ### ##### ######## ############# +## Ready + +package provide coroutine::auto 1.1.3 +return |