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