1# -*- tcl -*- 2# Commands covered: open, close, gets, read, puts, seek, tell, eof, flush, 3# fblocked, fconfigure, open, channel, fcopy 4# 5# This file contains a collection of tests for one or more of the Tcl 6# built-in commands. Sourcing this file into Tcl runs the tests and 7# generates output for errors. No output means no errors were found. 8# 9# Copyright (c) 1991-1994 The Regents of the University of California. 10# Copyright (c) 1994-1996 Sun Microsystems, Inc. 11# Copyright (c) 1998-1999 by Scriptics Corporation. 12# 13# See the file "license.terms" for information on usage and redistribution 14# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 15 16if {"::tcltest" ni [namespace children]} { 17 package require tcltest 2.5 18 namespace import -force ::tcltest::* 19} 20 21::tcltest::loadTestedCommands 22catch [list package require -exact Tcltest [info patchlevel]] 23 24package require tcltests 25 26# Custom constraints used in this file 27testConstraint testchannel [llength [info commands testchannel]] 28 29#---------------------------------------------------------------------- 30 31test iocmd-1.1 {puts command} { 32 list [catch {puts} msg] $msg 33} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}} 34test iocmd-1.2 {puts command} { 35 list [catch {puts a b c d e f g} msg] $msg 36} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}} 37test iocmd-1.3 {puts command} { 38 list [catch {puts froboz -nonewline kablooie} msg] $msg 39} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}} 40test iocmd-1.4 {puts command} { 41 list [catch {puts froboz hello} msg] $msg 42} {1 {can not find channel named "froboz"}} 43test iocmd-1.5 {puts command} { 44 list [catch {puts stdin hello} msg] $msg 45} {1 {channel "stdin" wasn't opened for writing}} 46 47set path(test1) [makeFile {} test1] 48 49test iocmd-1.6 {puts command} { 50 set f [open $path(test1) w] 51 fconfigure $f -translation lf -eofchar {} 52 puts -nonewline $f foobar 53 close $f 54 file size $path(test1) 55} 6 56test iocmd-1.7 {puts command} { 57 set f [open $path(test1) w] 58 fconfigure $f -translation lf -eofchar {} 59 puts $f foobar 60 close $f 61 file size $path(test1) 62} 7 63test iocmd-1.8 {puts command} { 64 set f [open $path(test1) w] 65 fconfigure $f -translation lf -eofchar {} -encoding iso8859-1 66 puts -nonewline $f [binary format a4a5 foo bar] 67 close $f 68 file size $path(test1) 69} 9 70 71test iocmd-2.1 {flush command} { 72 list [catch {flush} msg] $msg 73} {1 {wrong # args: should be "flush channelId"}} 74test iocmd-2.2 {flush command} { 75 list [catch {flush a b c d e} msg] $msg 76} {1 {wrong # args: should be "flush channelId"}} 77test iocmd-2.3 {flush command} { 78 list [catch {flush foo} msg] $msg 79} {1 {can not find channel named "foo"}} 80test iocmd-2.4 {flush command} { 81 list [catch {flush stdin} msg] $msg 82} {1 {channel "stdin" wasn't opened for writing}} 83 84test iocmd-3.1 {gets command} { 85 list [catch {gets} msg] $msg 86} {1 {wrong # args: should be "gets channelId ?varName?"}} 87test iocmd-3.2 {gets command} { 88 list [catch {gets a b c d e f g} msg] $msg 89} {1 {wrong # args: should be "gets channelId ?varName?"}} 90test iocmd-3.3 {gets command} { 91 list [catch {gets aaa} msg] $msg 92} {1 {can not find channel named "aaa"}} 93test iocmd-3.4 {gets command} { 94 list [catch {gets stdout} msg] $msg 95} {1 {channel "stdout" wasn't opened for reading}} 96test iocmd-3.5 {gets command} { 97 set f [open $path(test1) w] 98 puts $f [binary format a4a5 foo bar] 99 close $f 100 set f [open $path(test1) r] 101 set result [gets $f] 102 close $f 103 set x foo\x00 104 set x "${x}bar\x00\x00" 105 string compare $x $result 106} 0 107 108test iocmd-4.1 {read command} { 109 list [catch {read} msg] $msg 110} {1 {wrong # args: should be "read channelId ?numChars?" or "read ?-nonewline? channelId"}} 111test iocmd-4.2 {read command} { 112 list [catch {read a b c d e f g h} msg] $msg 113} {1 {wrong # args: should be "read channelId ?numChars?" or "read ?-nonewline? channelId"}} 114test iocmd-4.3 {read command} { 115 list [catch {read aaa} msg] $msg 116} {1 {can not find channel named "aaa"}} 117test iocmd-4.4 {read command} { 118 list [catch {read -nonewline} msg] $msg 119} {1 {wrong # args: should be "read channelId ?numChars?" or "read ?-nonewline? channelId"}} 120test iocmd-4.5 {read command} { 121 list [catch {read -nonew file4} msg] $msg $::errorCode 122} {1 {can not find channel named "-nonew"} {TCL LOOKUP CHANNEL -nonew}} 123test iocmd-4.6 {read command} { 124 list [catch {read stdout} msg] $msg 125} {1 {channel "stdout" wasn't opened for reading}} 126test iocmd-4.7 {read command} { 127 list [catch {read -nonewline stdout} msg] $msg 128} {1 {channel "stdout" wasn't opened for reading}} 129test iocmd-4.8 {read command with incorrect combination of arguments} { 130 file delete $path(test1) 131 set f [open $path(test1) w] 132 puts $f "Two lines: this one" 133 puts $f "and this one" 134 close $f 135 set f [open $path(test1)] 136 set x [list [catch {read -nonewline $f 20 z} msg] $msg $::errorCode] 137 close $f 138 set x 139} {1 {wrong # args: should be "read channelId ?numChars?" or "read ?-nonewline? channelId"} {TCL WRONGARGS}} 140test iocmd-4.9 {read command} { 141 list [catch {read stdin foo} msg] $msg $::errorCode 142} {1 {expected non-negative integer but got "foo"} {TCL VALUE NUMBER}} 143test iocmd-4.10 {read command} { 144 list [catch {read file107} msg] $msg $::errorCode 145} {1 {can not find channel named "file107"} {TCL LOOKUP CHANNEL file107}} 146set path(test3) [makeFile {} test3] 147test iocmd-4.11 {read command} { 148 set f [open $path(test3) w] 149 set x [list [catch {read $f} msg] $msg $::errorCode] 150 close $f 151 string compare [string tolower $x] \ 152 [list 1 [format "channel \"%s\" wasn't opened for reading" $f] none] 153} 0 154test iocmd-4.12 {read command} -setup { 155 set f [open $path(test1)] 156} -body { 157 list [catch {read $f 12z} msg] $msg $::errorCode 158} -cleanup { 159 close $f 160} -result {1 {expected non-negative integer but got "12z"} {TCL VALUE NUMBER}} 161 162test iocmd-5.1 {seek command} -returnCodes error -body { 163 seek 164} -result {wrong # args: should be "seek channelId offset ?origin?"} 165test iocmd-5.2 {seek command} -returnCodes error -body { 166 seek a b c d e f g 167} -result {wrong # args: should be "seek channelId offset ?origin?"} 168test iocmd-5.3 {seek command} -returnCodes error -body { 169 seek stdin gugu 170} -result {expected integer but got "gugu"} 171test iocmd-5.4 {seek command} -returnCodes error -body { 172 seek stdin 100 gugu 173} -result {bad origin "gugu": must be start, current, or end} 174 175test iocmd-6.1 {tell command} { 176 list [catch {tell} msg] $msg 177} {1 {wrong # args: should be "tell channelId"}} 178test iocmd-6.2 {tell command} { 179 list [catch {tell a b c d e} msg] $msg 180} {1 {wrong # args: should be "tell channelId"}} 181test iocmd-6.3 {tell command} { 182 list [catch {tell aaa} msg] $msg 183} {1 {can not find channel named "aaa"}} 184 185test iocmd-7.1 {close command} { 186 list [catch {close} msg] $msg 187} {1 {wrong # args: should be "close channelId ?direction?"}} 188test iocmd-7.2 {close command} { 189 list [catch {close a b c d e} msg] $msg 190} {1 {wrong # args: should be "close channelId ?direction?"}} 191test iocmd-7.3 {close command} { 192 list [catch {close aaa} msg] $msg 193} {1 {can not find channel named "aaa"}} 194test iocmd-7.4 {close command} -setup { 195 set chan [open [info script] r] 196} -body { 197 chan close $chan bar 198} -cleanup { 199 close $chan 200} -returnCodes error -result "bad direction \"bar\": must be read or write" 201test iocmd-7.5 {close command} -setup { 202 set chan [open [info script] r] 203} -body { 204 chan close $chan write 205} -cleanup { 206 close $chan 207} -returnCodes error -result "Half-close of write-side not possible, side not opened or already closed" 208 209test iocmd-8.1 {fconfigure command} { 210 list [catch {fconfigure} msg] $msg 211} {1 {wrong # args: should be "fconfigure channelId ?-option value ...?"}} 212test iocmd-8.2 {fconfigure command} { 213 list [catch {fconfigure a b c d e f} msg] $msg 214} {1 {wrong # args: should be "fconfigure channelId ?-option value ...?"}} 215test iocmd-8.3 {fconfigure command} { 216 list [catch {fconfigure a b} msg] $msg 217} {1 {can not find channel named "a"}} 218test iocmd-8.4 {fconfigure command} { 219 file delete $path(test1) 220 set f1 [open $path(test1) w] 221 set x [list [catch {fconfigure $f1 froboz} msg] $msg] 222 close $f1 223 set x 224} {1 {bad option "froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} 225test iocmd-8.5 {fconfigure command} { 226 list [catch {fconfigure stdin -buffering froboz} msg] $msg 227} {1 {bad value for -buffering: must be one of full, line, or none}} 228test iocmd-8.6 {fconfigure command} { 229 list [catch {fconfigure stdin -translation froboz} msg] $msg 230} {1 {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}} 231test iocmd-8.7 {fconfigure command} { 232 file delete $path(test1) 233 set f1 [open $path(test1) w] 234 fconfigure $f1 -translation lf -eofchar {} -encoding unicode 235 set x [fconfigure $f1] 236 close $f1 237 set x 238} {-blocking 1 -buffering full -buffersize 4096 -encoding unicode -eofchar {} -translation lf} 239test iocmd-8.8 {fconfigure command} { 240 file delete $path(test1) 241 set f1 [open $path(test1) w] 242 fconfigure $f1 -translation lf -buffering line -buffersize 3030 \ 243 -eofchar {} -encoding unicode 244 set x "" 245 lappend x [fconfigure $f1 -buffering] 246 lappend x [fconfigure $f1] 247 close $f1 248 set x 249} {line {-blocking 1 -buffering line -buffersize 3030 -encoding unicode -eofchar {} -translation lf}} 250test iocmd-8.9 {fconfigure command} { 251 file delete $path(test1) 252 set f1 [open $path(test1) w] 253 fconfigure $f1 -translation binary -buffering none -buffersize 4040 \ 254 -eofchar {} -encoding binary 255 set x [fconfigure $f1] 256 close $f1 257 set x 258} {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -translation lf} 259test iocmd-8.10 {fconfigure command} { 260 list [catch {fconfigure a b} msg] $msg 261} {1 {can not find channel named "a"}} 262set path(fconfigure.dummy) [makeFile {} fconfigure.dummy] 263test iocmd-8.11 {fconfigure command} { 264 set chan [open $path(fconfigure.dummy) r] 265 set res [list [catch {fconfigure $chan -froboz blarfo} msg] $msg] 266 close $chan 267 set res 268} {1 {bad option "-froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} 269test iocmd-8.12 {fconfigure command} { 270 set chan [open $path(fconfigure.dummy) r] 271 set res [list [catch {fconfigure $chan -b blarfo} msg] $msg] 272 close $chan 273 set res 274} {1 {bad option "-b": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} 275test iocmd-8.13 {fconfigure command} { 276 set chan [open $path(fconfigure.dummy) r] 277 set res [list [catch {fconfigure $chan -buffer blarfo} msg] $msg] 278 close $chan 279 set res 280} {1 {bad option "-buffer": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} 281removeFile fconfigure.dummy 282test iocmd-8.14 {fconfigure command} { 283 fconfigure stdin -buffers 284} 4096 285test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOrWin} -setup { 286 set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0] 287 set port [lindex [fconfigure $srv -sockname] 2] 288 proc iocmdSRV {sock ip port} {close $sock} 289 set cli [socket 127.0.0.1 $port] 290} -body { 291 fconfigure $cli -blah 292} -cleanup { 293 close $cli 294 close $srv 295 unset cli srv port 296 rename iocmdSRV {} 297} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -connecting, -peername, or -sockname} 298test iocmd-8.16 {fconfigure command / tcp channel} -constraints socket -setup { 299 set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0] 300 set port [lindex [fconfigure $srv -sockname] 2] 301 proc iocmdSRV {sock ip port} {close $sock} 302 set cli [socket 127.0.0.1 $port] 303} -body { 304 expr {[lindex [fconfigure $cli -peername] 2] == $port} 305} -cleanup { 306 close $cli 307 close $srv 308 unset cli srv port 309 rename iocmdSRV {} 310} -result 1 311test iocmd-8.17 {fconfigure command / tcp channel} -constraints nonPortable -setup { 312 set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0] 313 set port [lindex [fconfigure $srv -sockname] 2] 314 proc iocmdSRV {sock ip port} {close $sock} 315 set cli [socket 127.0.0.1 $port] 316} -body { 317 # It is possible that you don't get the connection reset by peer 318 # error but rather a valid answer. Depends on the tcp implementation 319 update 320 puts $cli "blah" 321 flush $cli; # that flush could/should fail too 322 update 323 regsub -all {can([^:])+: } [catch {fconfigure $cli -peername} msg] {} 324} -cleanup { 325 close $cli 326 close $srv 327 unset cli srv port 328 rename iocmdSRV {} 329} -result 1 330test iocmd-8.18 {fconfigure command / unix tty channel} -constraints {nonPortable unix} -setup { 331 set tty "" 332} -body { 333 # might fail if /dev/ttya is unavailable 334 set tty [open /dev/ttya] 335 fconfigure $tty -blah blih 336} -cleanup { 337 if {$tty ne ""} { 338 close $tty 339 } 340} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -mode} 341test iocmd-8.19 {fconfigure command / win tty channel} -constraints {nonPortable win} -setup { 342 set tty "" 343} -body { 344 # might fail early if com1 is unavailable 345 set tty [open com1] 346 fconfigure $tty -blah blih 347} -cleanup { 348 if {$tty ne ""} { 349 close $tty 350 } 351} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -mode, -handshake, -pollinterval, -sysbuffer, -timeout, -ttycontrol, or -xchar} 352# TODO: Test parsing of serial channel options (nonPortable, since requires an 353# open channel to work with). 354 355test iocmd-9.1 {eof command} { 356 list [catch {eof} msg] $msg $::errorCode 357} {1 {wrong # args: should be "eof channelId"} {TCL WRONGARGS}} 358test iocmd-9.2 {eof command} { 359 list [catch {eof a b} msg] $msg $::errorCode 360} {1 {wrong # args: should be "eof channelId"} {TCL WRONGARGS}} 361test iocmd-9.3 {eof command} { 362 catch {close file100} 363 list [catch {eof file100} msg] $msg $::errorCode 364} {1 {can not find channel named "file100"} {TCL LOOKUP CHANNEL file100}} 365 366# The tests for Tcl_ExecObjCmd are in exec.test 367 368test iocmd-10.1 {fblocked command} { 369 list [catch {fblocked} msg] $msg 370} {1 {wrong # args: should be "fblocked channelId"}} 371test iocmd-10.2 {fblocked command} { 372 list [catch {fblocked a b c d e f g} msg] $msg 373} {1 {wrong # args: should be "fblocked channelId"}} 374test iocmd-10.3 {fblocked command} { 375 list [catch {fblocked file1000} msg] $msg 376} {1 {can not find channel named "file1000"}} 377test iocmd-10.4 {fblocked command} { 378 list [catch {fblocked stdout} msg] $msg 379} {1 {channel "stdout" wasn't opened for reading}} 380test iocmd-10.5 {fblocked command} { 381 fblocked stdin 382} 0 383 384set path(test4) [makeFile {} test4] 385set path(test5) [makeFile {} test5] 386 387test iocmd-11.1 {I/O to command pipelines} {unixOrWin unixExecs} { 388 set f [open $path(test4) w] 389 close $f 390 list [catch {open "| cat < \"$path(test4)\" > \"$path(test5)\"" w} msg] $msg $::errorCode 391} {1 {can't write input to command: standard input was redirected} {TCL OPERATION EXEC BADREDIRECT}} 392test iocmd-11.2 {I/O to command pipelines} {unixOrWin unixExecs} { 393 list [catch {open "| echo > \"$path(test5)\"" r} msg] $msg $::errorCode 394} {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}} 395test iocmd-11.3 {I/O to command pipelines} {unixOrWin unixExecs} { 396 list [catch {open "| echo > \"$path(test5)\"" r+} msg] $msg $::errorCode 397} {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}} 398test iocmd-11.4 {I/O to command pipelines} {notValgrind unixOrWin} { 399 list [catch {open "| no_such_command_exists" rb} msg] $msg $::errorCode 400} {1 {couldn't execute "no_such_command_exists": no such file or directory} {POSIX ENOENT {no such file or directory}}} 401 402test iocmd-12.1 {POSIX open access modes: RDONLY} { 403 file delete $path(test1) 404 set f [open $path(test1) w] 405 puts $f "Two lines: this one" 406 puts $f "and this one" 407 close $f 408 set f [open $path(test1) RDONLY] 409 set x [list [gets $f] [catch {puts $f Test} msg] $msg] 410 close $f 411 string compare $x \ 412 "{Two lines: this one} 1 [list [format "channel \"%s\" wasn't opened for writing" $f]]" 413} 0 414test iocmd-12.2 {POSIX open access modes: RDONLY} -match regexp -body { 415 file delete $path(test3) 416 open $path(test3) RDONLY 417} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory} 418test iocmd-12.3 {POSIX open access modes: WRONLY} -match regexp -body { 419 file delete $path(test3) 420 open $path(test3) WRONLY 421} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory} 422# 423# Test 13.4 relies on assigning the same channel name twice. 424# 425test iocmd-12.4 {POSIX open access modes: WRONLY} {unix} { 426 file delete $path(test3) 427 set f [open $path(test3) w] 428 fconfigure $f -eofchar {} 429 puts $f xyzzy 430 close $f 431 set f [open $path(test3) WRONLY] 432 fconfigure $f -eofchar {} 433 puts -nonewline $f "ab" 434 seek $f 0 current 435 set x [list [catch {gets $f} msg] $msg] 436 close $f 437 set f [open $path(test3) r] 438 fconfigure $f -eofchar {} 439 lappend x [gets $f] 440 close $f 441 set y [list 1 [format "channel \"%s\" wasn't opened for reading" $f] abzzy] 442 string compare $x $y 443} 0 444test iocmd-12.5 {POSIX open access modes: RDWR} -match regexp -body { 445 file delete $path(test3) 446 open $path(test3) RDWR 447} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory} 448test iocmd-12.6 {POSIX open access modes: errors} { 449 concat [catch {open $path(test3) "FOO \{BAR BAZ"} msg] $msg\n$::errorInfo 450} "1 unmatched open brace in list 451unmatched open brace in list 452 while processing open access modes \"FOO {BAR BAZ\" 453 invoked from within 454\"open \$path(test3) \"FOO \\{BAR BAZ\"\"" 455test iocmd-12.7 {POSIX open access modes: errors} { 456 list [catch {open $path(test3) {FOO BAR BAZ}} msg] $msg 457} {1 {invalid access mode "FOO": must be RDONLY, WRONLY, RDWR, APPEND, BINARY, CREAT, EXCL, NOCTTY, NONBLOCK, or TRUNC}} 458test iocmd-12.8 {POSIX open access modes: errors} { 459 list [catch {open $path(test3) {TRUNC CREAT}} msg] $msg 460} {1 {access mode must include either RDONLY, WRONLY, or RDWR}} 461close [open $path(test3) w] 462test iocmd-12.9 {POSIX open access modes: BINARY} { 463 list [catch {open $path(test1) BINARY} msg] $msg 464} {1 {access mode must include either RDONLY, WRONLY, or RDWR}} 465test iocmd-12.10 {POSIX open access modes: BINARY} { 466 set f [open $path(test1) {WRONLY BINARY TRUNC}] 467 puts $f a 468 puts $f b 469 puts -nonewline $f c ;# contents are now 5 bytes: a\nb\nc 470 close $f 471 set f [open $path(test1) r] 472 fconfigure $f -translation binary 473 set result [string length [read $f]] 474 close $f 475 set result 476} 5 477test iocmd-12.11 {POSIX open access modes: BINARY} { 478 set f [open $path(test1) {WRONLY BINARY TRUNC}] 479 puts $f \u0248 ;# gets truncated to \u0048 480 close $f 481 set f [open $path(test1) r] 482 fconfigure $f -translation binary 483 set result [read -nonewline $f] 484 close $f 485 set result 486} \u0048 487 488test iocmd-13.1 {errors in open command} { 489 list [catch {open} msg] $msg 490} {1 {wrong # args: should be "open fileName ?access? ?permissions?"}} 491test iocmd-13.2 {errors in open command} { 492 list [catch {open a b c d} msg] $msg 493} {1 {wrong # args: should be "open fileName ?access? ?permissions?"}} 494test iocmd-13.3 {errors in open command} { 495 list [catch {open $path(test1) x} msg] $msg 496} {1 {illegal access mode "x"}} 497test iocmd-13.4 {errors in open command} { 498 list [catch {open $path(test1) rw} msg] $msg 499} {1 {illegal access mode "rw"}} 500test iocmd-13.5 {errors in open command} { 501 list [catch {open $path(test1) r+1} msg] $msg 502} {1 {illegal access mode "r+1"}} 503test iocmd-13.6 {errors in open command} { 504 set msg [list [catch {open _non_existent_} msg] $msg $::errorCode] 505 regsub [file join {} _non_existent_] $msg "_non_existent_" msg 506 string tolower $msg 507} {1 {couldn't open "_non_existent_": no such file or directory} {posix enoent {no such file or directory}}} 508test iocmd-13.7 {errors in open command} { 509 list [catch {open $path(test1) b} msg] $msg 510} {1 {illegal access mode "b"}} 511test iocmd-13.8 {errors in open command} { 512 list [catch {open $path(test1) rbb} msg] $msg 513} {1 {illegal access mode "rbb"}} 514test iocmd-13.9 {errors in open command} { 515 list [catch {open $path(test1) r++} msg] $msg 516} {1 {illegal access mode "r++"}} 517test iocmd-13.10.1 {open for append, a mode} -setup { 518 set log [makeFile {} out] 519 set chans {} 520} -body { 521 foreach i { 0 1 2 3 4 5 6 7 8 9 } { 522 puts [set ch [open $log a]] $i 523 lappend chans $ch 524 } 525 foreach ch $chans {catch {close $ch}} 526 lsort [split [string trim [viewFile out]] \n] 527} -cleanup { 528 removeFile out 529 # Ensure that channels are gone, even if body failed to do so 530 foreach ch $chans {catch {close $ch}} 531} -result {0 1 2 3 4 5 6 7 8 9} 532test iocmd-13.10.2 {open for append, O_APPEND} -setup { 533 set log [makeFile {} out] 534 set chans {} 535} -body { 536 foreach i { 0 1 2 3 4 5 6 7 8 9 } { 537 puts [set ch [open $log {WRONLY CREAT APPEND}]] $i 538 lappend chans $ch 539 } 540 foreach ch $chans {catch {close $ch}} 541 lsort [split [string trim [viewFile out]] \n] 542} -cleanup { 543 removeFile out 544 # Ensure that channels are gone, even if body failed to do so 545 foreach ch $chans {catch {close $ch}} 546} -result {0 1 2 3 4 5 6 7 8 9} 547test ioCmd-13.11 {open ... a+ must not use O_APPEND: Bug 1773127} -setup { 548 set f [makeFile {} ioutil41.tmp] 549 set fid [open $f wb] 550 puts -nonewline $fid 123 551 close $fid 552} -body { 553 set fid [open $f ab+] 554 puts -nonewline $fid 456 555 seek $fid 2 556 set d [read $fid 2] 557 seek $fid 4 558 puts -nonewline $fid x 559 close $fid 560 set fid [open $f rb] 561 append d [read $fid] 562 close $fid 563 return $d 564} -cleanup { 565 removeFile $f 566} -result 341234x6 567 568 569test iocmd-14.1 {file id parsing errors} { 570 list [catch {eof gorp} msg] $msg $::errorCode 571} {1 {can not find channel named "gorp"} {TCL LOOKUP CHANNEL gorp}} 572test iocmd-14.2 {file id parsing errors} { 573 list [catch {eof filex} msg] $msg 574} {1 {can not find channel named "filex"}} 575test iocmd-14.3 {file id parsing errors} { 576 list [catch {eof file12a} msg] $msg 577} {1 {can not find channel named "file12a"}} 578test iocmd-14.4 {file id parsing errors} { 579 list [catch {eof file123} msg] $msg 580} {1 {can not find channel named "file123"}} 581test iocmd-14.5 {file id parsing errors} { 582 list [catch {eof stdout} msg] $msg 583} {0 0} 584test iocmd-14.6 {file id parsing errors} { 585 list [catch {eof stdin} msg] $msg 586} {0 0} 587test iocmd-14.7 {file id parsing errors} { 588 list [catch {eof stdout} msg] $msg 589} {0 0} 590test iocmd-14.8 {file id parsing errors} { 591 list [catch {eof stderr} msg] $msg 592} {0 0} 593test iocmd-14.9 {file id parsing errors} { 594 list [catch {eof stderr1} msg] $msg 595} {1 {can not find channel named "stderr1"}} 596 597set f [open $path(test1) w] 598close $f 599 600set expect "1 {can not find channel named \"$f\"}" 601test iocmd-14.10 {file id parsing errors} { 602 list [catch {eof $f} msg] $msg 603} $expect 604 605test iocmd-15.1 {Tcl_FcopyObjCmd} {fcopy} { 606 list [catch {fcopy} msg] $msg 607} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}} 608test iocmd-15.2 {Tcl_FcopyObjCmd} {fcopy} { 609 list [catch {fcopy 1} msg] $msg 610} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}} 611test iocmd-15.3 {Tcl_FcopyObjCmd} {fcopy} { 612 list [catch {fcopy 1 2 3 4 5 6 7} msg] $msg 613} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}} 614test iocmd-15.4 {Tcl_FcopyObjCmd} {fcopy} { 615 list [catch {fcopy 1 2 3} msg] $msg 616} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}} 617test iocmd-15.5 {Tcl_FcopyObjCmd} {fcopy} { 618 list [catch {fcopy 1 2 3 4 5} msg] $msg 619} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}} 620 621set path(test2) [makeFile {} test2] 622set f [open $path(test1) w] 623close $f 624set rfile [open $path(test1) r] 625set wfile [open $path(test2) w] 626 627test iocmd-15.6 {Tcl_FcopyObjCmd} {fcopy} { 628 list [catch {fcopy foo $wfile} msg] $msg 629} {1 {can not find channel named "foo"}} 630test iocmd-15.7 {Tcl_FcopyObjCmd} {fcopy} { 631 list [catch {fcopy $rfile foo} msg] $msg 632} {1 {can not find channel named "foo"}} 633test iocmd-15.8 {Tcl_FcopyObjCmd} {fcopy} { 634 list [catch {fcopy $wfile $wfile} msg] $msg 635} "1 {channel \"$wfile\" wasn't opened for reading}" 636test iocmd-15.9 {Tcl_FcopyObjCmd} {fcopy} { 637 list [catch {fcopy $rfile $rfile} msg] $msg 638} "1 {channel \"$rfile\" wasn't opened for writing}" 639test iocmd-15.10 {Tcl_FcopyObjCmd} {fcopy} { 640 list [catch {fcopy $rfile $wfile foo bar} msg] $msg 641} {1 {bad option "foo": must be -size or -command}} 642test iocmd-15.11 {Tcl_FcopyObjCmd} {fcopy} { 643 list [catch {fcopy $rfile $wfile -size foo} msg] $msg 644} {1 {expected integer but got "foo"}} 645test iocmd-15.12 {Tcl_FcopyObjCmd} {fcopy} { 646 list [catch {fcopy $rfile $wfile -command bar -size foo} msg] $msg 647} {1 {expected integer but got "foo"}} 648 649close $rfile 650close $wfile 651 652# ### ### ### ######### ######### ######### 653## Testing the reflected channel. 654 655test iocmd-20.0 {chan, wrong#args} { 656 catch {chan} msg 657 set msg 658} {wrong # args: should be "chan subcommand ?arg ...?"} 659test iocmd-20.1 {chan, unknown method} -body { 660 chan foo 661} -returnCodes error -match glob -result {unknown or ambiguous subcommand "foo": must be *} 662 663# --- --- --- --------- --------- --------- 664# chan create, and method "initalize" 665 666test iocmd-21.0 {chan create, wrong#args, not enough} { 667 catch {chan create} msg 668 set msg 669} {wrong # args: should be "chan create mode cmdprefix"} 670test iocmd-21.1 {chan create, wrong#args, too many} { 671 catch {chan create a b c} msg 672 set msg 673} {wrong # args: should be "chan create mode cmdprefix"} 674test iocmd-21.2 {chan create, invalid r/w mode, empty} { 675 proc foo {} {} 676 catch {chan create {} foo} msg 677 rename foo {} 678 set msg 679} {bad mode list: is empty} 680test iocmd-21.3 {chan create, invalid r/w mode, bad string} { 681 proc foo {} {} 682 catch {chan create {c} foo} msg 683 rename foo {} 684 set msg 685} {bad mode "c": must be read or write} 686test iocmd-21.4 {chan create, bad handler, not a list} { 687 catch {chan create {r w} "foo \{"} msg 688 set msg 689} {unmatched open brace in list} 690test iocmd-21.5 {chan create, bad handler, not a command} { 691 catch {chan create {r w} foo} msg 692 set msg 693} {invalid command name "foo"} 694test iocmd-21.6 {chan create, initialize failed, bad signature} { 695 proc foo {} {} 696 catch {chan create {r w} foo} msg 697 rename foo {} 698 set msg 699} {wrong # args: should be "foo"} 700test iocmd-21.7 {chan create, initialize failed, bad signature} { 701 proc foo {} {} 702 catch {chan create {r w} ::foo} msg 703 rename foo {} 704 set msg 705} {wrong # args: should be "::foo"} 706test iocmd-21.8 {chan create, initialize failed, bad result, not a list} -body { 707 proc foo {args} {return "\{"} 708 catch {chan create {r w} foo} msg 709 rename foo {} 710 set ::errorInfo 711} -match glob -result {chan handler "foo initialize" returned non-list: *} 712test iocmd-21.9 {chan create, initialize failed, bad result, not a list} -body { 713 proc foo {args} {return \{\{\}} 714 catch {chan create {r w} foo} msg 715 rename foo {} 716 set msg 717} -match glob -result {chan handler "foo initialize" returned non-list: *} 718test iocmd-21.10 {chan create, initialize failed, bad result, empty list} -body { 719 proc foo {args} {} 720 catch {chan create {r w} foo} msg 721 rename foo {} 722 set msg 723} -match glob -result {*all required methods*} 724test iocmd-21.11 {chan create, initialize failed, bad result, bogus method name} -body { 725 proc foo {args} {return 1} 726 catch {chan create {r w} foo} msg 727 rename foo {} 728 set msg 729} -match glob -result {*bad method "1": must be *} 730test iocmd-21.12 {chan create, initialize failed, bad result, bogus method name} -body { 731 proc foo {args} {return {a b c}} 732 catch {chan create {r w} foo} msg 733 rename foo {} 734 set msg 735} -match glob -result {*bad method "c": must be *} 736test iocmd-21.13 {chan create, initialize failed, bad result, required methods missing} -body { 737 proc foo {args} {return {initialize finalize}} 738 catch {chan create {r w} foo} msg 739 rename foo {} 740 set msg 741} -match glob -result {*all required methods*} 742test iocmd-21.14 {chan create, initialize failed, bad result, mode/handler mismatch} -body { 743 proc foo {args} {return {initialize finalize watch read}} 744 catch {chan create {r w} foo} msg 745 rename foo {} 746 set msg 747} -match glob -result {*lacks a "write" method} 748test iocmd-21.15 {chan create, initialize failed, bad result, mode/handler mismatch} -body { 749 proc foo {args} {return {initialize finalize watch write}} 750 catch {chan create {r w} foo} msg 751 rename foo {} 752 set msg 753} -match glob -result {*lacks a "read" method} 754test iocmd-21.16 {chan create, initialize failed, bad result, cget(all) mismatch} -body { 755 proc foo {args} {return {initialize finalize watch cget write read}} 756 catch {chan create {r w} foo} msg 757 rename foo {} 758 set msg 759} -match glob -result {*supports "cget" but not "cgetall"} 760test iocmd-21.17 {chan create, initialize failed, bad result, cget(all) mismatch} -body { 761 proc foo {args} {return {initialize finalize watch cgetall read write}} 762 catch {chan create {r w} foo} msg 763 rename foo {} 764 set msg 765} -match glob -result {*supports "cgetall" but not "cget"} 766test iocmd-21.18 {chan create, initialize ok, creates channel} -match glob -body { 767 proc foo {args} { 768 global res 769 lappend res $args 770 if {[lindex $args 0] ne "initialize"} {return} 771 return {initialize finalize watch read write} 772 } 773 set res {} 774 lappend res [file channel rc*] 775 lappend res [chan create {r w} foo] 776 lappend res [close [lindex $res end]] 777 lappend res [file channel rc*] 778 rename foo {} 779 set res 780} -result {{} {initialize rc* {read write}} rc* {finalize rc*} {} {}} 781test iocmd-21.19 {chan create, init failure -> no channel, no finalize} -match glob -body { 782 proc foo {args} { 783 global res 784 lappend res $args 785 return {} 786 } 787 set res {} 788 lappend res [file channel rc*] 789 lappend res [catch {chan create {r w} foo} msg] 790 lappend res $msg 791 lappend res [file channel rc*] 792 rename foo {} 793 set res 794} -result {{} {initialize rc* {read write}} 1 {*all required methods*} {}} 795test iocmd-21.20 {Bug 88aef05cda} -setup { 796 proc foo {method chan args} { 797 switch -- $method blocking { 798 chan configure $chan -blocking [lindex $args 0] 799 return 800 } initialize { 801 return {initialize finalize watch blocking read write 802 configure cget cgetall} 803 } finalize { 804 return 805 } 806 } 807 set ch [chan create {read write} foo] 808} -body { 809 chan configure $ch -blocking 0 810} -cleanup { 811 close $ch 812 rename foo {} 813} -match glob -returnCodes 1 -result {*(infinite loop?)*} 814test iocmd-21.21 {[close] in [read] segfaults} -setup { 815 proc foo {method chan args} { 816 switch -- $method initialize { 817 return {initialize finalize watch read} 818 } finalize {} watch {} read { 819 close $chan 820 return a 821 } 822 } 823 set ch [chan create read foo] 824} -body { 825 read $ch 0 826} -cleanup { 827 close $ch 828 rename foo {} 829} -result {} 830test iocmd-21.22 {[close] in [read] segfaults} -setup { 831 proc foo {method chan args} { 832 switch -- $method initialize { 833 return {initialize finalize watch read} 834 } finalize {} watch {} read { 835 catch {close $chan} 836 return a 837 } 838 } 839 set ch [chan create read foo] 840} -body { 841 read $ch 1 842} -returnCodes error -cleanup { 843 catch {close $ch} 844 rename foo {} 845} -match glob -result {*invalid argument*} 846test iocmd-21.23 {[close] in [gets] segfaults} -setup { 847 proc foo {method chan args} { 848 switch -- $method initialize { 849 return {initialize finalize watch read} 850 } finalize {} watch {} read { 851 catch {close $chan} 852 return \n 853 } 854 } 855 set ch [chan create read foo] 856} -body { 857 gets $ch 858} -cleanup { 859 catch {close $ch} 860 rename foo {} 861} -result {} 862test iocmd-21.24 {[close] in binary [gets] segfaults} -setup { 863 proc foo {method chan args} { 864 switch -- $method initialize { 865 return {initialize finalize watch read} 866 } finalize {} watch {} read { 867 catch {close $chan} 868 return \n 869 } 870 } 871 set ch [chan create read foo] 872} -body { 873 chan configure $ch -translation binary 874 gets $ch 875} -cleanup { 876 catch {close $ch} 877 rename foo {} 878} -result {} 879 880# --- --- --- --------- --------- --------- 881# Helper commands to record the arguments to handler methods. 882 883# Stored in a script so that the threads and interpreters needing this 884# code do not need their own copy but can access this variable. 885 886set helperscript { 887 888proc note {item} {global res; lappend res $item; return} 889proc track {} {upvar args item; note $item; return} 890proc notes {items} {foreach i $items {note $i}} 891# This forces the return options to be in the order that the test expects! 892proc noteOpts opts {global res; lappend res [dict merge { 893 -code !?! -level !?! -errorcode !?! -errorline !?! -errorinfo !?! 894} $opts]; return} 895 896# Helper command, canned result for 'initialize' method. 897# Gets the optional methods as arguments. Use return features 898# to post the result higher up. 899 900proc init {args} { 901 lappend args initialize finalize watch read write 902 return -code return $args 903} 904proc oninit {args} { 905 upvar args hargs 906 if {[lindex $hargs 0] ne "initialize"} {return} 907 lappend args initialize finalize watch read write 908 return -code return $args 909} 910proc onfinal {} { 911 upvar args hargs 912 if {[lindex $hargs 0] ne "finalize"} {return} 913 return -code return "" 914} 915} 916 917# Set everything up in the main thread. 918eval $helperscript 919 920# --- --- --- --------- --------- --------- 921# method finalize 922 923test iocmd-22.1 {chan finalize, handler destruction has no effect on channel} -match glob -body { 924 set res {} 925 proc foo {args} {track; oninit; return} 926 note [set c [chan create {r w} foo]] 927 rename foo {} 928 note [file channels rc*] 929 note [catch {close $c} msg]; note $msg 930 note [file channels rc*] 931 set res 932} -result {{initialize rc* {read write}} rc* rc* 1 {invalid command name "foo"} {}} 933test iocmd-22.2 {chan finalize, for close} -match glob -body { 934 set res {} 935 proc foo {args} {track; oninit; return {}} 936 note [set c [chan create {r w} foo]] 937 close $c 938 # Close deleted the channel. 939 note [file channels rc*] 940 # Channel destruction does not kill handler command! 941 note [info command foo] 942 rename foo {} 943 set res 944} -result {{initialize rc* {read write}} rc* {finalize rc*} {} foo} 945test iocmd-22.3 {chan finalize, for close, error, close error} -match glob -body { 946 set res {} 947 proc foo {args} {track; oninit; return -code error 5} 948 note [set c [chan create {r w} foo]] 949 note [catch {close $c} msg]; note $msg 950 # Channel is gone despite error. 951 note [file channels rc*] 952 rename foo {} 953 set res 954} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 5 {}} 955test iocmd-22.4 {chan finalize, for close, error, close error} -match glob -body { 956 set res {} 957 proc foo {args} {track; oninit; error FOO} 958 note [set c [chan create {r w} foo]] 959 note [catch {close $c} msg]; note $msg; note $::errorInfo 960 rename foo {} 961 set res 962} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 FOO {FOO 963*"close $c"}} 964test iocmd-22.5 {chan finalize, for close, arbitrary result, ignored} -match glob -body { 965 set res {} 966 proc foo {args} {track; oninit; return SOMETHING} 967 note [set c [chan create {r w} foo]] 968 note [catch {close $c} msg]; note $msg 969 rename foo {} 970 set res 971} -result {{initialize rc* {read write}} rc* {finalize rc*} 0 {}} 972test iocmd-22.6 {chan finalize, for close, break, close error} -match glob -body { 973 set res {} 974 proc foo {args} {track; oninit; return -code 3} 975 note [set c [chan create {r w} foo]] 976 note [catch {close $c} msg]; note $msg 977 rename foo {} 978 set res 979} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 *bad code*} 980test iocmd-22.7 {chan finalize, for close, continue, close error} -match glob -body { 981 set res {} 982 proc foo {args} {track; oninit; return -code 4} 983 note [set c [chan create {r w} foo]] 984 note [catch {close $c} msg]; note $msg 985 rename foo {} 986 set res 987} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 *bad code*} 988test iocmd-22.8 {chan finalize, for close, custom code, close error} -match glob -body { 989 set res {} 990 proc foo {args} {track; oninit; return -code 777 BANG} 991 note [set c [chan create {r w} foo]] 992 note [catch {close $c} msg]; note $msg 993 rename foo {} 994 set res 995} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 *bad code*} 996test iocmd-22.9 {chan finalize, for close, ignore level, close error} -match glob -setup { 997 set res {} 998} -body { 999 proc foo {args} {track; oninit; return -level 5 -code 777 BANG} 1000 note [set c [chan create {r w} foo]] 1001 note [catch {close $c} msg opt]; note $msg; noteOpts $opt 1002 return $res 1003} -cleanup { 1004 rename foo {} 1005} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}} 1006 1007# --- === *** ########################### 1008# method read 1009 1010test iocmd-23.1 {chan read, regular data return} -match glob -body { 1011 set res {} 1012 proc foo {args} { 1013 oninit; onfinal; track 1014 return snarf 1015 } 1016 set c [chan create {r w} foo] 1017 note [read $c 10] 1018 close $c 1019 rename foo {} 1020 set res 1021} -result {{read rc* 4096} {read rc* 4096} snarfsnarf} 1022test iocmd-23.2 {chan read, bad data return, to much} -match glob -body { 1023 set res {} 1024 proc foo {args} { 1025 oninit; onfinal; track 1026 return [string repeat snarf 1000] 1027 } 1028 set c [chan create {r w} foo] 1029 note [catch {read $c 2} msg]; note $msg 1030 close $c 1031 rename foo {} 1032 set res 1033} -result {{read rc* 4096} 1 {read delivered more than requested}} 1034test iocmd-23.3 {chan read, for non-readable channel} -match glob -body { 1035 set res {} 1036 proc foo {args} { 1037 oninit; onfinal; track; note MUST_NOT_HAPPEN 1038 } 1039 set c [chan create {w} foo] 1040 note [catch {read $c 2} msg]; note $msg 1041 close $c 1042 rename foo {} 1043 set res 1044} -result {1 {channel "rc*" wasn't opened for reading}} 1045test iocmd-23.4 {chan read, error return} -match glob -body { 1046 set res {} 1047 proc foo {args} { 1048 oninit; onfinal; track 1049 return -code error BOOM! 1050 } 1051 set c [chan create {r w} foo] 1052 note [catch {read $c 2} msg]; note $msg 1053 close $c 1054 rename foo {} 1055 set res 1056} -result {{read rc* 4096} 1 BOOM!} 1057test iocmd-23.5 {chan read, break return is error} -match glob -body { 1058 set res {} 1059 proc foo {args} { 1060 oninit; onfinal; track 1061 return -code break BOOM! 1062 } 1063 set c [chan create {r w} foo] 1064 note [catch {read $c 2} msg]; note $msg 1065 close $c 1066 rename foo {} 1067 set res 1068} -result {{read rc* 4096} 1 *bad code*} 1069test iocmd-23.6 {chan read, continue return is error} -match glob -body { 1070 set res {} 1071 proc foo {args} { 1072 oninit; onfinal; track 1073 return -code continue BOOM! 1074 } 1075 set c [chan create {r w} foo] 1076 note [catch {read $c 2} msg]; note $msg 1077 close $c 1078 rename foo {} 1079 set res 1080} -result {{read rc* 4096} 1 *bad code*} 1081test iocmd-23.7 {chan read, custom return is error} -match glob -body { 1082 set res {} 1083 proc foo {args} { 1084 oninit; onfinal; track 1085 return -code 777 BOOM! 1086 } 1087 set c [chan create {r w} foo] 1088 note [catch {read $c 2} msg]; note $msg 1089 close $c 1090 rename foo {} 1091 set res 1092} -result {{read rc* 4096} 1 *bad code*} 1093test iocmd-23.8 {chan read, level is squashed} -match glob -body { 1094 set res {} 1095 proc foo {args} { 1096 oninit; onfinal; track 1097 return -level 55 -code 777 BOOM! 1098 } 1099 set c [chan create {r w} foo] 1100 note [catch {read $c 2} msg opt]; note $msg; noteOpts $opt 1101 close $c 1102 rename foo {} 1103 set res 1104} -result {{read rc* 4096} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}} 1105test iocmd-23.9 {chan read, no data means eof} -match glob -setup { 1106 set res {} 1107 proc foo {args} { 1108 oninit; onfinal; track 1109 return "" 1110 } 1111 set c [chan create {r w} foo] 1112} -body { 1113 note [read $c 2] 1114 note [eof $c] 1115 set res 1116} -cleanup { 1117 close $c 1118 rename foo {} 1119 unset res 1120} -result {{read rc* 4096} {} 1} 1121test iocmd-23.10 {chan read, EAGAIN means no data, yet no eof either} -match glob -setup { 1122 set res {} 1123 proc foo {args} { 1124 oninit; onfinal; track 1125 error EAGAIN 1126 } 1127 set c [chan create {r w} foo] 1128} -body { 1129 note [read $c 2] 1130 note [eof $c] 1131 set res 1132} -cleanup { 1133 close $c 1134 rename foo {} 1135 unset res 1136} -result {{read rc* 4096} {} 0} 1137test iocmd-23.11 {chan read, close pulls the rug out} -match glob -body { 1138 set res {} 1139 proc foo {args} { 1140 oninit; onfinal; track 1141 set args [lassign $args sub id] 1142 if {$sub ne "read"} {return} 1143 close $id 1144 return {} 1145 } 1146 set c [chan create {r} foo] 1147 note [read $c] 1148 rename foo {} 1149 set res 1150} -result {{read rc* 4096} {}} 1151 1152# --- === *** ########################### 1153# method write 1154 1155test iocmd-24.1 {chan write, regular write} -match glob -body { 1156 set res {} 1157 proc foo {args} { 1158 oninit; onfinal; track 1159 set written [string length [lindex $args 2]] 1160 note $written 1161 return $written 1162 } 1163 set c [chan create {r w} foo] 1164 puts -nonewline $c snarf; flush $c 1165 close $c 1166 rename foo {} 1167 set res 1168} -result {{write rc* snarf} 5} 1169test iocmd-24.2 {chan write, partial write is ok} -match glob -body { 1170 set res {} 1171 proc foo {args} { 1172 oninit; onfinal; track 1173 set written [string length [lindex $args 2]] 1174 if {$written > 10} {set written [expr {$written / 2}]} 1175 note $written 1176 return $written 1177 } 1178 set c [chan create {r w} foo] 1179 puts -nonewline $c snarfsnarfsnarf; flush $c 1180 close $c 1181 rename foo {} 1182 set res 1183} -result {{write rc* snarfsnarfsnarf} 7 {write rc* arfsnarf} 8} 1184test iocmd-24.3 {chan write, failed write} -match glob -body { 1185 set res {} 1186 proc foo {args} {oninit; onfinal; track; note -1; return -1} 1187 set c [chan create {r w} foo] 1188 puts -nonewline $c snarfsnarfsnarf; flush $c 1189 close $c 1190 rename foo {} 1191 set res 1192} -result {{write rc* snarfsnarfsnarf} -1} 1193test iocmd-24.4 {chan write, non-writable channel} -match glob -body { 1194 set res {} 1195 proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} 1196 set c [chan create {r} foo] 1197 note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]; note $msg 1198 close $c 1199 rename foo {} 1200 set res 1201} -result {1 {channel "rc*" wasn't opened for writing}} 1202test iocmd-24.5 {chan write, bad result, more written than data} -match glob -body { 1203 set res {} 1204 proc foo {args} {oninit; onfinal; track; return 10000} 1205 set c [chan create {r w} foo] 1206 note [catch {puts -nonewline $c snarf; flush $c} msg]; note $msg 1207 close $c 1208 rename foo {} 1209 set res 1210} -result {{write rc* snarf} 1 {write wrote more than requested}} 1211test iocmd-24.6 {chan write, bad result, zero-length write} -match glob -body { 1212 set res {} 1213 proc foo {args} {oninit; onfinal; track; return 0} 1214 set c [chan create {r w} foo] 1215 note [catch {puts -nonewline $c snarf; flush $c} msg]; note $msg 1216 close $c 1217 rename foo {} 1218 set res 1219} -result {{write rc* snarf} 1 {write wrote nothing}} 1220test iocmd-24.7 {chan write, failed write, error return} -match glob -body { 1221 set res {} 1222 proc foo {args} {oninit; onfinal; track; return -code error BOOM!} 1223 set c [chan create {r w} foo] 1224 note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] 1225 note $msg 1226 close $c 1227 rename foo {} 1228 set res 1229} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} 1230test iocmd-24.8 {chan write, failed write, error return} -match glob -body { 1231 set res {} 1232 proc foo {args} {oninit; onfinal; track; error BOOM!} 1233 set c [chan create {r w} foo] 1234 notes [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] 1235 note $msg 1236 close $c 1237 rename foo {} 1238 set res 1239} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} 1240test iocmd-24.9 {chan write, failed write, break return is error} -match glob -body { 1241 set res {} 1242 proc foo {args} {oninit; onfinal; track; return -code break BOOM!} 1243 set c [chan create {r w} foo] 1244 note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] 1245 note $msg 1246 close $c 1247 rename foo {} 1248 set res 1249} -result {{write rc* snarfsnarfsnarf} 1 *bad code*} 1250test iocmd-24.10 {chan write, failed write, continue return is error} -match glob -body { 1251 set res {} 1252 proc foo {args} {oninit; onfinal; track; return -code continue BOOM!} 1253 set c [chan create {r w} foo] 1254 note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] 1255 note $msg 1256 close $c 1257 rename foo {} 1258 set res 1259} -result {{write rc* snarfsnarfsnarf} 1 *bad code*} 1260test iocmd-24.11 {chan write, failed write, custom return is error} -match glob -body { 1261 set res {} 1262 proc foo {args} {oninit; onfinal; track; return -code 777 BOOM!} 1263 set c [chan create {r w} foo] 1264 note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] 1265 note $msg 1266 close $c 1267 rename foo {} 1268 set res 1269} -result {{write rc* snarfsnarfsnarf} 1 *bad code*} 1270test iocmd-24.12 {chan write, failed write, non-numeric return is error} -match glob -body { 1271 set res {} 1272 proc foo {args} {oninit; onfinal; track; return BANG} 1273 set c [chan create {r w} foo] 1274 note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] 1275 note $msg 1276 close $c 1277 rename foo {} 1278 set res 1279} -result {{write rc* snarfsnarfsnarf} 1 {expected integer but got "BANG"}} 1280test iocmd-24.13 {chan write, failed write, level is ignored} -match glob -body { 1281 set res {} 1282 proc foo {args} {oninit; onfinal; track; return -level 55 -code 777 BOOM!} 1283 set c [chan create {r w} foo] 1284 note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg opt] 1285 note $msg 1286 noteOpts $opt 1287 close $c 1288 rename foo {} 1289 set res 1290} -result {{write rc* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "write"*}} 1291test iocmd-24.14 {chan write, no EAGAIN means that writing is allowed at this time, bug 2936225} -match glob -setup { 1292 set res {} 1293 proc foo {args} { 1294 oninit; onfinal; track 1295 return 3 1296 } 1297 set c [chan create {r w} foo] 1298} -body { 1299 note [puts -nonewline $c ABC ; flush $c] 1300 set res 1301} -cleanup { 1302 close $c 1303 rename foo {} 1304 unset res 1305} -result {{write rc* ABC} {}} 1306test iocmd-24.15 {chan write, EAGAIN means that writing is not allowed at this time, bug 2936225} -match glob -setup { 1307 set res {} 1308 proc foo {args} { 1309 oninit; onfinal; track 1310 # Note: The EAGAIN signals that the channel cannot accept 1311 # write requests right now, this in turn causes the IO core to 1312 # request the generation of writable events (see expected 1313 # result below, and compare to case 24.14 above). 1314 error EAGAIN 1315 } 1316 set c [chan create {r w} foo] 1317} -body { 1318 note [puts -nonewline $c ABC ; flush $c] 1319 set res 1320} -cleanup { 1321 close $c 1322 rename foo {} 1323 unset res 1324} -result {{write rc* ABC} {watch rc* write} {}} 1325 1326# --- === *** ########################### 1327# method cgetall 1328 1329test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body { 1330 set res {} 1331 proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} 1332 set c [chan create {r w} foo] 1333 note [fconfigure $c] 1334 close $c 1335 rename foo {} 1336 set res 1337} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} 1338test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { 1339 set res {} 1340 proc foo {args} {oninit cget cgetall; onfinal; track; return ""} 1341 set c [chan create {r w} foo] 1342 note [fconfigure $c] 1343 close $c 1344 rename foo {} 1345 set res 1346} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} 1347test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { 1348 set res {} 1349 proc foo {args} { 1350 oninit cget cgetall; onfinal; track 1351 return "-bar foo -snarf x" 1352 } 1353 set c [chan create {r w} foo] 1354 note [fconfigure $c] 1355 close $c 1356 rename foo {} 1357 set res 1358} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *} -bar foo -snarf x}} 1359test iocmd-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { 1360 set res {} 1361 proc foo {args} { 1362 oninit cget cgetall; onfinal; track 1363 return "-bar" 1364 } 1365 set c [chan create {r w} foo] 1366 note [catch {fconfigure $c} msg]; note $msg 1367 close $c 1368 rename foo {} 1369 set res 1370} -result {{cgetall rc*} 1 {Expected list with even number of elements, got 1 element instead}} 1371test iocmd-25.5 {chan configure, cgetall, bad result, not a list} -match glob -body { 1372 set res {} 1373 proc foo {args} { 1374 oninit cget cgetall; onfinal; track 1375 return "\{" 1376 } 1377 set c [chan create {r w} foo] 1378 note [catch {fconfigure $c} msg]; note $msg 1379 close $c 1380 rename foo {} 1381 set res 1382} -result {{cgetall rc*} 1 {unmatched open brace in list}} 1383test iocmd-25.6 {chan configure, cgetall, error return} -match glob -body { 1384 set res {} 1385 proc foo {args} { 1386 oninit cget cgetall; onfinal; track 1387 return -code error BOOM! 1388 } 1389 set c [chan create {r w} foo] 1390 note [catch {fconfigure $c} msg]; note $msg 1391 close $c 1392 rename foo {} 1393 set res 1394} -result {{cgetall rc*} 1 BOOM!} 1395test iocmd-25.7 {chan configure, cgetall, break return is error} -match glob -body { 1396 set res {} 1397 proc foo {args} { 1398 oninit cget cgetall; onfinal; track 1399 return -code break BOOM! 1400 } 1401 set c [chan create {r w} foo] 1402 note [catch {fconfigure $c} msg]; note $msg 1403 close $c 1404 rename foo {} 1405 set res 1406} -result {{cgetall rc*} 1 *bad code*} 1407test iocmd-25.8 {chan configure, cgetall, continue return is error} -match glob -body { 1408 set res {} 1409 proc foo {args} { 1410 oninit cget cgetall; onfinal; track 1411 return -code continue BOOM! 1412 } 1413 set c [chan create {r w} foo] 1414 note [catch {fconfigure $c} msg]; note $msg 1415 close $c 1416 rename foo {} 1417 set res 1418} -result {{cgetall rc*} 1 *bad code*} 1419test iocmd-25.9 {chan configure, cgetall, custom return is error} -match glob -body { 1420 set res {} 1421 proc foo {args} { 1422 oninit cget cgetall; onfinal; track 1423 return -code 777 BOOM! 1424 } 1425 set c [chan create {r w} foo] 1426 note [catch {fconfigure $c} msg]; note $msg 1427 close $c 1428 rename foo {} 1429 set res 1430} -result {{cgetall rc*} 1 *bad code*} 1431test iocmd-25.10 {chan configure, cgetall, level is ignored} -match glob -body { 1432 set res {} 1433 proc foo {args} { 1434 oninit cget cgetall; onfinal; track 1435 return -level 55 -code 777 BANG 1436 } 1437 set c [chan create {r w} foo] 1438 note [catch {fconfigure $c} msg opt]; note $msg; noteOpts $opt 1439 close $c 1440 rename foo {} 1441 set res 1442} -result {{cgetall rc*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "cgetall"*}} 1443 1444# --- === *** ########################### 1445# method configure 1446 1447test iocmd-26.1 {chan configure, set standard option} -match glob -body { 1448 set res {} 1449 proc foo {args} { 1450 oninit configure; onfinal; track; note MUST_NOT_HAPPEN; return 1451 } 1452 set c [chan create {r w} foo] 1453 note [fconfigure $c -translation lf] 1454 close $c 1455 rename foo {} 1456 set res 1457} -result {{}} 1458test iocmd-26.2 {chan configure, set option, error return} -match glob -body { 1459 set res {} 1460 proc foo {args} { 1461 oninit configure; onfinal; track 1462 return -code error BOOM! 1463 } 1464 set c [chan create {r w} foo] 1465 note [catch {fconfigure $c -rc-foo bar} msg]; note $msg 1466 close $c 1467 rename foo {} 1468 set res 1469} -result {{configure rc* -rc-foo bar} 1 BOOM!} 1470test iocmd-26.3 {chan configure, set option, ok return} -match glob -body { 1471 set res {} 1472 proc foo {args} {oninit configure; onfinal; track; return} 1473 set c [chan create {r w} foo] 1474 note [fconfigure $c -rc-foo bar] 1475 close $c 1476 rename foo {} 1477 set res 1478} -result {{configure rc* -rc-foo bar} {}} 1479test iocmd-26.4 {chan configure, set option, break return is error} -match glob -body { 1480 set res {} 1481 proc foo {args} { 1482 oninit configure; onfinal; track 1483 return -code break BOOM! 1484 } 1485 set c [chan create {r w} foo] 1486 note [catch {fconfigure $c -rc-foo bar} msg]; note $msg 1487 close $c 1488 rename foo {} 1489 set res 1490} -result {{configure rc* -rc-foo bar} 1 *bad code*} 1491test iocmd-26.5 {chan configure, set option, continue return is error} -match glob -body { 1492 set res {} 1493 proc foo {args} { 1494 oninit configure; onfinal; track 1495 return -code continue BOOM! 1496 } 1497 set c [chan create {r w} foo] 1498 note [catch {fconfigure $c -rc-foo bar} msg]; note $msg 1499 close $c 1500 rename foo {} 1501 set res 1502} -result {{configure rc* -rc-foo bar} 1 *bad code*} 1503test iocmd-26.6 {chan configure, set option, custom return is error} -match glob -body { 1504 set res {} 1505 proc foo {args} { 1506 oninit configure; onfinal; track 1507 return -code 444 BOOM! 1508 } 1509 set c [chan create {r w} foo] 1510 note [catch {fconfigure $c -rc-foo bar} msg]; note $msg 1511 close $c 1512 rename foo {} 1513 set res 1514} -result {{configure rc* -rc-foo bar} 1 *bad code*} 1515test iocmd-26.7 {chan configure, set option, level is ignored} -match glob -body { 1516 set res {} 1517 proc foo {args} { 1518 oninit configure; onfinal; track 1519 return -level 55 -code 444 BANG 1520 } 1521 set c [chan create {r w} foo] 1522 note [catch {fconfigure $c -rc-foo bar} msg opt]; note $msg; noteOpts $opt 1523 close $c 1524 rename foo {} 1525 set res 1526} -result {{configure rc* -rc-foo bar} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "configure"*}} 1527 1528# --- === *** ########################### 1529# method cget 1530 1531test iocmd-27.1 {chan configure, get option, ok return} -match glob -body { 1532 set res {} 1533 proc foo {args} {oninit cget cgetall; onfinal; track; return foo} 1534 set c [chan create {r w} foo] 1535 note [fconfigure $c -rc-foo] 1536 close $c 1537 rename foo {} 1538 set res 1539} -result {{cget rc* -rc-foo} foo} 1540test iocmd-27.2 {chan configure, get option, error return} -match glob -body { 1541 set res {} 1542 proc foo {args} { 1543 oninit cget cgetall; onfinal; track 1544 return -code error BOOM! 1545 } 1546 set c [chan create {r w} foo] 1547 note [catch {fconfigure $c -rc-foo} msg]; note $msg 1548 close $c 1549 rename foo {} 1550 set res 1551} -result {{cget rc* -rc-foo} 1 BOOM!} 1552test iocmd-27.3 {chan configure, get option, break return is error} -match glob -body { 1553 set res {} 1554 proc foo {args} { 1555 oninit cget cgetall; onfinal; track 1556 return -code error BOOM! 1557 } 1558 set c [chan create {r w} foo] 1559 note [catch {fconfigure $c -rc-foo} msg]; note $msg 1560 close $c 1561 rename foo {} 1562 set res 1563} -result {{cget rc* -rc-foo} 1 BOOM!} 1564test iocmd-27.4 {chan configure, get option, continue return is error} -match glob -body { 1565 set res {} 1566 proc foo {args} { 1567 oninit cget cgetall; onfinal; track 1568 return -code continue BOOM! 1569 } 1570 set c [chan create {r w} foo] 1571 note [catch {fconfigure $c -rc-foo} msg]; note $msg 1572 close $c 1573 rename foo {} 1574 set res 1575} -result {{cget rc* -rc-foo} 1 *bad code*} 1576test iocmd-27.5 {chan configure, get option, custom return is error} -match glob -body { 1577 set res {} 1578 proc foo {args} { 1579 oninit cget cgetall; onfinal; track 1580 return -code 333 BOOM! 1581 } 1582 set c [chan create {r w} foo] 1583 note [catch {fconfigure $c -rc-foo} msg]; note $msg 1584 close $c 1585 rename foo {} 1586 set res 1587} -result {{cget rc* -rc-foo} 1 *bad code*} 1588test iocmd-27.6 {chan configure, get option, level is ignored} -match glob -body { 1589 set res {} 1590 proc foo {args} { 1591 oninit cget cgetall; onfinal; track 1592 return -level 77 -code 333 BANG 1593 } 1594 set c [chan create {r w} foo] 1595 note [catch {fconfigure $c -rc-foo} msg opt]; note $msg; noteOpts $opt 1596 close $c 1597 rename foo {} 1598 set res 1599} -result {{cget rc* -rc-foo} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "cget"*}} 1600 1601# --- === *** ########################### 1602# method seek 1603 1604test iocmd-28.1 {chan tell, not supported by handler} -match glob -body { 1605 set res {} 1606 proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} 1607 set c [chan create {r w} foo] 1608 note [tell $c] 1609 close $c 1610 rename foo {} 1611 set res 1612} -result {-1} 1613test iocmd-28.2 {chan tell, error return} -match glob -body { 1614 set res {} 1615 proc foo {args} {oninit seek; onfinal; track; return -code error BOOM!} 1616 set c [chan create {r w} foo] 1617 note [catch {tell $c} msg]; note $msg 1618 close $c 1619 rename foo {} 1620 set res 1621} -result {{seek rc* 0 current} 1 BOOM!} 1622test iocmd-28.3 {chan tell, break return is error} -match glob -body { 1623 set res {} 1624 proc foo {args} {oninit seek; onfinal; track; return -code break BOOM!} 1625 set c [chan create {r w} foo] 1626 note [catch {tell $c} msg]; note $msg 1627 close $c 1628 rename foo {} 1629 set res 1630} -result {{seek rc* 0 current} 1 *bad code*} 1631test iocmd-28.4 {chan tell, continue return is error} -match glob -body { 1632 set res {} 1633 proc foo {args} {oninit seek; onfinal; track; return -code continue BOOM!} 1634 set c [chan create {r w} foo] 1635 note [catch {tell $c} msg]; note $msg 1636 close $c 1637 rename foo {} 1638 set res 1639} -result {{seek rc* 0 current} 1 *bad code*} 1640test iocmd-28.5 {chan tell, custom return is error} -match glob -body { 1641 set res {} 1642 proc foo {args} {oninit seek; onfinal; track; return -code 222 BOOM!} 1643 set c [chan create {r w} foo] 1644 note [catch {tell $c} msg]; note $msg 1645 close $c 1646 rename foo {} 1647 set res 1648} -result {{seek rc* 0 current} 1 *bad code*} 1649test iocmd-28.6 {chan tell, level is ignored} -match glob -body { 1650 set res {} 1651 proc foo {args} {oninit seek; onfinal; track; return -level 11 -code 222 BANG} 1652 set c [chan create {r w} foo] 1653 note [catch {tell $c} msg opt]; note $msg; noteOpts $opt 1654 close $c 1655 rename foo {} 1656 set res 1657} -result {{seek rc* 0 current} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "seek"*}} 1658test iocmd-28.7 {chan tell, regular return} -match glob -body { 1659 set res {} 1660 proc foo {args} {oninit seek; onfinal; track; return 88} 1661 set c [chan create {r w} foo] 1662 note [tell $c] 1663 close $c 1664 rename foo {} 1665 set res 1666} -result {{seek rc* 0 current} 88} 1667test iocmd-28.8 {chan tell, negative return} -match glob -body { 1668 set res {} 1669 proc foo {args} {oninit seek; onfinal; track; return -1} 1670 set c [chan create {r w} foo] 1671 note [catch {tell $c} msg]; note $msg 1672 close $c 1673 rename foo {} 1674 set res 1675} -result {{seek rc* 0 current} 1 {Tried to seek before origin}} 1676test iocmd-28.9 {chan tell, string return} -match glob -body { 1677 set res {} 1678 proc foo {args} {oninit seek; onfinal; track; return BOGUS} 1679 set c [chan create {r w} foo] 1680 note [catch {tell $c} msg]; note $msg 1681 close $c 1682 rename foo {} 1683 set res 1684} -result {{seek rc* 0 current} 1 {expected integer but got "BOGUS"}} 1685test iocmd-28.10 {chan seek, not supported by handler} -match glob -body { 1686 set res {} 1687 proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} 1688 set c [chan create {r w} foo] 1689 note [catch {seek $c 0 start} msg]; note $msg 1690 close $c 1691 rename foo {} 1692 set res 1693} -result {1 {error during seek on "rc*": invalid argument}} 1694test iocmd-28.11 {chan seek, error return} -match glob -body { 1695 set res {} 1696 proc foo {args} {oninit seek; onfinal; track; return -code error BOOM!} 1697 set c [chan create {r w} foo] 1698 note [catch {seek $c 0 start} msg]; note $msg 1699 close $c 1700 rename foo {} 1701 set res 1702} -result {{seek rc* 0 start} 1 BOOM!} 1703test iocmd-28.12 {chan seek, break return is error} -match glob -body { 1704 set res {} 1705 proc foo {args} {oninit seek; onfinal; track; return -code break BOOM!} 1706 set c [chan create {r w} foo] 1707 note [catch {seek $c 0 start} msg]; note $msg 1708 close $c 1709 rename foo {} 1710 set res 1711} -result {{seek rc* 0 start} 1 *bad code*} 1712test iocmd-28.13 {chan seek, continue return is error} -match glob -body { 1713 set res {} 1714 proc foo {args} {oninit seek; onfinal; track; return -code continue BOOM!} 1715 set c [chan create {r w} foo] 1716 note [catch {seek $c 0 start} msg]; note $msg 1717 close $c 1718 rename foo {} 1719 set res 1720} -result {{seek rc* 0 start} 1 *bad code*} 1721test iocmd-28.14 {chan seek, custom return is error} -match glob -body { 1722 set res {} 1723 proc foo {args} {oninit seek; onfinal; track; return -code 99 BOOM!} 1724 set c [chan create {r w} foo] 1725 note [catch {seek $c 0 start} msg]; note $msg 1726 close $c 1727 rename foo {} 1728 set res 1729} -result {{seek rc* 0 start} 1 *bad code*} 1730test iocmd-28.15 {chan seek, level is ignored} -match glob -body { 1731 set res {} 1732 proc foo {args} {oninit seek; onfinal; track; return -level 33 -code 99 BANG} 1733 set c [chan create {r w} foo] 1734 note [catch {seek $c 0 start} msg opt]; note $msg; noteOpts $opt 1735 close $c 1736 rename foo {} 1737 set res 1738} -result {{seek rc* 0 start} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "seek"*}} 1739test iocmd-28.16 {chan seek, bogus return, negative location} -match glob -body { 1740 set res {} 1741 proc foo {args} {oninit seek; onfinal; track; return -45} 1742 set c [chan create {r w} foo] 1743 note [catch {seek $c 0 start} msg]; note $msg 1744 close $c 1745 rename foo {} 1746 set res 1747} -result {{seek rc* 0 start} 1 {Tried to seek before origin}} 1748test iocmd-28.17 {chan seek, bogus return, string return} -match glob -body { 1749 set res {} 1750 proc foo {args} {oninit seek; onfinal; track; return BOGUS} 1751 set c [chan create {r w} foo] 1752 note [catch {seek $c 0 start} msg]; note $msg 1753 close $c 1754 rename foo {} 1755 set res 1756} -result {{seek rc* 0 start} 1 {expected integer but got "BOGUS"}} 1757test iocmd-28.18 {chan seek, ok result} -match glob -body { 1758 set res {} 1759 proc foo {args} {oninit seek; onfinal; track; return 23} 1760 set c [chan create {r w} foo] 1761 note [seek $c 0 current] 1762 close $c 1763 rename foo {} 1764 set res 1765} -result {{seek rc* 0 current} {}} 1766foreach {testname code} { 1767 iocmd-28.19.0 start 1768 iocmd-28.19.1 current 1769 iocmd-28.19.2 end 1770} { 1771 test $testname "chan seek, base conversion, $code" -match glob -body { 1772 set res {} 1773 proc foo {args} {oninit seek; onfinal; track; return 0} 1774 set c [chan create {r w} foo] 1775 note [seek $c 0 $code] 1776 close $c 1777 rename foo {} 1778 set res 1779 } -result [list [list seek rc* 0 $code] {}] 1780} 1781 1782# --- === *** ########################### 1783# method blocking 1784 1785test iocmd-29.1 {chan blocking, no handler support} -match glob -body { 1786 set res {} 1787 proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} 1788 set c [chan create {r w} foo] 1789 note [fconfigure $c -blocking] 1790 close $c 1791 rename foo {} 1792 set res 1793} -result {1} 1794test iocmd-29.2 {chan blocking, no handler support} -match glob -body { 1795 set res {} 1796 proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} 1797 set c [chan create {r w} foo] 1798 note [fconfigure $c -blocking 0] 1799 note [fconfigure $c -blocking] 1800 close $c 1801 rename foo {} 1802 set res 1803} -result {{} 0} 1804test iocmd-29.3 {chan blocking, retrieval, handler support} -match glob -body { 1805 set res {} 1806 proc foo {args} {oninit blocking; onfinal; track; note MUST_NOT_HAPPEN; return} 1807 set c [chan create {r w} foo] 1808 note [fconfigure $c -blocking] 1809 close $c 1810 rename foo {} 1811 set res 1812} -result {1} 1813test iocmd-29.4 {chan blocking, resetting, handler support} -match glob -body { 1814 set res {} 1815 proc foo {args} {oninit blocking; onfinal; track; return} 1816 set c [chan create {r w} foo] 1817 note [fconfigure $c -blocking 0] 1818 note [fconfigure $c -blocking] 1819 close $c 1820 rename foo {} 1821 set res 1822} -result {{blocking rc* 0} {} 0} 1823test iocmd-29.5 {chan blocking, setting, handler support} -match glob -body { 1824 set res {} 1825 proc foo {args} {oninit blocking; onfinal; track; return} 1826 set c [chan create {r w} foo] 1827 note [fconfigure $c -blocking 1] 1828 note [fconfigure $c -blocking] 1829 close $c 1830 rename foo {} 1831 set res 1832} -result {{blocking rc* 1} {} 1} 1833test iocmd-29.6 {chan blocking, error return} -match glob -body { 1834 set res {} 1835 proc foo {args} {oninit blocking; onfinal; track; error BOOM!} 1836 set c [chan create {r w} foo] 1837 note [catch {fconfigure $c -blocking 0} msg]; note $msg 1838 # Catch the close. It changes blocking mode internally, and runs into the error result. 1839 catch {close $c} 1840 rename foo {} 1841 set res 1842} -result {{blocking rc* 0} 1 BOOM!} 1843test iocmd-29.7 {chan blocking, break return is error} -match glob -body { 1844 set res {} 1845 proc foo {args} {oninit blocking; onfinal; track; return -code break BOOM!} 1846 set c [chan create {r w} foo] 1847 note [catch {fconfigure $c -blocking 0} msg]; note $msg 1848 catch {close $c} 1849 rename foo {} 1850 set res 1851} -result {{blocking rc* 0} 1 *bad code*} 1852test iocmd-29.8 {chan blocking, continue return is error} -match glob -body { 1853 set res {} 1854 proc foo {args} {oninit blocking; onfinal; track; return -code continue BOOM!} 1855 set c [chan create {r w} foo] 1856 note [catch {fconfigure $c -blocking 0} msg]; note $msg 1857 catch {close $c} 1858 rename foo {} 1859 set res 1860} -result {{blocking rc* 0} 1 *bad code*} 1861test iocmd-29.9 {chan blocking, custom return is error} -match glob -body { 1862 set res {} 1863 proc foo {args} {oninit blocking; onfinal; track; return -code 44 BOOM!} 1864 set c [chan create {r w} foo] 1865 note [catch {fconfigure $c -blocking 0} msg]; note $msg 1866 catch {close $c} 1867 rename foo {} 1868 set res 1869} -result {{blocking rc* 0} 1 *bad code*} 1870test iocmd-29.10 {chan blocking, level is ignored} -match glob -setup { 1871 set res {} 1872} -body { 1873 proc foo {args} {oninit blocking; onfinal; track; return -level 99 -code 44 BANG} 1874 set c [chan create {r w} foo] 1875 note [catch {fconfigure $c -blocking 0} msg opt]; note $msg; noteOpts $opt 1876 catch {close $c} 1877 return $res 1878} -cleanup { 1879 rename foo {} 1880} -result {{blocking rc* 0} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "blocking"*}} 1881test iocmd-29.11 {chan blocking, regular return ok, value ignored} -match glob -body { 1882 set res {} 1883 proc foo {args} {oninit blocking; onfinal; track; return BOGUS} 1884 set c [chan create {r w} foo] 1885 note [catch {fconfigure $c -blocking 0} msg]; note $msg 1886 catch {close $c} 1887 rename foo {} 1888 set res 1889} -result {{blocking rc* 0} 0 {}} 1890 1891# --- === *** ########################### 1892# method watch 1893 1894test iocmd-30.1 {chan watch, read interest, some return} -match glob -body { 1895 set res {} 1896 proc foo {args} {oninit; onfinal; track; return IGNORED} 1897 set c [chan create {r w} foo] 1898 note [fileevent $c readable {set tick $tick}] 1899 close $c ;# 2nd watch, interest zero. 1900 rename foo {} 1901 set res 1902} -result {{watch rc* read} {} {watch rc* {}}} 1903test iocmd-30.2 {chan watch, write interest, error return} -match glob -body { 1904 set res {} 1905 proc foo {args} {oninit; onfinal; track; return -code error BOOM!_IGNORED} 1906 set c [chan create {r w} foo] 1907 note [fileevent $c writable {set tick $tick}] 1908 note [fileevent $c writable {}] 1909 close $c 1910 rename foo {} 1911 set res 1912} -result {{watch rc* write} {} {watch rc* {}} {}} 1913test iocmd-30.3 {chan watch, accumulated interests} -match glob -body { 1914 set res {} 1915 proc foo {args} {oninit; onfinal; track; return} 1916 set c [chan create {r w} foo] 1917 note [fileevent $c writable {set tick $tick}] 1918 note [fileevent $c readable {set tick $tick}] 1919 note [fileevent $c writable {}] 1920 note [fileevent $c readable {}] 1921 close $c 1922 rename foo {} 1923 set res 1924} -result {{watch rc* write} {} {watch rc* {read write}} {} {watch rc* read} {} {watch rc* {}} {}} 1925test iocmd-30.4 {chan watch, unchanged interest not forwarded} -match glob -body { 1926 set res {} 1927 proc foo {args} {oninit; onfinal; track; return} 1928 set c [chan create {r w} foo] 1929 note [fileevent $c writable {set tick $tick}] 1930 note [fileevent $c readable {set tick $tick}] ;# Script is changing, 1931 note [fileevent $c readable {set tock $tock}] ;# interest does not. 1932 close $c ;# 3rd and 4th watch, removing the event handlers. 1933 rename foo {} 1934 set res 1935} -result {{watch rc* write} {} {watch rc* {read write}} {} {} {watch rc* write} {watch rc* {}}} 1936 1937# --- === *** ########################### 1938# chan postevent 1939 1940test iocmd-31.1 {chan postevent, restricted to reflected channels} -match glob -body { 1941 set c [open [makeFile {} goo] r] 1942 catch {chan postevent $c {r w}} msg 1943 close $c 1944 removeFile goo 1945 set msg 1946} -result {can not find reflected channel named "file*"} 1947test iocmd-31.2 {chan postevent, unwanted events} -match glob -body { 1948 set res {} 1949 proc foo {args} {oninit; onfinal; track; return} 1950 set c [chan create {r w} foo] 1951 catch {chan postevent $c {r w}} msg; note $msg 1952 close $c 1953 rename foo {} 1954 set res 1955} -result {{tried to post events channel "rc*" is not interested in}} 1956test iocmd-31.3 {chan postevent, bad input, empty list} -match glob -body { 1957 set res {} 1958 proc foo {args} {oninit; onfinal; track; return} 1959 set c [chan create {r w} foo] 1960 catch {chan postevent $c {}} msg; note $msg 1961 close $c 1962 rename foo {} 1963 set res 1964} -result {{bad event list: is empty}} 1965test iocmd-31.4 {chan postevent, bad input, illlegal keyword} -match glob -body { 1966 set res {} 1967 proc foo {args} {oninit; onfinal; track; return} 1968 set c [chan create {r w} foo] 1969 catch {chan postevent $c goo} msg; note $msg 1970 close $c 1971 rename foo {} 1972 set res 1973} -result {{bad event "goo": must be read or write}} 1974test iocmd-31.5 {chan postevent, bad input, not a list} -match glob -body { 1975 set res {} 1976 proc foo {args} {oninit; onfinal; track; return} 1977 set c [chan create {r w} foo] 1978 catch {chan postevent $c "\{"} msg; note $msg 1979 close $c 1980 rename foo {} 1981 set res 1982} -result {{unmatched open brace in list}} 1983test iocmd-31.6 {chan postevent, posted events do happen} -match glob -body { 1984 set res {} 1985 proc foo {args} {oninit; onfinal; track; return} 1986 set c [chan create {r w} foo] 1987 note [fileevent $c readable {note TOCK}] 1988 set stop [after 15000 {note TIMEOUT}] 1989 after 1000 {note [chan postevent $c r]} 1990 vwait ::res 1991 catch {after cancel $stop} 1992 close $c 1993 rename foo {} 1994 set res 1995} -result {{watch rc* read} {} TOCK {} {watch rc* {}}} 1996test iocmd-31.7 {chan postevent, posted events do happen} -match glob -body { 1997 set res {} 1998 proc foo {args} {oninit; onfinal; track; return} 1999 set c [chan create {r w} foo] 2000 note [fileevent $c writable {note TOCK}] 2001 set stop [after 15000 {note TIMEOUT}] 2002 after 1000 {note [chan postevent $c w]} 2003 vwait ::res 2004 catch {after cancel $stop} 2005 close $c 2006 rename foo {} 2007 set res 2008} -result {{watch rc* write} {} TOCK {} {watch rc* {}}} 2009test iocmd-31.8 {chan postevent after close throws error} -match glob -setup { 2010 proc foo {args} {oninit; onfinal; track; return} 2011 proc dummy args { return } 2012 set c [chan create {r w} foo] 2013 fileevent $c readable dummy 2014} -body { 2015 close $c 2016 chan postevent $c read 2017} -cleanup { 2018 rename foo {} 2019 rename dummy {} 2020} -returnCodes error -result {can not find reflected channel named "rc*"} 2021 2022# --- === *** ########################### 2023# 'Pull the rug' tests. Create channel in a interpreter A, move to 2024# other interpreter B, destroy the origin interpreter (A) before or 2025# during access from B. Must not crash, must return proper errors. 2026 2027test iocmd-32.0 {origin interpreter of moved channel gone} -match glob -body { 2028 2029 set ida [interp create];#puts <<$ida>> 2030 set idb [interp create];#puts <<$idb>> 2031 2032 # Magic to get the test* commands in the children 2033 load {} Tcltest $ida 2034 load {} Tcltest $idb 2035 2036 # Set up channel in interpreter 2037 interp eval $ida $helperscript 2038 set chan [interp eval $ida { 2039 proc foo {args} {oninit seek; onfinal; track; return} 2040 set chan [chan create {r w} foo] 2041 fconfigure $chan -buffering none 2042 set chan 2043 }] 2044 2045 # Move channel to 2nd interpreter. 2046 interp eval $ida [list testchannel cut $chan] 2047 interp eval $idb [list testchannel splice $chan] 2048 2049 # Kill origin interpreter, then access channel from 2nd interpreter. 2050 interp delete $ida 2051 2052 set res {} 2053 lappend res [catch {interp eval $idb [list puts $chan shoo]} msg] $msg 2054 lappend res [catch {interp eval $idb [list tell $chan]} msg] $msg 2055 lappend res [catch {interp eval $idb [list seek $chan 1]} msg] $msg 2056 lappend res [catch {interp eval $idb [list gets $chan]} msg] $msg 2057 lappend res [catch {interp eval $idb [list close $chan]} msg] $msg 2058 set res 2059 2060} -cleanup { 2061 interp delete $idb 2062} -constraints {testchannel} \ 2063 -result {1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} 2064 2065test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -match glob -body { 2066 2067 set ida [interp create];#puts <<$ida>> 2068 set idb [interp create];#puts <<$idb>> 2069 2070 # Magic to get the test* commands in the children 2071 load {} Tcltest $ida 2072 load {} Tcltest $idb 2073 2074 # Set up channel in thread 2075 set chan [interp eval $ida $helperscript] 2076 set chan [interp eval $ida { 2077 proc foo {args} { 2078 oninit; onfinal; track; 2079 # destroy interpreter during channel access 2080 suicide 2081 } 2082 set chan [chan create {r w} foo] 2083 fconfigure $chan -buffering none 2084 set chan 2085 }] 2086 interp alias $ida suicide {} interp delete $ida 2087 2088 # Move channel to 2nd thread. 2089 interp eval $ida [list testchannel cut $chan] 2090 interp eval $idb [list testchannel splice $chan] 2091 2092 # Run access from interpreter B, this will give us a synchronous 2093 # response. 2094 2095 interp eval $idb [list set chan $chan] 2096 set res [interp eval $idb { 2097 # wait a bit, give the main thread the time to start its event 2098 # loop to wait for the response from B 2099 after 2000 2100 catch { puts $chan shoo } res 2101 set res 2102 }] 2103 set res 2104} -cleanup { 2105 interp delete $idb 2106} -constraints {testchannel} -result {Owner lost} 2107 2108test iocmd-32.2 {delete interp of reflected chan} { 2109 # Bug 3034840 2110 # Run this test in an interp with memory debugging to panic 2111 # on the double free 2112 interp create child 2113 child eval { 2114 proc no-op args {} 2115 proc driver {sub args} {return {initialize finalize watch read}} 2116 chan event [chan create read driver] readable no-op 2117 } 2118 interp delete child 2119} {} 2120 2121# ### ### ### ######### ######### ######### 2122## Same tests as above, but exercising the code forwarding and 2123## receiving driver operations to the originator thread. 2124 2125# -*- tcl -*- 2126# ### ### ### ######### ######### ######### 2127## Testing the reflected channel (Thread forwarding). 2128# 2129## The id numbers refer to the original test without thread 2130## forwarding, and gaps due to tests not applicable to forwarding are 2131## left to keep this asociation. 2132 2133# ### ### ### ######### ######### ######### 2134## Helper command. Runs a script in a separate thread and returns the 2135## result. A channel is transfered into the thread as well, and list of 2136## configuation variables 2137 2138proc inthread {chan script args} { 2139 # Test thread. 2140 2141 set tid [thread::create -preserved] 2142 thread::send $tid {load {} Tcltest} 2143 2144 # Init thread configuration. 2145 # - Listed variables 2146 # - Id of main thread 2147 # - A number of helper commands 2148 2149 foreach v $args { 2150 upvar 1 $v x 2151 thread::send $tid [list set $v $x] 2152 2153 } 2154 thread::send $tid [list set mid [thread::id]] 2155 thread::send $tid { 2156 proc note {item} {global notes; lappend notes $item} 2157 proc notes {} {global notes; return $notes} 2158 proc noteOpts opts {global notes; lappend notes [dict merge { 2159 -code !?! -level !?! -errorcode !?! -errorline !?! -errorinfo !?! 2160 } $opts]} 2161 } 2162 thread::send $tid [list proc s {} [list uplevel 1 $script]]; # (*) 2163 2164 # Transfer channel (cut/splice aka detach/attach) 2165 2166 testchannel cut $chan 2167 thread::send $tid [list testchannel splice $chan] 2168 2169 # Run test script, also run local event loop! 2170 # The local event loop waits for the result to come back. 2171 # It is also necessary for the execution of forwarded channel 2172 # operations. 2173 2174 set ::tres "" 2175 thread::send -async $tid { 2176 after 500 2177 catch {s} res; # This runs the script, 's' was defined at (*) 2178 thread::send -async $mid [list set ::tres $res] 2179 } 2180 vwait ::tres 2181 # Remove test thread, and return the captured result. 2182 2183 thread::release $tid 2184 return $::tres 2185} 2186 2187# ### ### ### ######### ######### ######### 2188 2189# ### ### ### ######### ######### ######### 2190 2191test iocmd.tf-22.2 {chan finalize, for close} -match glob -body { 2192 set res {} 2193 proc foo {args} {track; oninit; return {}} 2194 note [set c [chan create {r w} foo]] 2195 note [inthread $c { 2196 close $c 2197 # Close the deleted the channel. 2198 file channels rc* 2199 } c] 2200 # Channel destruction does not kill handler command! 2201 note [info command foo] 2202 rename foo {} 2203 set res 2204} -constraints {testchannel thread} -result {{initialize rc* {read write}} rc* {finalize rc*} {} foo} 2205test iocmd.tf-22.3 {chan finalize, for close, error, close error} -match glob -body { 2206 set res {} 2207 proc foo {args} {track; oninit; return -code error 5} 2208 note [set c [chan create {r w} foo]] 2209 notes [inthread $c { 2210 note [catch {close $c} msg]; note $msg 2211 # Channel is gone despite error. 2212 note [file channels rc*] 2213 notes 2214 } c] 2215 rename foo {} 2216 set res 2217} -constraints {testchannel thread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 5 {}} 2218test iocmd.tf-22.4 {chan finalize, for close, error, close errror} -match glob -body { 2219 set res {} 2220 proc foo {args} {track; oninit; error FOO} 2221 note [set c [chan create {r w} foo]] 2222 notes [inthread $c { 2223 note [catch {close $c} msg]; note $msg 2224 notes 2225 } c] 2226 rename foo {} 2227 set res 2228} -constraints {testchannel thread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 FOO} 2229test iocmd.tf-22.5 {chan finalize, for close, arbitrary result} -match glob -body { 2230 set res {} 2231 proc foo {args} {track; oninit; return SOMETHING} 2232 note [set c [chan create {r w} foo]] 2233 notes [inthread $c { 2234 note [catch {close $c} msg]; note $msg 2235 notes 2236 } c] 2237 rename foo {} 2238 set res 2239} -constraints {testchannel thread} -result {{initialize rc* {read write}} rc* {finalize rc*} 0 {}} 2240test iocmd.tf-22.6 {chan finalize, for close, break, close error} -match glob -body { 2241 set res {} 2242 proc foo {args} {track; oninit; return -code 3} 2243 note [set c [chan create {r w} foo]] 2244 notes [inthread $c { 2245 note [catch {close $c} msg]; note $msg 2246 notes 2247 } c] 2248 rename foo {} 2249 set res 2250} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 *bad code*} \ 2251 -constraints {testchannel thread} 2252test iocmd.tf-22.7 {chan finalize, for close, continue, close error} -match glob -body { 2253 set res {} 2254 proc foo {args} {track; oninit; return -code 4} 2255 note [set c [chan create {r w} foo]] 2256 notes [inthread $c { 2257 note [catch {close $c} msg]; note $msg 2258 notes 2259 } c] 2260 rename foo {} 2261 set res 2262} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 *bad code*} \ 2263 -constraints {testchannel thread} 2264test iocmd.tf-22.8 {chan finalize, for close, custom code, close error} -match glob -body { 2265 set res {} 2266 proc foo {args} {track; oninit; return -code 777 BANG} 2267 note [set c [chan create {r w} foo]] 2268 notes [inthread $c { 2269 note [catch {close $c} msg]; note $msg 2270 notes 2271 } c] 2272 rename foo {} 2273 set res 2274} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 *bad code*} \ 2275 -constraints {testchannel thread} 2276test iocmd.tf-22.9 {chan finalize, for close, ignore level, close error} -match glob -body { 2277 set res {} 2278 proc foo {args} {track; oninit; return -level 5 -code 777 BANG} 2279 note [set c [chan create {r w} foo]] 2280 notes [inthread $c { 2281 note [catch {close $c} msg opt]; note $msg; noteOpts $opt 2282 notes 2283 } c] 2284 rename foo {} 2285 set res 2286} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}} \ 2287 -constraints {testchannel thread} 2288 2289# --- === *** ########################### 2290# method read 2291 2292test iocmd.tf-23.1 {chan read, regular data return} -match glob -body { 2293 set res {} 2294 proc foo {args} { 2295 oninit; onfinal; track 2296 return snarf 2297 } 2298 set c [chan create {r w} foo] 2299 notes [inthread $c { 2300 note [read $c 10] 2301 close $c 2302 notes 2303 } c] 2304 rename foo {} 2305 set res 2306} -constraints {testchannel thread} -result {{read rc* 4096} {read rc* 4096} snarfsnarf} 2307test iocmd.tf-23.2 {chan read, bad data return, to much} -match glob -body { 2308 set res {} 2309 proc foo {args} { 2310 oninit; onfinal; track 2311 return [string repeat snarf 1000] 2312 } 2313 set c [chan create {r w} foo] 2314 notes [inthread $c { 2315 note [catch {[read $c 2]} msg]; note $msg 2316 close $c 2317 notes 2318 } c] 2319 rename foo {} 2320 set res 2321} -constraints {testchannel thread} -result {{read rc* 4096} 1 {read delivered more than requested}} 2322test iocmd.tf-23.3 {chan read, for non-readable channel} -match glob -body { 2323 set res {} 2324 proc foo {args} { 2325 oninit; onfinal; track; note MUST_NOT_HAPPEN 2326 } 2327 set c [chan create {w} foo] 2328 notes [inthread $c { 2329 note [catch {[read $c 2]} msg]; note $msg 2330 close $c 2331 notes 2332 } c] 2333 rename foo {} 2334 set res 2335} -constraints {testchannel thread} -result {1 {channel "rc*" wasn't opened for reading}} 2336test iocmd.tf-23.4 {chan read, error return} -match glob -body { 2337 set res {} 2338 proc foo {args} { 2339 oninit; onfinal; track 2340 return -code error BOOM! 2341 } 2342 set c [chan create {r w} foo] 2343 notes [inthread $c { 2344 note [catch {read $c 2} msg]; note $msg 2345 close $c 2346 notes 2347 } c] 2348 rename foo {} 2349 set res 2350} -result {{read rc* 4096} 1 BOOM!} \ 2351 -constraints {testchannel thread} 2352test iocmd.tf-23.5 {chan read, break return is error} -match glob -body { 2353 set res {} 2354 proc foo {args} { 2355 oninit; onfinal; track 2356 return -code break BOOM! 2357 } 2358 set c [chan create {r w} foo] 2359 notes [inthread $c { 2360 note [catch {read $c 2} msg]; note $msg 2361 close $c 2362 notes 2363 } c] 2364 rename foo {} 2365 set res 2366} -result {{read rc* 4096} 1 *bad code*} \ 2367 -constraints {testchannel thread} 2368test iocmd.tf-23.6 {chan read, continue return is error} -match glob -body { 2369 set res {} 2370 proc foo {args} { 2371 oninit; onfinal; track 2372 return -code continue BOOM! 2373 } 2374 set c [chan create {r w} foo] 2375 notes [inthread $c { 2376 note [catch {read $c 2} msg]; note $msg 2377 close $c 2378 notes 2379 } c] 2380 rename foo {} 2381 set res 2382} -result {{read rc* 4096} 1 *bad code*} \ 2383 -constraints {testchannel thread} 2384test iocmd.tf-23.7 {chan read, custom return is error} -match glob -body { 2385 set res {} 2386 proc foo {args} { 2387 oninit; onfinal; track 2388 return -code 777 BOOM! 2389 } 2390 set c [chan create {r w} foo] 2391 notes [inthread $c { 2392 note [catch {read $c 2} msg]; note $msg 2393 close $c 2394 notes 2395 } c] 2396 rename foo {} 2397 set res 2398} -result {{read rc* 4096} 1 *bad code*} \ 2399 -constraints {testchannel thread} 2400test iocmd.tf-23.8 {chan read, level is squashed} -match glob -body { 2401 set res {} 2402 proc foo {args} { 2403 oninit; onfinal; track 2404 return -level 55 -code 777 BOOM! 2405 } 2406 set c [chan create {r w} foo] 2407 notes [inthread $c { 2408 note [catch {read $c 2} msg opt]; note $msg; noteOpts $opt 2409 close $c 2410 notes 2411 } c] 2412 rename foo {} 2413 set res 2414} -result {{read rc* 4096} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}} \ 2415 -constraints {testchannel thread} 2416test iocmd.tf-23.9 {chan read, no data means eof} -match glob -setup { 2417 set res {} 2418 proc foo {args} { 2419 oninit; onfinal; track 2420 return "" 2421 } 2422 set c [chan create {r w} foo] 2423} -body { 2424 notes [inthread $c { 2425 note [read $c 2] 2426 note [eof $c] 2427 close $c 2428 notes 2429 } c] 2430 set res 2431} -cleanup { 2432 rename foo {} 2433 unset res 2434} -result {{read rc* 4096} {} 1} \ 2435 -constraints {testchannel thread} 2436test iocmd.tf-23.10 {chan read, EAGAIN means no data, yet no eof either} -match glob -setup { 2437 set res {} 2438 proc foo {args} { 2439 oninit; onfinal; track 2440 error EAGAIN 2441 } 2442 set c [chan create {r w} foo] 2443} -body { 2444 notes [inthread $c { 2445 note [read $c 2] 2446 note [eof $c] 2447 close $c 2448 notes 2449 } c] 2450 set res 2451} -cleanup { 2452 rename foo {} 2453 unset res 2454} -result {{read rc* 4096} {} 0} \ 2455 -constraints {testchannel thread} 2456 2457# --- === *** ########################### 2458# method write 2459 2460test iocmd.tf-24.1 {chan write, regular write} -match glob -body { 2461 set res {} 2462 proc foo {args} { 2463 oninit; onfinal; track 2464 set written [string length [lindex $args 2]] 2465 note $written 2466 return $written 2467 } 2468 set c [chan create {r w} foo] 2469 inthread $c { 2470 puts -nonewline $c snarf; flush $c 2471 close $c 2472 } c 2473 rename foo {} 2474 set res 2475} -constraints {testchannel thread} -result {{write rc* snarf} 5} 2476test iocmd.tf-24.2 {chan write, ack partial writes} -match glob -body { 2477 set res {} 2478 proc foo {args} { 2479 oninit; onfinal; track 2480 set written [string length [lindex $args 2]] 2481 if {$written > 10} {set written [expr {$written / 2}]} 2482 note $written 2483 return $written 2484 } 2485 set c [chan create {r w} foo] 2486 inthread $c { 2487 puts -nonewline $c snarfsnarfsnarf; flush $c 2488 close $c 2489 } c 2490 rename foo {} 2491 set res 2492} -constraints {testchannel thread} -result {{write rc* snarfsnarfsnarf} 7 {write rc* arfsnarf} 8} 2493test iocmd.tf-24.3 {chan write, failed write} -match glob -body { 2494 set res {} 2495 proc foo {args} {oninit; onfinal; track; note -1; return -1} 2496 set c [chan create {r w} foo] 2497 inthread $c { 2498 puts -nonewline $c snarfsnarfsnarf; flush $c 2499 close $c 2500 } c 2501 rename foo {} 2502 set res 2503} -constraints {testchannel thread} -result {{write rc* snarfsnarfsnarf} -1} 2504test iocmd.tf-24.4 {chan write, non-writable channel} -match glob -body { 2505 set res {} 2506 proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} 2507 set c [chan create {r} foo] 2508 notes [inthread $c { 2509 note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] 2510 note $msg 2511 close $c 2512 notes 2513 } c] 2514 rename foo {} 2515 set res 2516} -constraints {testchannel thread} -result {1 {channel "rc*" wasn't opened for writing}} 2517test iocmd.tf-24.5 {chan write, bad result, more written than data} -match glob -body { 2518 set res {} 2519 proc foo {args} {oninit; onfinal; track; return 10000} 2520 set c [chan create {r w} foo] 2521 notes [inthread $c { 2522 note [catch {puts -nonewline $c snarf; flush $c} msg] 2523 note $msg 2524 close $c 2525 notes 2526 } c] 2527 rename foo {} 2528 set res 2529} -constraints {testchannel thread} -result {{write rc* snarf} 1 {write wrote more than requested}} 2530test iocmd.tf-24.6 {chan write, zero writes} -match glob -body { 2531 set res {} 2532 proc foo {args} {oninit; onfinal; track; return 0} 2533 set c [chan create {r w} foo] 2534 notes [inthread $c { 2535 note [catch {puts -nonewline $c snarf; flush $c} msg] 2536 note $msg 2537 close $c 2538 notes 2539 } c] 2540 rename foo {} 2541 set res 2542} -constraints {testchannel thread} -result {{write rc* snarf} 1 {write wrote more than requested}} 2543test iocmd.tf-24.7 {chan write, failed write, error return} -match glob -body { 2544 set res {} 2545 proc foo {args} {oninit; onfinal; track; return -code error BOOM!} 2546 set c [chan create {r w} foo] 2547 notes [inthread $c { 2548 note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] 2549 note $msg 2550 close $c 2551 notes 2552 } c] 2553 rename foo {} 2554 set res 2555} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \ 2556 -constraints {testchannel thread} 2557test iocmd.tf-24.8 {chan write, failed write, error return} -match glob -body { 2558 set res {} 2559 proc foo {args} {oninit; onfinal; track; error BOOM!} 2560 set c [chan create {r w} foo] 2561 notes [inthread $c { 2562 note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] 2563 note $msg 2564 close $c 2565 notes 2566 } c] 2567 rename foo {} 2568 set res 2569} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \ 2570 -constraints {testchannel thread} 2571test iocmd.tf-24.9 {chan write, failed write, break return is error} -match glob -body { 2572 set res {} 2573 proc foo {args} {oninit; onfinal; track; return -code break BOOM!} 2574 set c [chan create {r w} foo] 2575 notes [inthread $c { 2576 note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] 2577 note $msg 2578 close $c 2579 notes 2580 } c] 2581 rename foo {} 2582 set res 2583} -result {{write rc* snarfsnarfsnarf} 1 *bad code*} \ 2584 -constraints {testchannel thread} 2585test iocmd.tf-24.10 {chan write, failed write, continue return is error} -match glob -body { 2586 set res {} 2587 proc foo {args} {oninit; onfinal; track; return -code continue BOOM!} 2588 set c [chan create {r w} foo] 2589 notes [inthread $c { 2590 note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] 2591 note $msg 2592 close $c 2593 notes 2594 } c] 2595 rename foo {} 2596 set res 2597} -result {{write rc* snarfsnarfsnarf} 1 *bad code*} \ 2598 -constraints {testchannel thread} 2599test iocmd.tf-24.11 {chan write, failed write, custom return is error} -match glob -body { 2600 set res {} 2601 proc foo {args} {oninit; onfinal; track; return -code 777 BOOM!} 2602 set c [chan create {r w} foo] 2603 notes [inthread $c { 2604 note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] 2605 note $msg 2606 close $c 2607 notes 2608 } c] 2609 rename foo {} 2610 set res 2611} -result {{write rc* snarfsnarfsnarf} 1 *bad code*} \ 2612 -constraints {testchannel thread} 2613test iocmd.tf-24.12 {chan write, failed write, non-numeric return is error} -match glob -body { 2614 set res {} 2615 proc foo {args} {oninit; onfinal; track; return BANG} 2616 set c [chan create {r w} foo] 2617 notes [inthread $c { 2618 note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] 2619 note $msg 2620 close $c 2621 notes 2622 } c] 2623 rename foo {} 2624 set res 2625} -result {{write rc* snarfsnarfsnarf} 1 {expected integer but got "BANG"}} \ 2626 -constraints {testchannel thread} 2627test iocmd.tf-24.13 {chan write, failed write, level is ignored} -match glob -body { 2628 set res {} 2629 proc foo {args} {oninit; onfinal; track; return -level 55 -code 777 BOOM!} 2630 set c [chan create {r w} foo] 2631 notes [inthread $c { 2632 note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg opt] 2633 note $msg 2634 noteOpts $opt 2635 close $c 2636 notes 2637 } c] 2638 rename foo {} 2639 set res 2640} -result {{write rc* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "write"*}} \ 2641 -constraints {testchannel thread} 2642test iocmd.tf-24.14 {chan write, no EAGAIN means that writing is allowed at this time, bug 2936225} -match glob -setup { 2643 set res {} 2644 proc foo {args} { 2645 oninit; onfinal; track 2646 return 3 2647 } 2648 set c [chan create {r w} foo] 2649} -body { 2650 notes [inthread $c { 2651 note [puts -nonewline $c ABC ; flush $c] 2652 close $c 2653 notes 2654 } c] 2655 set res 2656} -cleanup { 2657 rename foo {} 2658 unset res 2659} -result {{write rc* ABC} {}} \ 2660 -constraints {testchannel thread} 2661test iocmd.tf-24.15 {chan write, EAGAIN means that writing is not allowed at this time, bug 2936225} -match glob -setup { 2662 set res {} 2663 proc foo {args} { 2664 oninit; onfinal; track 2665 # Note: The EAGAIN signals that the channel cannot accept 2666 # write requests right now, this in turn causes the IO core to 2667 # request the generation of writable events (see expected 2668 # result below, and compare to case 24.14 above). 2669 error EAGAIN 2670 } 2671 set c [chan create {r w} foo] 2672} -body { 2673 notes [inthread $c { 2674 note [puts -nonewline $c ABC ; flush $c] 2675 close $c 2676 notes 2677 } c] 2678 set res 2679} -cleanup { 2680 proc foo {args} {onfinal; set ::done-24.15 1; return 3} 2681 after 1000 {set ::done-24.15 2} 2682 vwait done-24.15 2683 rename foo {} 2684 unset res 2685} -result {{write rc* ABC} {watch rc* write} {}} \ 2686 -constraints {testchannel thread} 2687 2688test iocmd.tf-24.16 {chan write, note the background flush setup by close due to the EAGAIN leaving data in buffers.} -match glob -setup { 2689 set res {} 2690 proc foo {args} { 2691 oninit; onfinal; track 2692 # Note: The EAGAIN signals that the channel cannot accept 2693 # write requests right now, this in turn causes the IO core to 2694 # request the generation of writable events (see expected 2695 # result below, and compare to case 24.14 above). 2696 error EAGAIN 2697 } 2698 set c [chan create {r w} foo] 2699} -body { 2700 notes [inthread $c { 2701 note [puts -nonewline $c ABC ; flush $c] 2702 close $c 2703 notes 2704 } c] 2705 # Replace handler with all-tracking one which doesn't error. 2706 # This will tell us if a write-due-flush is there. 2707 proc foo {args} { onfinal; note BG ; track ; set ::endbody-24.16 1} 2708 # Flush (sic!) the event-queue to capture the write from a 2709 # BG-flush. 2710 after 1000 {set ::endbody-24.16 2} 2711 vwait endbody-24.16 2712 set res 2713} -cleanup { 2714 proc foo {args} {onfinal; set ::done-24.16 1; return 3} 2715 after 1000 {set ::done-24.16 2} 2716 vwait done-24.16 2717 rename foo {} 2718 unset res 2719} -result {{write rc* ABC} {watch rc* write} {} BG {write rc* ABC}} \ 2720 -constraints {testchannel thread} 2721 2722test iocmd.tf-24.17.bug3522560 {postevent for transfered channel} \ 2723 -constraints {testchannel thread} -setup { 2724 # This test exposes how the execution of postevent in the handler thread causes 2725 # a crash if we are not properly injecting the events into the owning thread instead. 2726 # With the injection the test will simply complete without crash. 2727 2728 set beat 10000 2729 set drive 999 2730 set data ...---... 2731 2732 proc LOG {text} { 2733 #puts stderr "[thread::id]: $text" 2734 return 2735 } 2736 2737 proc POST {hi} { 2738 LOG "-> [info level 0]" 2739 chan postevent $hi read 2740 LOG "<- [info level 0]" 2741 2742 set ::timer [after $::drive [info level 0]] 2743 return 2744 } 2745 2746 proc HANDLER {op ch args} { 2747 lappend ::res [lrange [info level 0] 1 end] 2748 LOG "-> [info level 0]" 2749 set ret {} 2750 switch -glob -- $op { 2751 init* {set ret {initialize finalize watch read}} 2752 watch { 2753 set l [lindex $args 0] 2754 catch {after cancel $::timer} 2755 if {[llength $l]} { 2756 set ::timer [after $::drive [list POST $ch]] 2757 } 2758 } 2759 finalize { 2760 catch { after cancel $::timer } 2761 after 500 {set ::forever now} 2762 } 2763 read { 2764 set ret $::data 2765 set ::data {} ; # Next is EOF. 2766 } 2767 } 2768 LOG "<- [info level 0] : $ret" 2769 return $ret 2770 } 2771} -body { 2772 LOG BEGIN 2773 set ch [chan create {read} HANDLER] 2774 2775 set tid [thread::create { 2776 proc LOG {text} { 2777 #puts stderr "\t\t\t\t\t\t[thread::id]: $text" 2778 return 2779 } 2780 LOG THREAD-STARTED 2781 load {} Tcltest 2782 proc bgerror s { 2783 LOG BGERROR:$s 2784 } 2785 vwait forever 2786 LOG THREAD-DONE 2787 }] 2788 2789 testchannel cut $ch 2790 thread::send $tid [list set thech $ch] 2791 thread::send $tid [list set beat $beat] 2792 thread::send -async $tid { 2793 LOG SPLICE-BEG 2794 testchannel splice $thech 2795 LOG SPLICE-END 2796 proc PROCESS {ch} { 2797 LOG "-> [info level 0]" 2798 if {[eof $ch]} { 2799 close $ch 2800 set ::done 1 2801 set c <<EOF>> 2802 } else { 2803 set c [read $ch 1] 2804 } 2805 LOG "GOTCHAR: $c" 2806 LOG "<- [info level 0]" 2807 } 2808 LOG THREAD-FILEEVENT 2809 fconfigure $thech -translation binary -blocking 0 2810 fileevent $thech readable [list PROCESS $thech] 2811 LOG THREAD-NOEVENT-LOOP 2812 set done 0 2813 while {!$done} { 2814 after $beat 2815 LOG THREAD-HEARTBEAT 2816 update 2817 } 2818 LOG THREAD-LOOP-DONE 2819 #thread::exit 2820 # Thread exits cause leaks; Use clean thread shutdown 2821 set forever yourGirl 2822 } 2823 2824 LOG MAIN_WAITING 2825 vwait forever 2826 LOG MAIN_DONE 2827 2828 set res 2829} -cleanup { 2830 after cancel $::timer 2831 rename LOG {} 2832 rename POST {} 2833 rename HANDLER {} 2834 unset beat drive data forever res tid ch timer 2835} -match glob \ 2836 -result {{initialize rc* read} {watch rc* read} {read rc* 4096} {watch rc* {}} {watch rc* read} {read rc* 4096} {watch rc* {}} {finalize rc*}} 2837 2838# --- === *** ########################### 2839# method cgetall 2840 2841test iocmd.tf-25.1 {chan configure, cgetall, standard options} -match glob -body { 2842 set res {} 2843 proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} 2844 set c [chan create {r w} foo] 2845 notes [inthread $c { 2846 note [fconfigure $c] 2847 close $c 2848 notes 2849 } c] 2850 rename foo {} 2851 set res 2852} -constraints {testchannel thread} \ 2853 -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} 2854test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body { 2855 set res {} 2856 proc foo {args} {oninit cget cgetall; onfinal; track; return ""} 2857 set c [chan create {r w} foo] 2858 notes [inthread $c { 2859 note [fconfigure $c] 2860 close $c 2861 notes 2862 } c] 2863 rename foo {} 2864 set res 2865} -constraints {testchannel thread} \ 2866 -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} 2867test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body { 2868 set res {} 2869 proc foo {args} { 2870 oninit cget cgetall; onfinal; track 2871 return "-bar foo -snarf x" 2872 } 2873 set c [chan create {r w} foo] 2874 notes [inthread $c { 2875 note [fconfigure $c] 2876 close $c 2877 notes 2878 } c] 2879 rename foo {} 2880 set res 2881} -constraints {testchannel thread} \ 2882 -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *} -bar foo -snarf x}} 2883test iocmd.tf-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { 2884 set res {} 2885 proc foo {args} { 2886 oninit cget cgetall; onfinal; track 2887 return "-bar" 2888 } 2889 set c [chan create {r w} foo] 2890 notes [inthread $c { 2891 note [catch {fconfigure $c} msg] 2892 note $msg 2893 close $c 2894 notes 2895 } c] 2896 rename foo {} 2897 set res 2898} -constraints {testchannel thread} -result {{cgetall rc*} 1 {Expected list with even number of elements, got 1 element instead}} 2899test iocmd.tf-25.5 {chan configure, cgetall, bad result, not a list} -match glob -body { 2900 set res {} 2901 proc foo {args} { 2902 oninit cget cgetall; onfinal; track 2903 return "\{" 2904 } 2905 set c [chan create {r w} foo] 2906 notes [inthread $c { 2907 note [catch {fconfigure $c} msg] 2908 note $msg 2909 close $c 2910 notes 2911 } c] 2912 rename foo {} 2913 set res 2914} -constraints {testchannel thread} -result {{cgetall rc*} 1 {unmatched open brace in list}} 2915test iocmd.tf-25.6 {chan configure, cgetall, error return} -match glob -body { 2916 set res {} 2917 proc foo {args} { 2918 oninit cget cgetall; onfinal; track 2919 return -code error BOOM! 2920 } 2921 set c [chan create {r w} foo] 2922 notes [inthread $c { 2923 note [catch {fconfigure $c} msg] 2924 note $msg 2925 close $c 2926 notes 2927 } c] 2928 rename foo {} 2929 set res 2930} -constraints {testchannel thread} -result {{cgetall rc*} 1 BOOM!} 2931test iocmd.tf-25.7 {chan configure, cgetall, break return is error} -match glob -body { 2932 set res {} 2933 proc foo {args} { 2934 oninit cget cgetall; onfinal; track 2935 return -code break BOOM! 2936 } 2937 set c [chan create {r w} foo] 2938 notes [inthread $c { 2939 note [catch {fconfigure $c} msg] 2940 note $msg 2941 close $c 2942 notes 2943 } c] 2944 rename foo {} 2945 set res 2946} -result {{cgetall rc*} 1 *bad code*} \ 2947 -constraints {testchannel thread} 2948test iocmd.tf-25.8 {chan configure, cgetall, continue return is error} -match glob -body { 2949 set res {} 2950 proc foo {args} { 2951 oninit cget cgetall; onfinal; track 2952 return -code continue BOOM! 2953 } 2954 set c [chan create {r w} foo] 2955 notes [inthread $c { 2956 note [catch {fconfigure $c} msg] 2957 note $msg 2958 close $c 2959 notes 2960 } c] 2961 rename foo {} 2962 set res 2963} -result {{cgetall rc*} 1 *bad code*} \ 2964 -constraints {testchannel thread} 2965test iocmd.tf-25.9 {chan configure, cgetall, custom return is error} -match glob -body { 2966 set res {} 2967 proc foo {args} { 2968 oninit cget cgetall; onfinal; track 2969 return -code 777 BOOM! 2970 } 2971 set c [chan create {r w} foo] 2972 notes [inthread $c { 2973 note [catch {fconfigure $c} msg] 2974 note $msg 2975 close $c 2976 notes 2977 } c] 2978 rename foo {} 2979 set res 2980} -result {{cgetall rc*} 1 *bad code*} \ 2981 -constraints {testchannel thread} 2982test iocmd.tf-25.10 {chan configure, cgetall, level is ignored} -match glob -body { 2983 set res {} 2984 proc foo {args} { 2985 oninit cget cgetall; onfinal; track 2986 return -level 55 -code 777 BANG 2987 } 2988 set c [chan create {r w} foo] 2989 notes [inthread $c { 2990 note [catch {fconfigure $c} msg opt] 2991 note $msg 2992 noteOpts $opt 2993 close $c 2994 notes 2995 } c] 2996 rename foo {} 2997 set res 2998} -result {{cgetall rc*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "cgetall"*}} \ 2999 -constraints {testchannel thread} 3000 3001# --- === *** ########################### 3002# method configure 3003 3004test iocmd.tf-26.1 {chan configure, set standard option} -match glob -body { 3005 set res {} 3006 proc foo {args} { 3007 oninit configure; onfinal; track; note MUST_NOT_HAPPEN; return 3008 } 3009 set c [chan create {r w} foo] 3010 notes [inthread $c { 3011 note [fconfigure $c -translation lf] 3012 close $c 3013 notes 3014 } c] 3015 rename foo {} 3016 set res 3017} -constraints {testchannel thread} -result {{}} 3018test iocmd.tf-26.2 {chan configure, set option, error return} -match glob -body { 3019 set res {} 3020 proc foo {args} { 3021 oninit configure; onfinal; track 3022 return -code error BOOM! 3023 } 3024 set c [chan create {r w} foo] 3025 notes [inthread $c { 3026 note [catch {fconfigure $c -rc-foo bar} msg] 3027 note $msg 3028 close $c 3029 notes 3030 } c] 3031 rename foo {} 3032 set res 3033} -constraints {testchannel thread} -result {{configure rc* -rc-foo bar} 1 BOOM!} 3034test iocmd.tf-26.3 {chan configure, set option, ok return} -match glob -body { 3035 set res {} 3036 proc foo {args} {oninit configure; onfinal; track; return} 3037 set c [chan create {r w} foo] 3038 notes [inthread $c { 3039 note [fconfigure $c -rc-foo bar] 3040 close $c 3041 notes 3042 } c] 3043 rename foo {} 3044 set res 3045} -constraints {testchannel thread} -result {{configure rc* -rc-foo bar} {}} 3046test iocmd.tf-26.4 {chan configure, set option, break return is error} -match glob -body { 3047 set res {} 3048 proc foo {args} { 3049 oninit configure; onfinal; track 3050 return -code break BOOM! 3051 } 3052 set c [chan create {r w} foo] 3053 notes [inthread $c { 3054 note [catch {fconfigure $c -rc-foo bar} msg] 3055 note $msg 3056 close $c 3057 notes 3058 } c] 3059 rename foo {} 3060 set res 3061} -result {{configure rc* -rc-foo bar} 1 *bad code*} \ 3062 -constraints {testchannel thread} 3063test iocmd.tf-26.5 {chan configure, set option, continue return is error} -match glob -body { 3064 set res {} 3065 proc foo {args} { 3066 oninit configure; onfinal; track 3067 return -code continue BOOM! 3068 } 3069 set c [chan create {r w} foo] 3070 notes [inthread $c { 3071 note [catch {fconfigure $c -rc-foo bar} msg] 3072 note $msg 3073 close $c 3074 notes 3075 } c] 3076 rename foo {} 3077 set res 3078} -result {{configure rc* -rc-foo bar} 1 *bad code*} \ 3079 -constraints {testchannel thread} 3080test iocmd.tf-26.6 {chan configure, set option, custom return is error} -match glob -body { 3081 set res {} 3082 proc foo {args} { 3083 oninit configure; onfinal; track 3084 return -code 444 BOOM! 3085 } 3086 set c [chan create {r w} foo] 3087 notes [inthread $c { 3088 note [catch {fconfigure $c -rc-foo bar} msg] 3089 note $msg 3090 close $c 3091 notes 3092 } c] 3093 rename foo {} 3094 set res 3095} -result {{configure rc* -rc-foo bar} 1 *bad code*} \ 3096 -constraints {testchannel thread} 3097test iocmd.tf-26.7 {chan configure, set option, level is ignored} -match glob -body { 3098 set res {} 3099 proc foo {args} { 3100 oninit configure; onfinal; track 3101 return -level 55 -code 444 BANG 3102 } 3103 set c [chan create {r w} foo] 3104 notes [inthread $c { 3105 note [catch {fconfigure $c -rc-foo bar} msg opt] 3106 note $msg 3107 noteOpts $opt 3108 close $c 3109 notes 3110 } c] 3111 rename foo {} 3112 set res 3113} -result {{configure rc* -rc-foo bar} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "configure"*}} \ 3114 -constraints {testchannel thread} 3115 3116# --- === *** ########################### 3117# method cget 3118 3119test iocmd.tf-27.1 {chan configure, get option, ok return} -match glob -body { 3120 set res {} 3121 proc foo {args} {oninit cget cgetall; onfinal; track; return foo} 3122 set c [chan create {r w} foo] 3123 notes [inthread $c { 3124 note [fconfigure $c -rc-foo] 3125 close $c 3126 notes 3127 } c] 3128 rename foo {} 3129 set res 3130} -constraints {testchannel thread} -result {{cget rc* -rc-foo} foo} 3131test iocmd.tf-27.2 {chan configure, get option, error return} -match glob -body { 3132 set res {} 3133 proc foo {args} { 3134 oninit cget cgetall; onfinal; track 3135 return -code error BOOM! 3136 } 3137 set c [chan create {r w} foo] 3138 notes [inthread $c { 3139 note [catch {fconfigure $c -rc-foo} msg] 3140 note $msg 3141 close $c 3142 notes 3143 } c] 3144 rename foo {} 3145 set res 3146} -constraints {testchannel thread} -result {{cget rc* -rc-foo} 1 BOOM!} 3147test iocmd.tf-27.3 {chan configure, get option, break return is error} -match glob -body { 3148 set res {} 3149 proc foo {args} { 3150 oninit cget cgetall; onfinal; track 3151 return -code error BOOM! 3152 } 3153 set c [chan create {r w} foo] 3154 notes [inthread $c { 3155 note [catch {fconfigure $c -rc-foo} msg] 3156 note $msg 3157 close $c 3158 notes 3159 } c] 3160 rename foo {} 3161 set res 3162} -result {{cget rc* -rc-foo} 1 BOOM!} \ 3163 -constraints {testchannel thread} 3164test iocmd.tf-27.4 {chan configure, get option, continue return is error} -match glob -body { 3165 set res {} 3166 proc foo {args} { 3167 oninit cget cgetall; onfinal; track 3168 return -code continue BOOM! 3169 } 3170 set c [chan create {r w} foo] 3171 notes [inthread $c { 3172 note [catch {fconfigure $c -rc-foo} msg] 3173 note $msg 3174 close $c 3175 notes 3176 } c] 3177 rename foo {} 3178 set res 3179} -result {{cget rc* -rc-foo} 1 *bad code*} \ 3180 -constraints {testchannel thread} 3181test iocmd.tf-27.5 {chan configure, get option, custom return is error} -match glob -body { 3182 set res {} 3183 proc foo {args} { 3184 oninit cget cgetall; onfinal; track 3185 return -code 333 BOOM! 3186 } 3187 set c [chan create {r w} foo] 3188 notes [inthread $c { 3189 note [catch {fconfigure $c -rc-foo} msg] 3190 note $msg 3191 close $c 3192 notes 3193 } c] 3194 rename foo {} 3195 set res 3196} -result {{cget rc* -rc-foo} 1 *bad code*} \ 3197 -constraints {testchannel thread} 3198test iocmd.tf-27.6 {chan configure, get option, level is ignored} -match glob -body { 3199 set res {} 3200 proc foo {args} { 3201 oninit cget cgetall; onfinal; track 3202 return -level 77 -code 333 BANG 3203 } 3204 set c [chan create {r w} foo] 3205 notes [inthread $c { 3206 note [catch {fconfigure $c -rc-foo} msg opt] 3207 note $msg 3208 noteOpts $opt 3209 close $c 3210 notes 3211 } c] 3212 rename foo {} 3213 set res 3214} -result {{cget rc* -rc-foo} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "cget"*}} \ 3215 -constraints {testchannel thread} 3216 3217# --- === *** ########################### 3218# method seek 3219 3220test iocmd.tf-28.1 {chan tell, not supported by handler} -match glob -body { 3221 set res {} 3222 proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} 3223 set c [chan create {r w} foo] 3224 notes [inthread $c { 3225 note [tell $c] 3226 close $c 3227 notes 3228 } c] 3229 rename foo {} 3230 set res 3231} -result {-1} \ 3232 -constraints {testchannel thread} 3233test iocmd.tf-28.2 {chan tell, error return} -match glob -body { 3234 set res {} 3235 proc foo {args} {oninit seek; onfinal; track; return -code error BOOM!} 3236 set c [chan create {r w} foo] 3237 notes [inthread $c { 3238 note [catch {tell $c} msg] 3239 note $msg 3240 close $c 3241 notes 3242 } c] 3243 rename foo {} 3244 set res 3245} -result {{seek rc* 0 current} 1 BOOM!} \ 3246 -constraints {testchannel thread} 3247test iocmd.tf-28.3 {chan tell, break return is error} -match glob -body { 3248 set res {} 3249 proc foo {args} {oninit seek; onfinal; track; return -code break BOOM!} 3250 set c [chan create {r w} foo] 3251 notes [inthread $c { 3252 note [catch {tell $c} msg] 3253 note $msg 3254 close $c 3255 notes 3256 } c] 3257 rename foo {} 3258 set res 3259} -result {{seek rc* 0 current} 1 *bad code*} \ 3260 -constraints {testchannel thread} 3261test iocmd.tf-28.4 {chan tell, continue return is error} -match glob -body { 3262 set res {} 3263 proc foo {args} {oninit seek; onfinal; track; return -code continue BOOM!} 3264 set c [chan create {r w} foo] 3265 notes [inthread $c { 3266 note [catch {tell $c} msg] 3267 note $msg 3268 close $c 3269 notes 3270 } c] 3271 rename foo {} 3272 set res 3273} -result {{seek rc* 0 current} 1 *bad code*} \ 3274 -constraints {testchannel thread} 3275test iocmd.tf-28.5 {chan tell, custom return is error} -match glob -body { 3276 set res {} 3277 proc foo {args} {oninit seek; onfinal; track; return -code 222 BOOM!} 3278 set c [chan create {r w} foo] 3279 notes [inthread $c { 3280 note [catch {tell $c} msg] 3281 note $msg 3282 close $c 3283 notes 3284 } c] 3285 rename foo {} 3286 set res 3287} -result {{seek rc* 0 current} 1 *bad code*} \ 3288 -constraints {testchannel thread} 3289test iocmd.tf-28.6 {chan tell, level is ignored} -match glob -body { 3290 set res {} 3291 proc foo {args} {oninit seek; onfinal; track; return -level 11 -code 222 BANG} 3292 set c [chan create {r w} foo] 3293 notes [inthread $c { 3294 note [catch {tell $c} msg opt] 3295 note $msg 3296 noteOpts $opt 3297 close $c 3298 notes 3299 } c] 3300 rename foo {} 3301 set res 3302} -result {{seek rc* 0 current} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "seek"*}} \ 3303 -constraints {testchannel thread} 3304test iocmd.tf-28.7 {chan tell, regular return} -match glob -body { 3305 set res {} 3306 proc foo {args} {oninit seek; onfinal; track; return 88} 3307 set c [chan create {r w} foo] 3308 notes [inthread $c { 3309 note [tell $c] 3310 close $c 3311 notes 3312 } c] 3313 rename foo {} 3314 set res 3315} -result {{seek rc* 0 current} 88} \ 3316 -constraints {testchannel thread} 3317test iocmd.tf-28.8 {chan tell, negative return} -match glob -body { 3318 set res {} 3319 proc foo {args} {oninit seek; onfinal; track; return -1} 3320 set c [chan create {r w} foo] 3321 notes [inthread $c { 3322 note [catch {tell $c} msg] 3323 note $msg 3324 close $c 3325 notes 3326 } c] 3327 rename foo {} 3328 set res 3329} -result {{seek rc* 0 current} 1 {Tried to seek before origin}} \ 3330 -constraints {testchannel thread} 3331test iocmd.tf-28.9 {chan tell, string return} -match glob -body { 3332 set res {} 3333 proc foo {args} {oninit seek; onfinal; track; return BOGUS} 3334 set c [chan create {r w} foo] 3335 notes [inthread $c { 3336 note [catch {tell $c} msg] 3337 note $msg 3338 close $c 3339 notes 3340 } c] 3341 rename foo {} 3342 set res 3343} -result {{seek rc* 0 current} 1 {expected integer but got "BOGUS"}} \ 3344 -constraints {testchannel thread} 3345test iocmd.tf-28.10 {chan seek, not supported by handler} -match glob -body { 3346 set res {} 3347 proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} 3348 set c [chan create {r w} foo] 3349 notes [inthread $c { 3350 note [catch {seek $c 0 start} msg] 3351 note $msg 3352 close $c 3353 notes 3354 } c] 3355 rename foo {} 3356 set res 3357} -result {1 {error during seek on "rc*": invalid argument}} \ 3358 -constraints {testchannel thread} 3359test iocmd.tf-28.11 {chan seek, error return} -match glob -body { 3360 set res {} 3361 proc foo {args} {oninit seek; onfinal; track; return -code error BOOM!} 3362 set c [chan create {r w} foo] 3363 notes [inthread $c { 3364 note [catch {seek $c 0 start} msg] 3365 note $msg 3366 close $c 3367 notes 3368 } c] 3369 rename foo {} 3370 set res 3371} -result {{seek rc* 0 start} 1 BOOM!} \ 3372 -constraints {testchannel thread} 3373test iocmd.tf-28.12 {chan seek, break return is error} -match glob -body { 3374 set res {} 3375 proc foo {args} {oninit seek; onfinal; track; return -code break BOOM!} 3376 set c [chan create {r w} foo] 3377 notes [inthread $c { 3378 note [catch {seek $c 0 start} msg] 3379 note $msg 3380 close $c 3381 notes 3382 } c] 3383 rename foo {} 3384 set res 3385} -result {{seek rc* 0 start} 1 *bad code*} \ 3386 -constraints {testchannel thread} 3387test iocmd.tf-28.13 {chan seek, continue return is error} -match glob -body { 3388 set res {} 3389 proc foo {args} {oninit seek; onfinal; track; return -code continue BOOM!} 3390 set c [chan create {r w} foo] 3391 notes [inthread $c { 3392 note [catch {seek $c 0 start} msg] 3393 note $msg 3394 close $c 3395 notes 3396 } c] 3397 rename foo {} 3398 set res 3399} -result {{seek rc* 0 start} 1 *bad code*} \ 3400 -constraints {testchannel thread} 3401test iocmd.tf-28.14 {chan seek, custom return is error} -match glob -body { 3402 set res {} 3403 proc foo {args} {oninit seek; onfinal; track; return -code 99 BOOM!} 3404 set c [chan create {r w} foo] 3405 notes [inthread $c { 3406 note [catch {seek $c 0 start} msg] 3407 note $msg 3408 close $c 3409 notes 3410 } c] 3411 rename foo {} 3412 set res 3413} -result {{seek rc* 0 start} 1 *bad code*} \ 3414 -constraints {testchannel thread} 3415test iocmd.tf-28.15 {chan seek, level is ignored} -match glob -body { 3416 set res {} 3417 proc foo {args} {oninit seek; onfinal; track; return -level 33 -code 99 BANG} 3418 set c [chan create {r w} foo] 3419 notes [inthread $c { 3420 note [catch {seek $c 0 start} msg opt] 3421 note $msg 3422 noteOpts $opt 3423 close $c 3424 notes 3425 } c] 3426 rename foo {} 3427 set res 3428} -result {{seek rc* 0 start} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "seek"*}} \ 3429 -constraints {testchannel thread} 3430test iocmd.tf-28.16 {chan seek, bogus return, negative location} -match glob -body { 3431 set res {} 3432 proc foo {args} {oninit seek; onfinal; track; return -45} 3433 set c [chan create {r w} foo] 3434 notes [inthread $c { 3435 note [catch {seek $c 0 start} msg] 3436 note $msg 3437 close $c 3438 notes 3439 } c] 3440 rename foo {} 3441 set res 3442} -result {{seek rc* 0 start} 1 {Tried to seek before origin}} \ 3443 -constraints {testchannel thread} 3444test iocmd.tf-28.17 {chan seek, bogus return, string return} -match glob -body { 3445 set res {} 3446 proc foo {args} {oninit seek; onfinal; track; return BOGUS} 3447 set c [chan create {r w} foo] 3448 notes [inthread $c { 3449 note [catch {seek $c 0 start} msg] 3450 note $msg 3451 close $c 3452 notes 3453 } c] 3454 rename foo {} 3455 set res 3456} -result {{seek rc* 0 start} 1 {expected integer but got "BOGUS"}} \ 3457 -constraints {testchannel thread} 3458test iocmd.tf-28.18 {chan seek, ok result} -match glob -body { 3459 set res {} 3460 proc foo {args} {oninit seek; onfinal; track; return 23} 3461 set c [chan create {r w} foo] 3462 notes [inthread $c { 3463 note [seek $c 0 current] 3464 close $c 3465 notes 3466 } c] 3467 rename foo {} 3468 set res 3469} -result {{seek rc* 0 current} {}} \ 3470 -constraints {testchannel thread} 3471foreach {testname code} { 3472 iocmd.tf-28.19.0 start 3473 iocmd.tf-28.19.1 current 3474 iocmd.tf-28.19.2 end 3475} { 3476 test $testname "chan seek, base conversion, $code" -match glob -body { 3477 set res {} 3478 proc foo {args} {oninit seek; onfinal; track; return 0} 3479 set c [chan create {r w} foo] 3480 notes [inthread $c { 3481 note [seek $c 0 $code] 3482 close $c 3483 notes 3484 } c code] 3485 rename foo {} 3486 set res 3487 } -result [list [list seek rc* 0 $code] {}] \ 3488 -constraints {testchannel thread} 3489} 3490 3491# --- === *** ########################### 3492# method blocking 3493 3494test iocmd.tf-29.1 {chan blocking, no handler support} -match glob -body { 3495 set res {} 3496 proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} 3497 set c [chan create {r w} foo] 3498 notes [inthread $c { 3499 note [fconfigure $c -blocking] 3500 close $c 3501 notes 3502 } c] 3503 rename foo {} 3504 set res 3505} -result {1} \ 3506 -constraints {testchannel thread} 3507test iocmd.tf-29.2 {chan blocking, no handler support} -match glob -body { 3508 set res {} 3509 proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} 3510 set c [chan create {r w} foo] 3511 notes [inthread $c { 3512 note [fconfigure $c -blocking 0] 3513 note [fconfigure $c -blocking] 3514 close $c 3515 notes 3516 } c] 3517 rename foo {} 3518 set res 3519} -result {{} 0} \ 3520 -constraints {testchannel thread} 3521test iocmd.tf-29.3 {chan blocking, retrieval, handler support} -match glob -body { 3522 set res {} 3523 proc foo {args} {oninit blocking; onfinal; track; note MUST_NOT_HAPPEN; return} 3524 set c [chan create {r w} foo] 3525 notes [inthread $c { 3526 note [fconfigure $c -blocking] 3527 close $c 3528 notes 3529 } c] 3530 rename foo {} 3531 set res 3532} -result {1} \ 3533 -constraints {testchannel thread} 3534test iocmd.tf-29.4 {chan blocking, resetting, handler support} -match glob -body { 3535 set res {} 3536 proc foo {args} {oninit blocking; onfinal; track; return} 3537 set c [chan create {r w} foo] 3538 notes [inthread $c { 3539 note [fconfigure $c -blocking 0] 3540 note [fconfigure $c -blocking] 3541 close $c 3542 notes 3543 } c] 3544 rename foo {} 3545 set res 3546} -result {{blocking rc* 0} {} 0} \ 3547 -constraints {testchannel thread} 3548test iocmd.tf-29.5 {chan blocking, setting, handler support} -match glob -body { 3549 set res {} 3550 proc foo {args} {oninit blocking; onfinal; track; return} 3551 set c [chan create {r w} foo] 3552 notes [inthread $c { 3553 note [fconfigure $c -blocking 1] 3554 note [fconfigure $c -blocking] 3555 close $c 3556 notes 3557 } c] 3558 rename foo {} 3559 set res 3560} -result {{blocking rc* 1} {} 1} \ 3561 -constraints {testchannel thread} 3562test iocmd.tf-29.6 {chan blocking, error return} -match glob -body { 3563 set res {} 3564 proc foo {args} {oninit blocking; onfinal; track; error BOOM!} 3565 set c [chan create {r w} foo] 3566 notes [inthread $c { 3567 note [catch {fconfigure $c -blocking 0} msg] 3568 note $msg 3569 # Catch the close. It changes blocking mode internally, and runs into the error result. 3570 catch {close $c} 3571 notes 3572 } c] 3573 rename foo {} 3574 set res 3575} -result {{blocking rc* 0} 1 BOOM!} \ 3576 -constraints {testchannel thread} 3577test iocmd.tf-29.7 {chan blocking, break return is error} -match glob -body { 3578 set res {} 3579 proc foo {args} {oninit blocking; onfinal; track; return -code break BOOM!} 3580 set c [chan create {r w} foo] 3581 notes [inthread $c { 3582 note [catch {fconfigure $c -blocking 0} msg] 3583 note $msg 3584 catch {close $c} 3585 notes 3586 } c] 3587 rename foo {} 3588 set res 3589} -result {{blocking rc* 0} 1 *bad code*} \ 3590 -constraints {testchannel thread} 3591test iocmd.tf-29.8 {chan blocking, continue return is error} -match glob -body { 3592 set res {} 3593 proc foo {args} {oninit blocking; onfinal; track; return -code continue BOOM!} 3594 set c [chan create {r w} foo] 3595 notes [inthread $c { 3596 note [catch {fconfigure $c -blocking 0} msg] 3597 note $msg 3598 catch {close $c} 3599 notes 3600 } c] 3601 rename foo {} 3602 set res 3603} -result {{blocking rc* 0} 1 *bad code*} \ 3604 -constraints {testchannel thread} 3605test iocmd.tf-29.9 {chan blocking, custom return is error} -match glob -body { 3606 set res {} 3607 proc foo {args} {oninit blocking; onfinal; track; return -code 44 BOOM!} 3608 set c [chan create {r w} foo] 3609 notes [inthread $c { 3610 note [catch {fconfigure $c -blocking 0} msg] 3611 note $msg 3612 catch {close $c} 3613 notes 3614 } c] 3615 rename foo {} 3616 set res 3617} -result {{blocking rc* 0} 1 *bad code*} \ 3618 -constraints {testchannel thread} 3619test iocmd.tf-29.10 {chan blocking, level is ignored} -match glob -body { 3620 set res {} 3621 proc foo {args} {oninit blocking; onfinal; track; return -level 99 -code 44 BANG} 3622 set c [chan create {r w} foo] 3623 notes [inthread $c { 3624 note [catch {fconfigure $c -blocking 0} msg opt] 3625 note $msg 3626 noteOpts $opt 3627 catch {close $c} 3628 notes 3629 } c] 3630 rename foo {} 3631 set res 3632} -result {{blocking rc* 0} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "blocking"*}} \ 3633 -constraints {testchannel thread} 3634test iocmd.tf-29.11 {chan blocking, regular return ok, value ignored} -match glob -body { 3635 set res {} 3636 proc foo {args} {oninit blocking; onfinal; track; return BOGUS} 3637 set c [chan create {r w} foo] 3638 notes [inthread $c { 3639 note [catch {fconfigure $c -blocking 0} msg] 3640 note $msg 3641 catch {close $c} 3642 notes 3643 } c] 3644 rename foo {} 3645 set res 3646} -result {{blocking rc* 0} 0 {}} \ 3647 -constraints {testchannel thread} 3648 3649# --- === *** ########################### 3650# method watch 3651 3652test iocmd.tf-30.1 {chan watch, read interest, some return} -match glob -body { 3653 set res {} 3654 proc foo {args} {oninit; onfinal; track; return IGNORED} 3655 set c [chan create {r w} foo] 3656 notes [inthread $c { 3657 note [fileevent $c readable {set tick $tick}] 3658 close $c ;# 2nd watch, interest zero. 3659 notes 3660 } c] 3661 rename foo {} 3662 set res 3663} -constraints {testchannel thread} -result {{watch rc* read} {watch rc* {}} {}} 3664test iocmd.tf-30.2 {chan watch, write interest, error return} -match glob -body { 3665 set res {} 3666 proc foo {args} {oninit; onfinal; track; return -code error BOOM!_IGNORED} 3667 set c [chan create {r w} foo] 3668 notes [inthread $c { 3669 note [fileevent $c writable {set tick $tick}] 3670 note [fileevent $c writable {}] 3671 close $c 3672 notes 3673 } c] 3674 rename foo {} 3675 set res 3676} -constraints {testchannel thread} -result {{watch rc* write} {watch rc* {}} {} {}} 3677test iocmd.tf-30.3 {chan watch, accumulated interests} -match glob -body { 3678 set res {} 3679 proc foo {args} {oninit; onfinal; track; return} 3680 set c [chan create {r w} foo] 3681 notes [inthread $c { 3682 note [fileevent $c writable {set tick $tick}] 3683 note [fileevent $c readable {set tick $tick}] 3684 note [fileevent $c writable {}] 3685 note [fileevent $c readable {}] 3686 close $c 3687 notes 3688 } c] 3689 rename foo {} 3690 set res 3691} -constraints {testchannel thread} \ 3692 -result {{watch rc* write} {watch rc* {read write}} {watch rc* read} {watch rc* {}} {} {} {} {}} 3693test iocmd.tf-30.4 {chan watch, unchanged interest not forwarded} -match glob -body { 3694 set res {} 3695 proc foo {args} {oninit; onfinal; track; return} 3696 set c [chan create {r w} foo] 3697 notes [inthread $c { 3698 note [fileevent $c writable {set tick $tick}] 3699 note [fileevent $c readable {set tick $tick}] ;# Script is changing, 3700 note [fileevent $c readable {set tock $tock}] ;# interest does not. 3701 close $c ;# 3rd and 4th watch, removing the event handlers. 3702 notes 3703 } c] 3704 rename foo {} 3705 set res 3706} -constraints {testchannel thread} \ 3707 -result {{watch rc* write} {watch rc* {read write}} {watch rc* write} {watch rc* {}} {} {} {}} 3708 3709# --- === *** ########################### 3710# postevent 3711# Not possible from a thread not containing the command handler. 3712# Check that this is rejected. 3713 3714test iocmd.tf-31.8 {chan postevent, bad input} -match glob -body { 3715 set res {} 3716 proc foo {args} {oninit; onfinal; track; return} 3717 set c [chan create {r w} foo] 3718 notes [inthread $c { 3719 catch {chan postevent $c r} msg 3720 note $msg 3721 close $c 3722 notes 3723 } c] 3724 rename foo {} 3725 set res 3726} -constraints {testchannel thread} \ 3727 -result {{can not find reflected channel named "rc*"}} 3728 3729# --- === *** ########################### 3730# 'Pull the rug' tests. Create channel in a thread A, move to other 3731# thread B, destroy the origin thread (A) before or during access from 3732# B. Must not crash, must return proper errors. 3733 3734test iocmd.tf-32.0 {origin thread of moved channel gone} -match glob -body { 3735 3736 #puts <<$tcltest::mainThread>>main 3737 set tida [thread::create -preserved];#puts <<$tida>> 3738 thread::send $tida {load {} Tcltest} 3739 3740 set tidb [thread::create -preserved];#puts <<$tidb>> 3741 thread::send $tidb {load {} Tcltest} 3742 3743 # Set up channel in thread 3744 thread::send $tida $helperscript 3745 set chan [thread::send $tida { 3746 proc foo {args} {oninit seek; onfinal; track; return} 3747 set chan [chan create {r w} foo] 3748 fconfigure $chan -buffering none 3749 set chan 3750 }] 3751 3752 # Move channel to 2nd thread. 3753 thread::send $tida [list testchannel cut $chan] 3754 thread::send $tidb [list testchannel splice $chan] 3755 3756 # Kill origin thread, then access channel from 2nd thread. 3757 thread::release $tida 3758 3759 set res {} 3760 lappend res [catch {thread::send $tidb [list puts $chan shoo]} msg] $msg 3761 3762 lappend res [catch {thread::send $tidb [list tell $chan]} msg] $msg 3763 lappend res [catch {thread::send $tidb [list seek $chan 1]} msg] $msg 3764 lappend res [catch {thread::send $tidb [list gets $chan]} msg] $msg 3765 lappend res [catch {thread::send $tidb [list close $chan]} msg] $msg 3766 thread::release $tidb 3767 set res 3768 3769} -constraints {testchannel thread} \ 3770 -result {1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} 3771 3772 3773# The test iocmd.tf-32.1 unavoidably exhibits a memory leak. We are testing 3774# the ability of the reflected channel system to react to the situation where 3775# the thread in which the driver routines runs exits during driver operations. 3776# In this case, thread exit handlers signal back to the owner thread so that the 3777# channel operation does not hang. There's no way to test this without actually 3778# exiting a thread in mid-operation, and that action is unavoidably leaky (which 3779# is why [thread::exit] is advised against). 3780# 3781# Use constraints to skip this test while valgrinding so this expected leak 3782# doesn't prevent a finding of "leak-free". 3783# 3784test iocmd.tf-32.1 {origin thread of moved channel destroyed during access} -match glob -body { 3785 3786 #puts <<$tcltest::mainThread>>main 3787 set tida [thread::create -preserved];#puts <<$tida>> 3788 thread::send $tida {load {} Tcltest} 3789 set tidb [thread::create -preserved];#puts <<$tidb>> 3790 thread::send $tidb {load {} Tcltest} 3791 3792 # Set up channel in thread 3793 thread::send $tida $helperscript 3794 set chan [thread::send $tida { 3795 proc foo {args} { 3796 oninit; onfinal; track; 3797 # destroy thread during channel access 3798 thread::exit 3799 } 3800 set chan [chan create {r w} foo] 3801 fconfigure $chan -buffering none 3802 set chan 3803 }] 3804 3805 # Move channel to 2nd thread. 3806 thread::send $tida [list testchannel cut $chan] 3807 thread::send $tidb [list testchannel splice $chan] 3808 3809 # Run access from thread B, wait for response from A (A is not 3810 # using event loop at this point, so the event pile up in the 3811 # queue. 3812 3813 thread::send $tidb [list set chan $chan] 3814 thread::send $tidb [list set mid [thread::id]] 3815 thread::send -async $tidb { 3816 # wait a bit, give the main thread the time to start its event 3817 # loop to wait for the response from B 3818 after 2000 3819 catch { puts $chan shoo } res 3820 thread::send -async $mid [list set ::res $res] 3821 } 3822 vwait ::res 3823 3824 catch {thread::release $tida} 3825 thread::release $tidb 3826 set res 3827} -constraints {testchannel thread notValgrind} \ 3828 -result {Owner lost} 3829 3830# ### ### ### ######### ######### ######### 3831 3832# ### ### ### ######### ######### ######### 3833 3834rename track {} 3835# cleanup 3836 3837 3838# Eliminate valgrind "still reachable" reports on outstanding "Detached" 3839# structures in the detached list which stem from PipeClose2Proc not waiting 3840# around for background processes to complete, meaning that previous calls to 3841# Tcl_ReapDetachedProcs might not have had a chance to reap all processes. 3842after 10 3843exec [info nameofexecutable] << {} 3844 3845 3846foreach file [list test1 test2 test3 test4] { 3847 removeFile $file 3848} 3849# delay long enough for background processes to finish 3850after 500 3851removeFile test5 3852cleanupTests 3853return 3854