NEM 2009-07-31: Here's a simple interactive tclsh-style application, with the difference that it runs inside a coroutine. This allows you to have complex event-driven interactions appear as if they are happening in a blocking, non-event-driven manner. For example, you can have Tk GUI applications responding to events while you are apparently in a blocking HTTP request.
# corotcl --
#
# A coroutine-enabled tclsh
#
package require Tk
proc lambda {params body args} {
list ::apply [list $params $body] {*}$args
}
proc prompt p {
puts -nonewline "$p "
flush stdout
fileevent stdin readable [lambda return {
$return [gets stdin]
} [info coroutine]]
yield
}
proc get-command {} {
set cmd [prompt %]
while {![info complete $cmd]} {
append cmd \n [prompt >]
}
return $cmd
}
proc repl {} {
while 1 {
set cmd [get-command]
set code [catch { uplevel #0 $cmd } result opts]
if {$code == 1} {
puts [dict get $opts -errorinfo]
} else { puts $result }
}
}
coroutine main repl
#vwait forever ;# if no TkAn example of use. First, we bring up a simple Tk interface to check that everything keeps running in the background:
% pack [button .b -text Test -command {puts Test}]
.bTesting this will show that it does print "Test" in the console when clicked. So far, so normal. Now, we create a coroutine-enabled version of http::geturl:
% package require http
2.7.2
% proc fetch url {
> http::geturl $url -command [info coroutine]
> yield
> }We can now use this to fetch data from the web, just like the usual geturl. The difference is that this works in the background: you can still click on the Tk button and it will still print to the console even while the fetch is still in progress:
% set t [fetch http://wiki.tcl.tk/4] Test Test Test ::http::1
There we go: an interactive Tcl interpreter that is fully coroutine enabled.
Next step? Futures?
CMcC - 2009-07-31 11:36:54
Very cool.
Here's a variant which uses a TclOO object called Shell so one can have multiple of these constructed with different chans as i/o. If you construct it with a 'port' argument, it'll listen on localhost.
# Shell -- a coroutine enabled tcl evaluator # # From Neil Madden's corotcl http://wiki.tcl.tk/24060 # # Usage: # # Shell new - create a shell listening on stdio # Shell new in $chan out $chan - shell connected to chan # Shell new port $port - shell server on localhost port $port
package require TclOO namespace import oo::*
package provide Shell
class create Shell {
variable interp
constructor {args} {
# prompt for input, collect it and return
proc prompt {in out p} {
puts -nonewline $out "$p "
chan flush $out
chan event $in readable [list ::apply {{return in} {
$return [gets $in]
}} [info coroutine] $in]
return [yield]
}
# read-eval-print loop - prompt, gets input, evaluate it, print result
proc repl {self in out} {
variable interp
while {1} {
set cmd [prompt $in $out %]
while {![info complete $cmd]} {
append cmd \n [prompt $in $out >]
}
try {
{*}$interp $cmd
} on error {result eo} {
puts $out [dict get $eo -errorinfo]
} on return {result} {
break
} on ok {result} {
puts $out $result
}
}
# close the i/o unless it's stdio
if {$in ne "stdin"} {
chan close $in read
} else {
chan event $in readable {} ;# stop listening to stdin
}
if {![string match std* $out]} {
chan close $in write
}
return $result
}
set interp {uplevel #0}
set in stdin; set out "";# default - use stdio
set host localhost ;# default - listen only to localhost
dict with args {
if {[info exists port]} {
# what is wanted is a listener
socket -server [list ::apply {{sock addr port} {
set shell [Shell new in $sock]
}}] -myaddr $host $port
} else {
# we have a chan (or a couple of chans)
if {$out eq ""} {
if {$in eq "stdin"} {
set out stdout
} else {
set out $in
}
}
chan configure $out -buffering line
coroutine [self]_CORO repl [self] $in $out
}
}
}}
if {info exists argv0 && ($argv0 eq info script)} {
puts "Shell on stdio"
Shell new
puts "Shell on localhost port 8082"
Shell new port 8082 interp {uplevel #1}
vwait forever}