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