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