diff options
Diffstat (limited to 'tests/ioCmd.test')
| -rw-r--r-- | tests/ioCmd.test | 1085 |
1 files changed, 289 insertions, 796 deletions
diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 2b9aed6..5a76d48 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -1,30 +1,27 @@ # -*- tcl -*- # Commands covered: open, close, gets, read, puts, seek, tell, eof, flush, -# fblocked, fconfigure, open, channel, fcopy, -# readFile, writeFile, foreachLine +# fblocked, fconfigure, open, channel, fcopy # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright © 1991-1994 The Regents of the University of California. -# Copyright © 1994-1996 Sun Microsystems, Inc. -# Copyright © 1998-1999 Scriptics Corporation. +# Copyright (c) 1991-1994 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {"::tcltest" ni [namespace children]} { - package require tcltest 2.5 +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2 namespace import -force ::tcltest::* } -source [file join [file dirname [info script]] tcltests.tcl] - -::tcltest::loadTestedCommands -catch [list package require -exact tcl::test [info patchlevel]] # Custom constraints used in this file +testConstraint fcopy [llength [info commands fcopy]] testConstraint testchannel [llength [info commands testchannel]] +testConstraint testthread [llength [info commands testthread]] #---------------------------------------------------------------------- @@ -136,10 +133,10 @@ test iocmd-4.8 {read command with incorrect combination of arguments} { set x [list [catch {read -nonewline $f 20 z} msg] $msg $::errorCode] close $f set x -} {1 {wrong # args: should be "read channelId ?numChars?" or "read ?-nonewline? channelId"} {TCL WRONGARGS}} +} {1 {wrong # args: should be "read channelId ?numChars?" or "read ?-nonewline? channelId"} NONE} test iocmd-4.9 {read command} { list [catch {read stdin foo} msg] $msg $::errorCode -} {1 {expected non-negative integer but got "foo"} {TCL VALUE NUMBER}} +} {1 {expected integer but got "foo"} {TCL VALUE NUMBER}} test iocmd-4.10 {read command} { list [catch {read file107} msg] $msg $::errorCode } {1 {can not find channel named "file107"} {TCL LOOKUP CHANNEL file107}} @@ -151,26 +148,25 @@ test iocmd-4.11 {read command} { string compare [string tolower $x] \ [list 1 [format "channel \"%s\" wasn't opened for reading" $f] none] } 0 -test iocmd-4.12 {read command} -setup { +test iocmd-4.12 {read command} { set f [open $path(test1)] -} -body { - read $f 12z -} -cleanup { + set x [list [catch {read $f 12z} msg] $msg $::errorCode] close $f -} -result {expected non-negative integer but got "12z"} -errorCode {TCL VALUE NUMBER} - -test iocmd-5.1 {seek command} -returnCodes error -body { - seek -} -result {wrong # args: should be "seek channelId offset ?origin?"} -test iocmd-5.2 {seek command} -returnCodes error -body { - seek a b c d e f g -} -result {wrong # args: should be "seek channelId offset ?origin?"} -test iocmd-5.3 {seek command} -returnCodes error -body { - seek stdin gugu -} -result {expected integer but got "gugu"} -test iocmd-5.4 {seek command} -returnCodes error -body { - seek stdin 100 gugu -} -result {bad origin "gugu": must be start, current, or end} + set x +} {1 {expected integer but got "12z"} {TCL VALUE NUMBER}} + +test iocmd-5.1 {seek command} { + list [catch {seek} msg] $msg +} {1 {wrong # args: should be "seek channelId offset ?origin?"}} +test iocmd-5.2 {seek command} { + list [catch {seek a b c d e f g} msg] $msg +} {1 {wrong # args: should be "seek channelId offset ?origin?"}} +test iocmd-5.3 {seek command} { + list [catch {seek stdin gugu} msg] $msg +} {1 {expected integer but got "gugu"}} +test iocmd-5.4 {seek command} { + list [catch {seek stdin 100 gugu} msg] $msg +} {1 {bad origin "gugu": must be start, current, or end}} test iocmd-6.1 {tell command} { list [catch {tell} msg] $msg @@ -184,117 +180,91 @@ test iocmd-6.3 {tell command} { test iocmd-7.1 {close command} { list [catch {close} msg] $msg -} {1 {wrong # args: should be "close channelId ?direction?"}} +} {1 {wrong # args: should be "close channelId"}} test iocmd-7.2 {close command} { list [catch {close a b c d e} msg] $msg -} {1 {wrong # args: should be "close channelId ?direction?"}} +} {1 {wrong # args: should be "close channelId"}} test iocmd-7.3 {close command} { list [catch {close aaa} msg] $msg } {1 {can not find channel named "aaa"}} -test iocmd-7.4 {close command} -setup { - set chan [open [info script] r] -} -body { - chan close $chan bar -} -cleanup { - close $chan -} -returnCodes error -result "bad direction \"bar\": must be read or write" -test iocmd-7.5 {close command} -setup { - set chan [open [info script] r] -} -body { - chan close $chan write -} -cleanup { - close $chan -} -returnCodes error -result "Half-close of write-side not possible, side not opened or already closed" -proc expectedOpts {got extra} { - set basicOpts { - -blocking -buffering -buffersize -encoding -eofchar -profile -translation - } - set opts [list {*}$basicOpts {*}$extra] - lset opts end [string cat "or " [lindex $opts end]] - return [format {bad option "%s": should be one of %s} $got [join $opts ", "]] -} -test iocmd-8.1 {fconfigure command} -returnCodes error -body { - fconfigure -} -result {wrong # args: should be "fconfigure channelId ?-option value ...?"} -test iocmd-8.2 {fconfigure command} -returnCodes error -body { - fconfigure a b c d e f -} -result {wrong # args: should be "fconfigure channelId ?-option value ...?"} -test iocmd-8.3 {fconfigure command} -returnCodes error -body { - fconfigure a b -} -result {can not find channel named "a"} -test iocmd-8.4 {fconfigure command} -setup { +test iocmd-8.1 {fconfigure command} { + list [catch {fconfigure} msg] $msg +} {1 {wrong # args: should be "fconfigure channelId ?optionName? ?value? ?optionName value?..."}} +test iocmd-8.2 {fconfigure command} { + list [catch {fconfigure a b c d e f} msg] $msg +} {1 {wrong # args: should be "fconfigure channelId ?optionName? ?value? ?optionName value?..."}} +test iocmd-8.3 {fconfigure command} { + list [catch {fconfigure a b} msg] $msg +} {1 {can not find channel named "a"}} +test iocmd-8.4 {fconfigure command} { file delete $path(test1) set f1 [open $path(test1) w] -} -body { - fconfigure $f1 froboz -} -returnCodes error -cleanup { + set x [list [catch {fconfigure $f1 froboz} msg] $msg] close $f1 -} -result [expectedOpts "froboz" -stat] -test iocmd-8.5 {fconfigure command} -returnCodes error -body { - fconfigure stdin -buffering froboz -} -result {bad value for -buffering: must be one of full, line, or none} -test iocmd-8.6 {fconfigure command} -returnCodes error -body { - fconfigure stdin -translation froboz -} -result {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform} -test iocmd-8.7 {fconfigure command} -setup { + set x +} {1 {bad option "froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} +test iocmd-8.5 {fconfigure command} { + list [catch {fconfigure stdin -buffering froboz} msg] $msg +} {1 {bad value for -buffering: must be one of full, line, or none}} +test iocmd-8.6 {fconfigure command} { + list [catch {fconfigure stdin -translation froboz} msg] $msg +} {1 {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}} +test iocmd-8.7 {fconfigure command} { file delete $path(test1) -} -body { set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} -encoding utf-16 -profile tcl8 - fconfigure $f1 -} -cleanup { - catch {close $f1} -} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -profile tcl8 -translation lf} -test iocmd-8.8 {fconfigure command} -setup { + fconfigure $f1 -translation lf -eofchar {} -encoding unicode + set x [fconfigure $f1] + close $f1 + set x +} {-blocking 1 -buffering full -buffersize 4096 -encoding unicode -eofchar {} -translation lf} +test iocmd-8.8 {fconfigure command} { file delete $path(test1) - set x {} -} -body { set f1 [open $path(test1) w] fconfigure $f1 -translation lf -buffering line -buffersize 3030 \ - -eofchar {} -encoding utf-16 -profile tcl8 + -eofchar {} -encoding unicode + set x "" lappend x [fconfigure $f1 -buffering] lappend x [fconfigure $f1] -} -cleanup { - catch {close $f1} -} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -profile tcl8 -translation lf}} -test iocmd-8.9 {fconfigure command} -setup { + close $f1 + set x +} {line {-blocking 1 -buffering line -buffersize 3030 -encoding unicode -eofchar {} -translation lf}} +test iocmd-8.9 {fconfigure command} { file delete $path(test1) -} -body { set f1 [open $path(test1) w] fconfigure $f1 -translation binary -buffering none -buffersize 4040 \ - -eofchar {} -encoding binary -profile tcl8 - fconfigure $f1 -} -cleanup { - catch {close $f1} -} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -profile tcl8 -translation lf} -test iocmd-8.10 {fconfigure command} -returnCodes error -body { - fconfigure a b -} -result {can not find channel named "a"} + -eofchar {} -encoding binary + set x [fconfigure $f1] + close $f1 + set x +} {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -translation lf} +test iocmd-8.10 {fconfigure command} { + list [catch {fconfigure a b} msg] $msg +} {1 {can not find channel named "a"}} set path(fconfigure.dummy) [makeFile {} fconfigure.dummy] -test iocmd-8.11 {fconfigure command} -body { +test iocmd-8.11 {fconfigure command} { set chan [open $path(fconfigure.dummy) r] - fconfigure $chan -froboz blarfo -} -returnCodes error -cleanup { - catch {close $chan} -} -result [expectedOpts "-froboz" {}] -test iocmd-8.12 {fconfigure command} -body { + set res [list [catch {fconfigure $chan -froboz blarfo} msg] $msg] + close $chan + set res +} {1 {bad option "-froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} +test iocmd-8.12 {fconfigure command} { set chan [open $path(fconfigure.dummy) r] - fconfigure $chan -b blarfo -} -returnCodes error -cleanup { - catch {close $chan} -} -result [expectedOpts "-b" {}] -test iocmd-8.13 {fconfigure command} -body { + set res [list [catch {fconfigure $chan -b blarfo} msg] $msg] + close $chan + set res +} {1 {bad option "-b": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} +test iocmd-8.13 {fconfigure command} { set chan [open $path(fconfigure.dummy) r] - fconfigure $chan -buffer blarfo -} -returnCodes error -cleanup { - catch {close $chan} -} -result [expectedOpts "-buffer" {}] + set res [list [catch {fconfigure $chan -buffer blarfo} msg] $msg] + close $chan + set res +} {1 {bad option "-buffer": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} removeFile fconfigure.dummy test iocmd-8.14 {fconfigure command} { fconfigure stdin -buffers } 4096 -test iocmd-8.15 {fconfigure command / tcp channel} -constraints {socket unixOrWin} -setup { +test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOrPc} -setup { set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0] set port [lindex [fconfigure $srv -sockname] 2] proc iocmdSRV {sock ip port} {close $sock} @@ -306,7 +276,7 @@ test iocmd-8.15 {fconfigure command / tcp channel} -constraints {socket unixOrWi close $srv unset cli srv port rename iocmdSRV {} -} -returnCodes error -result [expectedOpts "-blah" {-connecting -keepalive -nodelay -peername -sockname}] +} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -peername, or -sockname} test iocmd-8.16 {fconfigure command / tcp channel} -constraints socket -setup { set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0] set port [lindex [fconfigure $srv -sockname] 2] @@ -349,7 +319,7 @@ test iocmd-8.18 {fconfigure command / unix tty channel} -constraints {nonPortabl if {$tty ne ""} { close $tty } -} -returnCodes error -result [expectedOpts "-blah" {-closemode -inputmode -mode -queue -ttystatus -xchar}] +} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -mode} test iocmd-8.19 {fconfigure command / win tty channel} -constraints {nonPortable win} -setup { set tty "" } -body { @@ -360,47 +330,16 @@ test iocmd-8.19 {fconfigure command / win tty channel} -constraints {nonPortable if {$tty ne ""} { close $tty } -} -returnCodes error -result [expectedOpts "-blah" {-closemode -mode -handshake -pollinterval -sysbuffer -timeout -ttycontrol -xchar}] -test iocmd-8.20 {fconfigure command / win console channel} -constraints {nonPortable win} -setup { - # I don't know how else to open the console, but this is non-portable - set console stdin -} -body { - fconfigure $console -blah blih -} -returnCodes error -result [expectedOpts "-blah" {-inputmode}] -# TODO: Test parsing of serial channel options (nonPortable, since requires an +} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -mode, -handshake, -pollinterval, -sysbuffer, -timeout, -ttycontrol, or -xchar} +# TODO: Test parsing of serial channel options (nonportable, since requires an # open channel to work with). -test iocmd-8.21 {fconfigure command / -nocomplainencoding 0 error} -constraints { - deprecated obsolete -} -setup { - # I don't know how else to open the console, but this is non-portable - set console stdin -} -body { - fconfigure $console -nocomplainencoding 0 -} -returnCodes error -result "bad value for -nocomplainencoding: only true allowed" -test iocmd-8.22 {fconfigure command / -nocomplainencoding 0, no error if -strictencoding already defined} -setup { - set console stdin - set oldprofile [fconfigure $console -profile] -} -constraints { - obsolete -} -body { - fconfigure $console -strictencoding 1 - fconfigure $console -nocomplainencoding 0 - fconfigure $console -nocomplainencoding -} -cleanup { - fconfigure $console -strictencoding $oldmode -} -result 0 - - -test iocmd-8.23 {fconfigure -profile badprofile} -body { - fconfigure stdin -profile froboz -} -returnCodes error -result {bad profile name "froboz": must be replace, strict, or tcl8} test iocmd-9.1 {eof command} { list [catch {eof} msg] $msg $::errorCode -} {1 {wrong # args: should be "eof channelId"} {TCL WRONGARGS}} +} {1 {wrong # args: should be "eof channelId"} NONE} test iocmd-9.2 {eof command} { list [catch {eof a b} msg] $msg $::errorCode -} {1 {wrong # args: should be "eof channelId"} {TCL WRONGARGS}} +} {1 {wrong # args: should be "eof channelId"} NONE} test iocmd-9.3 {eof command} { catch {close file100} list [catch {eof file100} msg] $msg $::errorCode @@ -427,18 +366,19 @@ test iocmd-10.5 {fblocked command} { set path(test4) [makeFile {} test4] set path(test5) [makeFile {} test5] -test iocmd-11.1 {I/O to command pipelines} {unixOrWin unixExecs} { +file delete $path(test5) +test iocmd-11.1 {I/O to command pipelines} {unixOrPc unixExecs} { set f [open $path(test4) w] close $f list [catch {open "| cat < \"$path(test4)\" > \"$path(test5)\"" w} msg] $msg $::errorCode -} {1 {can't write input to command: standard input was redirected} {TCL OPERATION EXEC BADREDIRECT}} -test iocmd-11.2 {I/O to command pipelines} {unixOrWin unixExecs} { +} {1 {can't write input to command: standard input was redirected} NONE} +test iocmd-11.2 {I/O to command pipelines} {unixOrPc unixExecs} { list [catch {open "| echo > \"$path(test5)\"" r} msg] $msg $::errorCode -} {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}} -test iocmd-11.3 {I/O to command pipelines} {unixOrWin unixExecs} { +} {1 {can't read output from command: standard output was redirected} NONE} +test iocmd-11.3 {I/O to command pipelines} {unixOrPc unixExecs} { list [catch {open "| echo > \"$path(test5)\"" r+} msg] $msg $::errorCode -} {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}} -test iocmd-11.4 {I/O to command pipelines} {notValgrind unixOrWin} { +} {1 {can't read output from command: standard output was redirected} NONE} +test iocmd-11.4 {I/O to command pipelines} unixOrPc { list [catch {open "| no_such_command_exists" rb} msg] $msg $::errorCode } {1 {couldn't execute "no_such_command_exists": no such file or directory} {POSIX ENOENT {no such file or directory}}} @@ -519,14 +459,14 @@ test iocmd-12.10 {POSIX open access modes: BINARY} { } 5 test iocmd-12.11 {POSIX open access modes: BINARY} { set f [open $path(test1) {WRONLY BINARY TRUNC}] - puts $f Ɉ ;# gets truncated to H + puts $f \u0248 ;# gets truncated to \u0048 close $f set f [open $path(test1) r] fconfigure $f -translation binary set result [read -nonewline $f] close $f set result -} H +} \u0048 test iocmd-13.1 {errors in open command} { list [catch {open} msg] $msg @@ -587,48 +527,6 @@ test iocmd-13.10.2 {open for append, O_APPEND} -setup { # Ensure that channels are gone, even if body failed to do so foreach ch $chans {catch {close $ch}} } -result {0 1 2 3 4 5 6 7 8 9} -test ioCmd-13.11 {open ... a+ must not use O_APPEND: Bug 1773127} -setup { - set f [makeFile {} ioutil41.tmp] - set fid [open $f wb] - puts -nonewline $fid 123 - close $fid -} -body { - set fid [open $f ab+] - puts -nonewline $fid 456 - seek $fid 2 - set d [read $fid 2] - seek $fid 4 - puts -nonewline $fid x - close $fid - set fid [open $f rb] - append d [read $fid] - close $fid - return $d -} -cleanup { - removeFile $f -} -result 341234x6 -test ioCmd-13.12 {open file produces something that has fconfigure -stat} -setup { - set f [makeFile {} iocmd13_12] - set result {} -} -body { - set fd [open $f wb] - set result [dict get [fconfigure $fd -stat] type] - fconfigure $fd -buffering none - puts -nonewline $fd abc - # Three ways of getting the size; all should agree! - lappend result [tell $fd] [file size $f] \ - [dict get [fconfigure $fd -stat] size] - puts -nonewline $fd def - lappend result [tell $fd] [file size $f] \ - [dict get [fconfigure $fd -stat] size] - puts -nonewline $fd ghi - lappend result [tell $fd] [file size $f] \ - [dict get [fconfigure $fd -stat] size] - close $fd - return $result -} -cleanup { - removeFile $f -} -result {file 3 3 3 6 6 6 9 9 9} test iocmd-14.1 {file id parsing errors} { list [catch {eof gorp} msg] $msg $::errorCode @@ -702,7 +600,7 @@ test iocmd-15.9 {Tcl_FcopyObjCmd} {fcopy} { } "1 {channel \"$rfile\" wasn't opened for writing}" test iocmd-15.10 {Tcl_FcopyObjCmd} {fcopy} { list [catch {fcopy $rfile $wfile foo bar} msg] $msg -} {1 {bad option "foo": must be -size or -command}} +} {1 {bad switch "foo": must be -size or -command}} test iocmd-15.11 {Tcl_FcopyObjCmd} {fcopy} { list [catch {fcopy $rfile $wfile -size foo} msg] $msg } {1 {expected integer but got "foo"}} @@ -719,13 +617,14 @@ close $wfile test iocmd-20.0 {chan, wrong#args} { catch {chan} msg set msg -} {wrong # args: should be "chan subcommand ?arg ...?"} -test iocmd-20.1 {chan, unknown method} -body { - chan foo -} -returnCodes error -match glob -result {unknown or ambiguous subcommand "foo": must be *} +} {wrong # args: should be "chan subcommand ?argument ...?"} +test iocmd-20.1 {chan, unknown method} { + catch {chan foo} msg + set msg +} {unknown or ambiguous subcommand "foo": must be blocked, close, configure, copy, create, eof, event, flush, gets, names, pending, postevent, puts, read, seek, tell, or truncate} # --- --- --- --------- --------- --------- -# chan create, and method "initialize" +# chan create, and method "initalize" test iocmd-21.0 {chan create, wrong#args, not enough} { catch {chan create} msg @@ -735,12 +634,12 @@ test iocmd-21.1 {chan create, wrong#args, too many} { catch {chan create a b c} msg set msg } {wrong # args: should be "chan create mode cmdprefix"} -test iocmd-21.2 {chan create, r/w mode empty} { - proc foo {cmd args} { return {initialize finalize watch} } - set chan [chan create {} foo] - close $chan +test iocmd-21.2 {chan create, invalid r/w mode, empty} { + proc foo {} {} + catch {chan create {} foo} msg rename foo {} -} {} + set msg +} {bad mode list: is empty} test iocmd-21.3 {chan create, invalid r/w mode, bad string} { proc foo {} {} catch {chan create {c} foo} msg @@ -870,11 +769,11 @@ test iocmd-21.20 {Bug 88aef05cda} -setup { } set ch [chan create {read write} foo] } -body { - chan configure $ch -blocking 0 + list [catch {chan configure $ch -blocking 0} m] $m } -cleanup { close $ch rename foo {} -} -match glob -returnCodes 1 -result {*(infinite loop?)*} +} -match glob -result {1 {*nested eval*}} test iocmd-21.21 {[close] in [read] segfaults} -setup { proc foo {method chan args} { switch -- $method initialize { @@ -976,17 +875,6 @@ proc onfinal {} { if {[lindex $hargs 0] ne "finalize"} {return} return -code return "" } - -proc onwatch {} { - upvar args hargs - lassign $hargs watch chan eventspec - if {$watch ne "watch"} return - foreach spec $eventspec { - chan postevent $chan $spec - } - return -} - } # Set everything up in the main thread. @@ -1094,7 +982,7 @@ test iocmd-23.1 {chan read, regular data return} -match glob -body { rename foo {} set res } -result {{read rc* 4096} {read rc* 4096} snarfsnarf} -test iocmd-23.2 {chan read, bad data return, too much} -match glob -body { +test iocmd-23.2 {chan read, bad data return, to much} -match glob -body { set res {} proc foo {args} { oninit; onfinal; track @@ -1409,7 +1297,7 @@ test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body { close $c rename foo {} set res -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -profile * -translation {auto *}}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} proc foo {args} {oninit cget cgetall; onfinal; track; return ""} @@ -1418,7 +1306,7 @@ test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -profile * -translation {auto *}}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { set res {} proc foo {args} { @@ -1430,7 +1318,7 @@ test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -profile * -translation {auto *} -bar foo -snarf x}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *} -bar foo -snarf x}} test iocmd-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { set res {} proc foo {args} { @@ -2059,29 +1947,28 @@ test iocmd-31.6 {chan postevent, posted events do happen} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return} set c [chan create {r w} foo] - set tock {} - note [fileevent $c readable {lappend res TOCK; set tock 1}] - set stop [after 15000 {lappend res TIMEOUT; set tock 1}] + note [fileevent $c readable {note TOCK}] + set stop [after 10000 {note TIMEOUT}] after 1000 {note [chan postevent $c r]} - vwait ::tock + vwait ::res catch {after cancel $stop} close $c rename foo {} set res -} -result {{watch rc* read} {} {} TOCK {watch rc* {}}} +} -result {{watch rc* read} {} TOCK {} {watch rc* {}}} test iocmd-31.7 {chan postevent, posted events do happen} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return} set c [chan create {r w} foo] - note [fileevent $c writable {lappend res TOCK; set tock 1}] - set stop [after 15000 {lappend res TIMEOUT; set tock 1}] + note [fileevent $c writable {note TOCK}] + set stop [after 10000 {note TIMEOUT}] after 1000 {note [chan postevent $c w]} - vwait ::tock + vwait ::res catch {after cancel $stop} close $c rename foo {} set res -} -result {{watch rc* write} {} {} TOCK {watch rc* {}}} +} -result {{watch rc* write} {} TOCK {} {watch rc* {}}} test iocmd-31.8 {chan postevent after close throws error} -match glob -setup { proc foo {args} {oninit; onfinal; track; return} proc dummy args { return } @@ -2094,31 +1981,6 @@ test iocmd-31.8 {chan postevent after close throws error} -match glob -setup { rename foo {} rename dummy {} } -returnCodes error -result {can not find reflected channel named "rc*"} -test iocmd-31.9 { - chan postevent - - call to current coroutine - - see 67a5eabbd3d1 -} -match glob -body { - set res {} - proc foo {args} {oninit; onwatch; onfinal; track; return} - set c [chan create {r w} foo] - after 0 [list ::apply [list c { - coroutine c1 ::apply [list c { - chan event $c readable [list [info coroutine]] - yield - set ::done READING - } [namespace current]] $c - } [namespace current]] $c] - set stop [after 10000 {set done TIMEOUT}] - vwait ::done - catch {after cancel $stop} - lappend res $done - close $c - rename foo {} - set res -} -result {{watch rc* read} READING {watch rc* {}}} # --- === *** ########################### # 'Pull the rug' tests. Create channel in a interpreter A, move to @@ -2130,7 +1992,7 @@ test iocmd-32.0 {origin interpreter of moved channel gone} -match glob -body { set ida [interp create];#puts <<$ida>> set idb [interp create];#puts <<$idb>> - # Magic to get the test* commands in the children + # Magic to get the test* commands in the slaves load {} Tcltest $ida load {} Tcltest $idb @@ -2158,8 +2020,6 @@ test iocmd-32.0 {origin interpreter of moved channel gone} -match glob -body { lappend res [catch {interp eval $idb [list close $chan]} msg] $msg set res -} -cleanup { - interp delete $idb } -constraints {testchannel} \ -result {1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} @@ -2168,7 +2028,7 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m set ida [interp create];#puts <<$ida>> set idb [interp create];#puts <<$idb>> - # Magic to get the test* commands in the children + # Magic to get the test* commands in the slaves load {} Tcltest $ida load {} Tcltest $idb @@ -2194,6 +2054,7 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m # response. interp eval $idb [list set chan $chan] + interp eval $idb [list set mid $tcltest::mainThread] set res [interp eval $idb { # wait a bit, give the main thread the time to start its event # loop to wait for the response from B @@ -2202,21 +2063,19 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m set res }] set res -} -cleanup { - interp delete $idb } -constraints {testchannel} -result {Owner lost} test iocmd-32.2 {delete interp of reflected chan} { # Bug 3034840 # Run this test in an interp with memory debugging to panic # on the double free - interp create child - child eval { - proc no-op args {} - proc driver {sub args} {return {initialize finalize watch read}} - chan event [chan create read driver] readable no-op + interp create slave + slave eval { + proc no-op args {} + proc driver {sub args} {return {initialize finalize watch read}} + chan event [chan create read driver] readable no-op } - interp delete child + interp delete slave } {} # ### ### ### ######### ######### ######### @@ -2231,6 +2090,23 @@ test iocmd-32.2 {delete interp of reflected chan} { ## forwarding, and gaps due to tests not applicable to forwarding are ## left to keep this asociation. +# Duplicate of code in "thread.test". Find a better way of doing this +# without duplication. Maybe placement into a proc which transforms to +# nop after the first call, and placement of its defintion in a +# central location. + +if {[testConstraint testthread]} { + testthread errorproc ThreadError + + proc ThreadError {id info} { + global threadError + set threadError $info + } + proc ThreadNullError {id info} { + # ignore + } +} + # ### ### ### ######### ######### ######### ## Helper command. Runs a script in a separate thread and returns the ## result. A channel is transfered into the thread as well, and list of @@ -2239,8 +2115,7 @@ test iocmd-32.2 {delete interp of reflected chan} { proc inthread {chan script args} { # Test thread. - set tid [thread::create -preserved] - thread::send $tid {load {} Tcltest} + set tid [testthread create] # Init thread configuration. # - Listed variables @@ -2249,23 +2124,22 @@ proc inthread {chan script args} { foreach v $args { upvar 1 $v x - thread::send $tid [list set $v $x] - + testthread send $tid [list set $v $x] } - thread::send $tid [list set mid [thread::id]] - thread::send $tid { + testthread send $tid [list set mid $tcltest::mainThread] + testthread send $tid { proc note {item} {global notes; lappend notes $item} proc notes {} {global notes; return $notes} proc noteOpts opts {global notes; lappend notes [dict merge { -code !?! -level !?! -errorcode !?! -errorline !?! -errorinfo !?! } $opts]} } - thread::send $tid [list proc s {} [list uplevel 1 $script]]; # (*) + testthread send $tid [list proc s {} [list uplevel 1 $script]]; # (*) # Transfer channel (cut/splice aka detach/attach) testchannel cut $chan - thread::send $tid [list testchannel splice $chan] + testthread send $tid [list testchannel splice $chan] # Run test script, also run local event loop! # The local event loop waits for the result to come back. @@ -2273,15 +2147,15 @@ proc inthread {chan script args} { # operations. set ::tres "" - thread::send -async $tid { + testthread send -async $tid { after 500 catch {s} res; # This runs the script, 's' was defined at (*) - thread::send -async $mid [list set ::tres $res] + testthread send -async $mid [list set ::tres $res] } vwait ::tres # Remove test thread, and return the captured result. - thread::release $tid + tcltest::threadReap return $::tres } @@ -2302,7 +2176,7 @@ test iocmd.tf-22.2 {chan finalize, for close} -match glob -body { note [info command foo] rename foo {} set res -} -constraints {testchannel thread} -result {{initialize rc* {read write}} rc* {finalize rc*} {} foo} +} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} {} foo} test iocmd.tf-22.3 {chan finalize, for close, error, close error} -match glob -body { set res {} proc foo {args} {track; oninit; return -code error 5} @@ -2315,7 +2189,7 @@ test iocmd.tf-22.3 {chan finalize, for close, error, close error} -match glob -b } c] rename foo {} set res -} -constraints {testchannel thread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 5 {}} +} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 5 {}} test iocmd.tf-22.4 {chan finalize, for close, error, close errror} -match glob -body { set res {} proc foo {args} {track; oninit; error FOO} @@ -2326,7 +2200,7 @@ test iocmd.tf-22.4 {chan finalize, for close, error, close errror} -match glob - } c] rename foo {} set res -} -constraints {testchannel thread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 FOO} +} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 FOO} test iocmd.tf-22.5 {chan finalize, for close, arbitrary result} -match glob -body { set res {} proc foo {args} {track; oninit; return SOMETHING} @@ -2337,7 +2211,7 @@ test iocmd.tf-22.5 {chan finalize, for close, arbitrary result} -match glob -bod } c] rename foo {} set res -} -constraints {testchannel thread} -result {{initialize rc* {read write}} rc* {finalize rc*} 0 {}} +} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} 0 {}} test iocmd.tf-22.6 {chan finalize, for close, break, close error} -match glob -body { set res {} proc foo {args} {track; oninit; return -code 3} @@ -2349,7 +2223,7 @@ test iocmd.tf-22.6 {chan finalize, for close, break, close error} -match glob -b rename foo {} set res } -result {{initialize rc* {read write}} rc* {finalize rc*} 1 *bad code*} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-22.7 {chan finalize, for close, continue, close error} -match glob -body { set res {} proc foo {args} {track; oninit; return -code 4} @@ -2361,7 +2235,7 @@ test iocmd.tf-22.7 {chan finalize, for close, continue, close error} -match glob rename foo {} set res } -result {{initialize rc* {read write}} rc* {finalize rc*} 1 *bad code*} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-22.8 {chan finalize, for close, custom code, close error} -match glob -body { set res {} proc foo {args} {track; oninit; return -code 777 BANG} @@ -2373,7 +2247,7 @@ test iocmd.tf-22.8 {chan finalize, for close, custom code, close error} -match g rename foo {} set res } -result {{initialize rc* {read write}} rc* {finalize rc*} 1 *bad code*} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-22.9 {chan finalize, for close, ignore level, close error} -match glob -body { set res {} proc foo {args} {track; oninit; return -level 5 -code 777 BANG} @@ -2385,7 +2259,7 @@ test iocmd.tf-22.9 {chan finalize, for close, ignore level, close error} -match rename foo {} set res } -result {{initialize rc* {read write}} rc* {finalize rc*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} # --- === *** ########################### # method read @@ -2404,8 +2278,8 @@ test iocmd.tf-23.1 {chan read, regular data return} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel thread} -result {{read rc* 4096} {read rc* 4096} snarfsnarf} -test iocmd.tf-23.2 {chan read, bad data return, too much} -match glob -body { +} -constraints {testchannel testthread} -result {{read rc* 4096} {read rc* 4096} snarfsnarf} +test iocmd.tf-23.2 {chan read, bad data return, to much} -match glob -body { set res {} proc foo {args} { oninit; onfinal; track @@ -2419,7 +2293,7 @@ test iocmd.tf-23.2 {chan read, bad data return, too much} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel thread} -result {{read rc* 4096} 1 {read delivered more than requested}} +} -constraints {testchannel testthread} -result {{read rc* 4096} 1 {read delivered more than requested}} test iocmd.tf-23.3 {chan read, for non-readable channel} -match glob -body { set res {} proc foo {args} { @@ -2433,7 +2307,7 @@ test iocmd.tf-23.3 {chan read, for non-readable channel} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel thread} -result {1 {channel "rc*" wasn't opened for reading}} +} -constraints {testchannel testthread} -result {1 {channel "rc*" wasn't opened for reading}} test iocmd.tf-23.4 {chan read, error return} -match glob -body { set res {} proc foo {args} { @@ -2449,7 +2323,7 @@ test iocmd.tf-23.4 {chan read, error return} -match glob -body { rename foo {} set res } -result {{read rc* 4096} 1 BOOM!} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-23.5 {chan read, break return is error} -match glob -body { set res {} proc foo {args} { @@ -2465,7 +2339,7 @@ test iocmd.tf-23.5 {chan read, break return is error} -match glob -body { rename foo {} set res } -result {{read rc* 4096} 1 *bad code*} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-23.6 {chan read, continue return is error} -match glob -body { set res {} proc foo {args} { @@ -2481,7 +2355,7 @@ test iocmd.tf-23.6 {chan read, continue return is error} -match glob -body { rename foo {} set res } -result {{read rc* 4096} 1 *bad code*} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-23.7 {chan read, custom return is error} -match glob -body { set res {} proc foo {args} { @@ -2497,7 +2371,7 @@ test iocmd.tf-23.7 {chan read, custom return is error} -match glob -body { rename foo {} set res } -result {{read rc* 4096} 1 *bad code*} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-23.8 {chan read, level is squashed} -match glob -body { set res {} proc foo {args} { @@ -2513,7 +2387,7 @@ test iocmd.tf-23.8 {chan read, level is squashed} -match glob -body { rename foo {} set res } -result {{read rc* 4096} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-23.9 {chan read, no data means eof} -match glob -setup { set res {} proc foo {args} { @@ -2533,7 +2407,7 @@ test iocmd.tf-23.9 {chan read, no data means eof} -match glob -setup { rename foo {} unset res } -result {{read rc* 4096} {} 1} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-23.10 {chan read, EAGAIN means no data, yet no eof either} -match glob -setup { set res {} proc foo {args} { @@ -2553,7 +2427,7 @@ test iocmd.tf-23.10 {chan read, EAGAIN means no data, yet no eof either} -match rename foo {} unset res } -result {{read rc* 4096} {} 0} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} # --- === *** ########################### # method write @@ -2573,7 +2447,7 @@ test iocmd.tf-24.1 {chan write, regular write} -match glob -body { } c rename foo {} set res -} -constraints {testchannel thread} -result {{write rc* snarf} 5} +} -constraints {testchannel testthread} -result {{write rc* snarf} 5} test iocmd.tf-24.2 {chan write, ack partial writes} -match glob -body { set res {} proc foo {args} { @@ -2590,7 +2464,7 @@ test iocmd.tf-24.2 {chan write, ack partial writes} -match glob -body { } c rename foo {} set res -} -constraints {testchannel thread} -result {{write rc* snarfsnarfsnarf} 7 {write rc* arfsnarf} 8} +} -constraints {testchannel testthread} -result {{write rc* snarfsnarfsnarf} 7 {write rc* arfsnarf} 8} test iocmd.tf-24.3 {chan write, failed write} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; note -1; return -1} @@ -2601,7 +2475,7 @@ test iocmd.tf-24.3 {chan write, failed write} -match glob -body { } c rename foo {} set res -} -constraints {testchannel thread} -result {{write rc* snarfsnarfsnarf} -1} +} -constraints {testchannel testthread} -result {{write rc* snarfsnarfsnarf} -1} test iocmd.tf-24.4 {chan write, non-writable channel} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} @@ -2614,7 +2488,7 @@ test iocmd.tf-24.4 {chan write, non-writable channel} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel thread} -result {1 {channel "rc*" wasn't opened for writing}} +} -constraints {testchannel testthread} -result {1 {channel "rc*" wasn't opened for writing}} test iocmd.tf-24.5 {chan write, bad result, more written than data} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return 10000} @@ -2627,7 +2501,7 @@ test iocmd.tf-24.5 {chan write, bad result, more written than data} -match glob } c] rename foo {} set res -} -constraints {testchannel thread} -result {{write rc* snarf} 1 {write wrote more than requested}} +} -constraints {testchannel testthread} -result {{write rc* snarf} 1 {write wrote more than requested}} test iocmd.tf-24.6 {chan write, zero writes} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return 0} @@ -2640,7 +2514,7 @@ test iocmd.tf-24.6 {chan write, zero writes} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel thread} -result {{write rc* snarf} 1 {write wrote more than requested}} +} -constraints {testchannel testthread} -result {{write rc* snarf} 1 {write wrote more than requested}} test iocmd.tf-24.7 {chan write, failed write, error return} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return -code error BOOM!} @@ -2654,7 +2528,7 @@ test iocmd.tf-24.7 {chan write, failed write, error return} -match glob -body { rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-24.8 {chan write, failed write, error return} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; error BOOM!} @@ -2668,7 +2542,7 @@ test iocmd.tf-24.8 {chan write, failed write, error return} -match glob -body { rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-24.9 {chan write, failed write, break return is error} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return -code break BOOM!} @@ -2682,7 +2556,7 @@ test iocmd.tf-24.9 {chan write, failed write, break return is error} -match glob rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 *bad code*} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-24.10 {chan write, failed write, continue return is error} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return -code continue BOOM!} @@ -2696,7 +2570,7 @@ test iocmd.tf-24.10 {chan write, failed write, continue return is error} -match rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 *bad code*} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-24.11 {chan write, failed write, custom return is error} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return -code 777 BOOM!} @@ -2710,7 +2584,7 @@ test iocmd.tf-24.11 {chan write, failed write, custom return is error} -match gl rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 *bad code*} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-24.12 {chan write, failed write, non-numeric return is error} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return BANG} @@ -2724,7 +2598,7 @@ test iocmd.tf-24.12 {chan write, failed write, non-numeric return is error} -mat rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 {expected integer but got "BANG"}} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-24.13 {chan write, failed write, level is ignored} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return -level 55 -code 777 BOOM!} @@ -2739,7 +2613,7 @@ test iocmd.tf-24.13 {chan write, failed write, level is ignored} -match glob -bo rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "write"*}} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-24.14 {chan write, no EAGAIN means that writing is allowed at this time, bug 2936225} -match glob -setup { set res {} proc foo {args} { @@ -2758,7 +2632,7 @@ test iocmd.tf-24.14 {chan write, no EAGAIN means that writing is allowed at this rename foo {} unset res } -result {{write rc* ABC} {}} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-24.15 {chan write, EAGAIN means that writing is not allowed at this time, bug 2936225} -match glob -setup { set res {} proc foo {args} { @@ -2778,163 +2652,10 @@ test iocmd.tf-24.15 {chan write, EAGAIN means that writing is not allowed at thi } c] set res } -cleanup { - proc foo {args} {onfinal; set ::done-24.15 1; return 3} - after 1000 {set ::done-24.15 2} - vwait done-24.15 rename foo {} unset res } -result {{write rc* ABC} {watch rc* write} {}} \ - -constraints {testchannel thread} - -test iocmd.tf-24.16 {chan write, note the background flush setup by close due to the EAGAIN leaving data in buffers.} -match glob -setup { - set res {} - proc foo {args} { - oninit; onfinal; track - # Note: The EAGAIN signals that the channel cannot accept - # write requests right now, this in turn causes the IO core to - # request the generation of writable events (see expected - # result below, and compare to case 24.14 above). - error EAGAIN - } - set c [chan create {r w} foo] -} -body { - notes [inthread $c { - note [puts -nonewline $c ABC ; flush $c] - close $c - notes - } c] - # Replace handler with all-tracking one which doesn't error. - # This will tell us if a write-due-flush is there. - proc foo {args} { onfinal; note BG ; track ; set ::endbody-24.16 1} - # Flush (sic!) the event-queue to capture the write from a - # BG-flush. - after 1000 {set ::endbody-24.16 2} - vwait endbody-24.16 - set res -} -cleanup { - proc foo {args} {onfinal; set ::done-24.16 1; return 3} - after 1000 {set ::done-24.16 2} - vwait done-24.16 - rename foo {} - unset res -} -result {{write rc* ABC} {watch rc* write} {} BG {write rc* ABC}} \ - -constraints {testchannel thread} - -test iocmd.tf-24.17.bug3522560 {postevent for transfered channel} \ - -constraints {testchannel thread} -setup { - # This test exposes how the execution of postevent in the handler thread causes - # a crash if we are not properly injecting the events into the owning thread instead. - # With the injection the test will simply complete without crash. - - set beat 10000 - set drive 999 - set data ...---... - - proc LOG {text} { - #puts stderr "[thread::id]: $text" - return - } - - proc POST {hi} { - LOG "-> [info level 0]" - chan postevent $hi read - LOG "<- [info level 0]" - - set ::timer [after $::drive [info level 0]] - return - } - - proc HANDLER {op ch args} { - lappend ::res [lrange [info level 0] 1 end] - LOG "-> [info level 0]" - set ret {} - switch -glob -- $op { - init* {set ret {initialize finalize watch read}} - watch { - set l [lindex $args 0] - catch {after cancel $::timer} - if {[llength $l]} { - set ::timer [after $::drive [list POST $ch]] - } - } - finalize { - catch { after cancel $::timer } - after 500 {set ::forever now} - } - read { - set ret $::data - set ::data {} ; # Next is EOF. - } - } - LOG "<- [info level 0] : $ret" - return $ret - } -} -body { - LOG BEGIN - set ch [chan create {read} HANDLER] - - set tid [thread::create { - proc LOG {text} { - #puts stderr "\t\t\t\t\t\t[thread::id]: $text" - return - } - LOG THREAD-STARTED - load {} Tcltest - proc bgerror s { - LOG BGERROR:$s - } - vwait forever - LOG THREAD-DONE - }] - - testchannel cut $ch - thread::send $tid [list set thech $ch] - thread::send $tid [list set beat $beat] - thread::send -async $tid { - LOG SPLICE-BEG - testchannel splice $thech - LOG SPLICE-END - proc PROCESS {ch} { - LOG "-> [info level 0]" - if {[eof $ch]} { - close $ch - set ::done 1 - set c <<EOF>> - } else { - set c [read $ch 1] - } - LOG "GOTCHAR: $c" - LOG "<- [info level 0]" - } - LOG THREAD-FILEEVENT - fconfigure $thech -translation binary -blocking 0 - fileevent $thech readable [list PROCESS $thech] - LOG THREAD-NOEVENT-LOOP - set done 0 - while {!$done} { - after $beat - LOG THREAD-HEARTBEAT - update - } - LOG THREAD-LOOP-DONE - #thread::exit - # Thread exits cause leaks; Use clean thread shutdown - set forever yourGirl - } - - LOG MAIN_WAITING - vwait forever - LOG MAIN_DONE - - set res -} -cleanup { - after cancel $::timer - rename LOG {} - rename POST {} - rename HANDLER {} - unset beat drive data forever res tid ch timer -} -match glob \ - -result {{initialize rc* read} {watch rc* read} {read rc* 4096} {watch rc* {}} {watch rc* read} {read rc* 4096} {watch rc* {}} {finalize rc*}} + -constraints {testchannel testthread} # --- === *** ########################### # method cgetall @@ -2950,8 +2671,8 @@ test iocmd.tf-25.1 {chan configure, cgetall, standard options} -match glob -body } c] rename foo {} set res -} -constraints {testchannel thread} \ - -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} * -translation {auto *}}} +} -constraints {testchannel testthread} \ + -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} proc foo {args} {oninit cget cgetall; onfinal; track; return ""} @@ -2963,8 +2684,8 @@ test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel thread} \ - -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} * -translation {auto *}}} +} -constraints {testchannel testthread} \ + -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body { set res {} proc foo {args} { @@ -2979,8 +2700,8 @@ test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel thread} \ - -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} * -translation {auto *} -bar foo -snarf x}} +} -constraints {testchannel testthread} \ + -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *} -bar foo -snarf x}} test iocmd.tf-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { set res {} proc foo {args} { @@ -2996,7 +2717,7 @@ test iocmd.tf-25.4 {chan configure, cgetall, bad result, list of uneven length} } c] rename foo {} set res -} -constraints {testchannel thread} -result {{cgetall rc*} 1 {Expected list with even number of elements, got 1 element instead}} +} -constraints {testchannel testthread} -result {{cgetall rc*} 1 {Expected list with even number of elements, got 1 element instead}} test iocmd.tf-25.5 {chan configure, cgetall, bad result, not a list} -match glob -body { set res {} proc foo {args} { @@ -3012,7 +2733,7 @@ test iocmd.tf-25.5 {chan configure, cgetall, bad result, not a list} -match glob } c] rename foo {} set res -} -constraints {testchannel thread} -result {{cgetall rc*} 1 {unmatched open brace in list}} +} -constraints {testchannel testthread} -result {{cgetall rc*} 1 {unmatched open brace in list}} test iocmd.tf-25.6 {chan configure, cgetall, error return} -match glob -body { set res {} proc foo {args} { @@ -3028,7 +2749,7 @@ test iocmd.tf-25.6 {chan configure, cgetall, error return} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel thread} -result {{cgetall rc*} 1 BOOM!} +} -constraints {testchannel testthread} -result {{cgetall rc*} 1 BOOM!} test iocmd.tf-25.7 {chan configure, cgetall, break return is error} -match glob -body { set res {} proc foo {args} { @@ -3045,7 +2766,7 @@ test iocmd.tf-25.7 {chan configure, cgetall, break return is error} -match glob rename foo {} set res } -result {{cgetall rc*} 1 *bad code*} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-25.8 {chan configure, cgetall, continue return is error} -match glob -body { set res {} proc foo {args} { @@ -3062,7 +2783,7 @@ test iocmd.tf-25.8 {chan configure, cgetall, continue return is error} -match gl rename foo {} set res } -result {{cgetall rc*} 1 *bad code*} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-25.9 {chan configure, cgetall, custom return is error} -match glob -body { set res {} proc foo {args} { @@ -3079,7 +2800,7 @@ test iocmd.tf-25.9 {chan configure, cgetall, custom return is error} -match glob rename foo {} set res } -result {{cgetall rc*} 1 *bad code*} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-25.10 {chan configure, cgetall, level is ignored} -match glob -body { set res {} proc foo {args} { @@ -3097,7 +2818,7 @@ test iocmd.tf-25.10 {chan configure, cgetall, level is ignored} -match glob -bod rename foo {} set res } -result {{cgetall rc*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "cgetall"*}} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} # --- === *** ########################### # method configure @@ -3115,7 +2836,7 @@ test iocmd.tf-26.1 {chan configure, set standard option} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel thread} -result {{}} +} -constraints {testchannel testthread} -result {{}} test iocmd.tf-26.2 {chan configure, set option, error return} -match glob -body { set res {} proc foo {args} { @@ -3131,7 +2852,7 @@ test iocmd.tf-26.2 {chan configure, set option, error return} -match glob -body } c] rename foo {} set res -} -constraints {testchannel thread} -result {{configure rc* -rc-foo bar} 1 BOOM!} +} -constraints {testchannel testthread} -result {{configure rc* -rc-foo bar} 1 BOOM!} test iocmd.tf-26.3 {chan configure, set option, ok return} -match glob -body { set res {} proc foo {args} {oninit configure; onfinal; track; return} @@ -3143,7 +2864,7 @@ test iocmd.tf-26.3 {chan configure, set option, ok return} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel thread} -result {{configure rc* -rc-foo bar} {}} +} -constraints {testchannel testthread} -result {{configure rc* -rc-foo bar} {}} test iocmd.tf-26.4 {chan configure, set option, break return is error} -match glob -body { set res {} proc foo {args} { @@ -3160,7 +2881,7 @@ test iocmd.tf-26.4 {chan configure, set option, break return is error} -match gl rename foo {} set res } -result {{configure rc* -rc-foo bar} 1 *bad code*} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-26.5 {chan configure, set option, continue return is error} -match glob -body { set res {} proc foo {args} { @@ -3177,7 +2898,7 @@ test iocmd.tf-26.5 {chan configure, set option, continue return is error} -match rename foo {} set res } -result {{configure rc* -rc-foo bar} 1 *bad code*} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-26.6 {chan configure, set option, custom return is error} -match glob -body { set res {} proc foo {args} { @@ -3194,7 +2915,7 @@ test iocmd.tf-26.6 {chan configure, set option, custom return is error} -match g rename foo {} set res } -result {{configure rc* -rc-foo bar} 1 *bad code*} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-26.7 {chan configure, set option, level is ignored} -match glob -body { set res {} proc foo {args} { @@ -3212,7 +2933,7 @@ test iocmd.tf-26.7 {chan configure, set option, level is ignored} -match glob -b rename foo {} set res } -result {{configure rc* -rc-foo bar} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "configure"*}} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} # --- === *** ########################### # method cget @@ -3228,7 +2949,7 @@ test iocmd.tf-27.1 {chan configure, get option, ok return} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel thread} -result {{cget rc* -rc-foo} foo} +} -constraints {testchannel testthread} -result {{cget rc* -rc-foo} foo} test iocmd.tf-27.2 {chan configure, get option, error return} -match glob -body { set res {} proc foo {args} { @@ -3244,7 +2965,7 @@ test iocmd.tf-27.2 {chan configure, get option, error return} -match glob -body } c] rename foo {} set res -} -constraints {testchannel thread} -result {{cget rc* -rc-foo} 1 BOOM!} +} -constraints {testchannel testthread} -result {{cget rc* -rc-foo} 1 BOOM!} test iocmd.tf-27.3 {chan configure, get option, break return is error} -match glob -body { set res {} proc foo {args} { @@ -3261,7 +2982,7 @@ test iocmd.tf-27.3 {chan configure, get option, break return is error} -match gl rename foo {} set res } -result {{cget rc* -rc-foo} 1 BOOM!} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-27.4 {chan configure, get option, continue return is error} -match glob -body { set res {} proc foo {args} { @@ -3278,7 +2999,7 @@ test iocmd.tf-27.4 {chan configure, get option, continue return is error} -match rename foo {} set res } -result {{cget rc* -rc-foo} 1 *bad code*} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-27.5 {chan configure, get option, custom return is error} -match glob -body { set res {} proc foo {args} { @@ -3295,7 +3016,7 @@ test iocmd.tf-27.5 {chan configure, get option, custom return is error} -match g rename foo {} set res } -result {{cget rc* -rc-foo} 1 *bad code*} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-27.6 {chan configure, get option, level is ignored} -match glob -body { set res {} proc foo {args} { @@ -3313,7 +3034,7 @@ test iocmd.tf-27.6 {chan configure, get option, level is ignored} -match glob -b rename foo {} set res } -result {{cget rc* -rc-foo} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "cget"*}} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} # --- === *** ########################### # method seek @@ -3330,7 +3051,7 @@ test iocmd.tf-28.1 {chan tell, not supported by handler} -match glob -body { rename foo {} set res } -result {-1} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-28.2 {chan tell, error return} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -code error BOOM!} @@ -3344,7 +3065,7 @@ test iocmd.tf-28.2 {chan tell, error return} -match glob -body { rename foo {} set res } -result {{seek rc* 0 current} 1 BOOM!} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-28.3 {chan tell, break return is error} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -code break BOOM!} @@ -3358,7 +3079,7 @@ test iocmd.tf-28.3 {chan tell, break return is error} -match glob -body { rename foo {} set res } -result {{seek rc* 0 current} 1 *bad code*} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-28.4 {chan tell, continue return is error} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -code continue BOOM!} @@ -3372,7 +3093,7 @@ test iocmd.tf-28.4 {chan tell, continue return is error} -match glob -body { rename foo {} set res } -result {{seek rc* 0 current} 1 *bad code*} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-28.5 {chan tell, custom return is error} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -code 222 BOOM!} @@ -3386,7 +3107,7 @@ test iocmd.tf-28.5 {chan tell, custom return is error} -match glob -body { rename foo {} set res } -result {{seek rc* 0 current} 1 *bad code*} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-28.6 {chan tell, level is ignored} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -level 11 -code 222 BANG} @@ -3401,7 +3122,7 @@ test iocmd.tf-28.6 {chan tell, level is ignored} -match glob -body { rename foo {} set res } -result {{seek rc* 0 current} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "seek"*}} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-28.7 {chan tell, regular return} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return 88} @@ -3414,7 +3135,7 @@ test iocmd.tf-28.7 {chan tell, regular return} -match glob -body { rename foo {} set res } -result {{seek rc* 0 current} 88} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-28.8 {chan tell, negative return} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -1} @@ -3428,7 +3149,7 @@ test iocmd.tf-28.8 {chan tell, negative return} -match glob -body { rename foo {} set res } -result {{seek rc* 0 current} 1 {Tried to seek before origin}} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-28.9 {chan tell, string return} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return BOGUS} @@ -3442,7 +3163,7 @@ test iocmd.tf-28.9 {chan tell, string return} -match glob -body { rename foo {} set res } -result {{seek rc* 0 current} 1 {expected integer but got "BOGUS"}} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-28.10 {chan seek, not supported by handler} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} @@ -3456,7 +3177,7 @@ test iocmd.tf-28.10 {chan seek, not supported by handler} -match glob -body { rename foo {} set res } -result {1 {error during seek on "rc*": invalid argument}} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-28.11 {chan seek, error return} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -code error BOOM!} @@ -3470,7 +3191,7 @@ test iocmd.tf-28.11 {chan seek, error return} -match glob -body { rename foo {} set res } -result {{seek rc* 0 start} 1 BOOM!} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-28.12 {chan seek, break return is error} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -code break BOOM!} @@ -3484,7 +3205,7 @@ test iocmd.tf-28.12 {chan seek, break return is error} -match glob -body { rename foo {} set res } -result {{seek rc* 0 start} 1 *bad code*} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-28.13 {chan seek, continue return is error} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -code continue BOOM!} @@ -3498,7 +3219,7 @@ test iocmd.tf-28.13 {chan seek, continue return is error} -match glob -body { rename foo {} set res } -result {{seek rc* 0 start} 1 *bad code*} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-28.14 {chan seek, custom return is error} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -code 99 BOOM!} @@ -3512,7 +3233,7 @@ test iocmd.tf-28.14 {chan seek, custom return is error} -match glob -body { rename foo {} set res } -result {{seek rc* 0 start} 1 *bad code*} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-28.15 {chan seek, level is ignored} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -level 33 -code 99 BANG} @@ -3527,7 +3248,7 @@ test iocmd.tf-28.15 {chan seek, level is ignored} -match glob -body { rename foo {} set res } -result {{seek rc* 0 start} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "seek"*}} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-28.16 {chan seek, bogus return, negative location} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -45} @@ -3541,7 +3262,7 @@ test iocmd.tf-28.16 {chan seek, bogus return, negative location} -match glob -bo rename foo {} set res } -result {{seek rc* 0 start} 1 {Tried to seek before origin}} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-28.17 {chan seek, bogus return, string return} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return BOGUS} @@ -3555,7 +3276,7 @@ test iocmd.tf-28.17 {chan seek, bogus return, string return} -match glob -body { rename foo {} set res } -result {{seek rc* 0 start} 1 {expected integer but got "BOGUS"}} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-28.18 {chan seek, ok result} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return 23} @@ -3568,7 +3289,7 @@ test iocmd.tf-28.18 {chan seek, ok result} -match glob -body { rename foo {} set res } -result {{seek rc* 0 current} {}} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} foreach {testname code} { iocmd.tf-28.19.0 start iocmd.tf-28.19.1 current @@ -3586,7 +3307,7 @@ foreach {testname code} { rename foo {} set res } -result [list [list seek rc* 0 $code] {}] \ - -constraints {testchannel thread} + -constraints {testchannel testthread} } # --- === *** ########################### @@ -3604,7 +3325,7 @@ test iocmd.tf-29.1 {chan blocking, no handler support} -match glob -body { rename foo {} set res } -result {1} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-29.2 {chan blocking, no handler support} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} @@ -3618,7 +3339,7 @@ test iocmd.tf-29.2 {chan blocking, no handler support} -match glob -body { rename foo {} set res } -result {{} 0} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-29.3 {chan blocking, retrieval, handler support} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; note MUST_NOT_HAPPEN; return} @@ -3631,7 +3352,7 @@ test iocmd.tf-29.3 {chan blocking, retrieval, handler support} -match glob -body rename foo {} set res } -result {1} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-29.4 {chan blocking, resetting, handler support} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return} @@ -3645,7 +3366,7 @@ test iocmd.tf-29.4 {chan blocking, resetting, handler support} -match glob -body rename foo {} set res } -result {{blocking rc* 0} {} 0} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-29.5 {chan blocking, setting, handler support} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return} @@ -3659,7 +3380,7 @@ test iocmd.tf-29.5 {chan blocking, setting, handler support} -match glob -body { rename foo {} set res } -result {{blocking rc* 1} {} 1} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-29.6 {chan blocking, error return} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; error BOOM!} @@ -3674,7 +3395,7 @@ test iocmd.tf-29.6 {chan blocking, error return} -match glob -body { rename foo {} set res } -result {{blocking rc* 0} 1 BOOM!} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-29.7 {chan blocking, break return is error} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return -code break BOOM!} @@ -3688,7 +3409,7 @@ test iocmd.tf-29.7 {chan blocking, break return is error} -match glob -body { rename foo {} set res } -result {{blocking rc* 0} 1 *bad code*} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-29.8 {chan blocking, continue return is error} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return -code continue BOOM!} @@ -3702,7 +3423,7 @@ test iocmd.tf-29.8 {chan blocking, continue return is error} -match glob -body { rename foo {} set res } -result {{blocking rc* 0} 1 *bad code*} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-29.9 {chan blocking, custom return is error} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return -code 44 BOOM!} @@ -3716,7 +3437,7 @@ test iocmd.tf-29.9 {chan blocking, custom return is error} -match glob -body { rename foo {} set res } -result {{blocking rc* 0} 1 *bad code*} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-29.10 {chan blocking, level is ignored} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return -level 99 -code 44 BANG} @@ -3731,7 +3452,7 @@ test iocmd.tf-29.10 {chan blocking, level is ignored} -match glob -body { rename foo {} set res } -result {{blocking rc* 0} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "blocking"*}} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} test iocmd.tf-29.11 {chan blocking, regular return ok, value ignored} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return BOGUS} @@ -3745,7 +3466,7 @@ test iocmd.tf-29.11 {chan blocking, regular return ok, value ignored} -match glo rename foo {} set res } -result {{blocking rc* 0} 0 {}} \ - -constraints {testchannel thread} + -constraints {testchannel testthread} # --- === *** ########################### # method watch @@ -3761,7 +3482,7 @@ test iocmd.tf-30.1 {chan watch, read interest, some return} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel thread} -result {{watch rc* read} {watch rc* {}} {}} +} -constraints {testchannel testthread} -result {{watch rc* read} {watch rc* {}} {}} test iocmd.tf-30.2 {chan watch, write interest, error return} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return -code error BOOM!_IGNORED} @@ -3774,7 +3495,7 @@ test iocmd.tf-30.2 {chan watch, write interest, error return} -match glob -body } c] rename foo {} set res -} -constraints {testchannel thread} -result {{watch rc* write} {watch rc* {}} {} {}} +} -constraints {testchannel testthread} -result {{watch rc* write} {watch rc* {}} {} {}} test iocmd.tf-30.3 {chan watch, accumulated interests} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return} @@ -3789,7 +3510,7 @@ test iocmd.tf-30.3 {chan watch, accumulated interests} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel thread} \ +} -constraints {testchannel testthread} \ -result {{watch rc* write} {watch rc* {read write}} {watch rc* read} {watch rc* {}} {} {} {} {}} test iocmd.tf-30.4 {chan watch, unchanged interest not forwarded} -match glob -body { set res {} @@ -3804,7 +3525,7 @@ test iocmd.tf-30.4 {chan watch, unchanged interest not forwarded} -match glob -b } c] rename foo {} set res -} -constraints {testchannel thread} \ +} -constraints {testchannel testthread} \ -result {{watch rc* write} {watch rc* {read write}} {watch rc* write} {watch rc* {}} {} {} {}} # --- === *** ########################### @@ -3824,7 +3545,7 @@ test iocmd.tf-31.8 {chan postevent, bad input} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel thread} \ +} -constraints {testchannel testthread} \ -result {{can not find reflected channel named "rc*"}} # --- === *** ########################### @@ -3835,15 +3556,12 @@ test iocmd.tf-31.8 {chan postevent, bad input} -match glob -body { test iocmd.tf-32.0 {origin thread of moved channel gone} -match glob -body { #puts <<$tcltest::mainThread>>main - set tida [thread::create -preserved];#puts <<$tida>> - thread::send $tida {load {} Tcltest} - - set tidb [thread::create -preserved];#puts <<$tidb>> - thread::send $tidb {load {} Tcltest} + set tida [testthread create];#puts <<$tida>> + set tidb [testthread create];#puts <<$tidb>> # Set up channel in thread - thread::send $tida $helperscript - set chan [thread::send $tida { + testthread send $tida $helperscript + set chan [testthread send $tida { proc foo {args} {oninit seek; onfinal; track; return} set chan [chan create {r w} foo] fconfigure $chan -buffering none @@ -3851,307 +3569,82 @@ test iocmd.tf-32.0 {origin thread of moved channel gone} -match glob -body { }] # Move channel to 2nd thread. - thread::send $tida [list testchannel cut $chan] - thread::send $tidb [list testchannel splice $chan] + testthread send $tida [list testchannel cut $chan] + testthread send $tidb [list testchannel splice $chan] # Kill origin thread, then access channel from 2nd thread. - thread::release $tida + testthread send -async $tida {testthread exit} + after 100 set res {} - lappend res [catch {thread::send $tidb [list puts $chan shoo]} msg] $msg + lappend res [catch {testthread send $tidb [list puts $chan shoo]} msg] $msg - lappend res [catch {thread::send $tidb [list tell $chan]} msg] $msg - lappend res [catch {thread::send $tidb [list seek $chan 1]} msg] $msg - lappend res [catch {thread::send $tidb [list gets $chan]} msg] $msg - lappend res [catch {thread::send $tidb [list close $chan]} msg] $msg - thread::release $tidb + lappend res [catch {testthread send $tidb [list tell $chan]} msg] $msg + lappend res [catch {testthread send $tidb [list seek $chan 1]} msg] $msg + lappend res [catch {testthread send $tidb [list gets $chan]} msg] $msg + lappend res [catch {testthread send $tidb [list close $chan]} msg] $msg + tcltest::threadReap set res -} -constraints {testchannel thread} \ +} -constraints {testchannel testthread} \ -result {1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} - -# The test iocmd.tf-32.1 unavoidably exhibits a memory leak. We are testing -# the ability of the reflected channel system to react to the situation where -# the thread in which the driver routines runs exits during driver operations. -# In this case, thread exit handlers signal back to the owner thread so that the -# channel operation does not hang. There's no way to test this without actually -# exiting a thread in mid-operation, and that action is unavoidably leaky (which -# is why [thread::exit] is advised against). -# -# Use constraints to skip this test while valgrinding so this expected leak -# doesn't prevent a finding of "leak-free". -# test iocmd.tf-32.1 {origin thread of moved channel destroyed during access} -match glob -body { #puts <<$tcltest::mainThread>>main - set tida [thread::create -preserved];#puts <<$tida>> - thread::send $tida {load {} Tcltest} - set tidb [thread::create -preserved];#puts <<$tidb>> - thread::send $tidb {load {} Tcltest} + set tida [testthread create];#puts <<$tida>> + set tidb [testthread create];#puts <<$tidb>> # Set up channel in thread - thread::send $tida $helperscript - set chan [thread::send $tida { + set chan [testthread send $tida $helperscript] + set chan [testthread send $tida { proc foo {args} { oninit; onfinal; track; # destroy thread during channel access - thread::exit - } + testthread exit + return} set chan [chan create {r w} foo] fconfigure $chan -buffering none set chan }] # Move channel to 2nd thread. - thread::send $tida [list testchannel cut $chan] - thread::send $tidb [list testchannel splice $chan] + testthread send $tida [list testchannel cut $chan] + testthread send $tidb [list testchannel splice $chan] # Run access from thread B, wait for response from A (A is not # using event loop at this point, so the event pile up in the # queue. - thread::send $tidb [list set chan $chan] - thread::send $tidb [list set mid [thread::id]] - thread::send -async $tidb { + testthread send $tidb [list set chan $chan] + testthread send $tidb [list set mid $tcltest::mainThread] + testthread send -async $tidb { # wait a bit, give the main thread the time to start its event # loop to wait for the response from B after 2000 catch { puts $chan shoo } res - thread::send -async $mid [list set ::res $res] + testthread send -async $mid [list set ::res $res] } vwait ::res - catch {thread::release $tida} - thread::release $tidb + tcltest::threadReap set res -} -constraints {testchannel thread notValgrind} \ +} -constraints {testchannel testthread} \ -result {Owner lost} -# Tests of readFile - -set BIN_DATA "\u0000\u0001\u0002\u0003\u0004\u001a\u001b\u000d\u000a\u0000" - -test iocmd.readFile-1.1 "readFile procedure: syntax" -body { - readFile -} -returnCodes error -result {wrong # args: should be "readFile filename ?mode?"} -test iocmd.readFile-1.2 "readFile procedure: syntax" -body { - readFile a b c -} -returnCodes error -result {wrong # args: should be "readFile filename ?mode?"} -test iocmd.readFile-1.3 "readFile procedure: syntax" -body { - readFile gorp gorp2 -} -returnCodes error -result {bad mode "gorp2": must be binary or text} - -test iocmd.readFile-2.1 "readFile procedure: behaviour" -setup { - set f [makeFile "File\nContents" readFile21.txt] -} -body { - readFile $f -} -cleanup { - removeFile $f -} -result "File\nContents\n" -test iocmd.readFile-2.2 "readFile procedure: behaviour" -setup { - set f [makeFile "File\nContents" readFile22.txt] -} -body { - readFile $f text -} -cleanup { - removeFile $f -} -result "File\nContents\n" -test iocmd.readFile-2.3 "readFile procedure: behaviour" -setup { - set f [makeFile "" readFile23.bindata] - apply {filename { - global BIN_DATA - set ff [open $filename wb] - puts -nonewline $ff $BIN_DATA - close $ff - }} $f -} -body { - list [binary scan [readFile $f binary] c* x] $x -} -cleanup { - removeFile $f -} -result {1 {0 1 2 3 4 26 27 13 10 0}} -# Need to set up ahead of the test -set f [makeFile "" readFile24.txt] -removeFile $f -test iocmd.readFile-2.4 "readFile procedure: behaviour" -body { - readFile $f -} -returnCodes error -result "couldn't open \"$f\": no such file or directory" - -# Tests of writeFile - -test iocmd.writeFile-1.1 "writeFile procedure: syntax" -body { - writeFile -} -returnCodes error -result {wrong # args: should be "writeFile filename ?mode? data"} -test iocmd.writeFile-1.2 "writeFile procedure: syntax" -body { - writeFile a b c d -} -returnCodes error -result {wrong # args: should be "writeFile filename ?mode? data"} -test iocmd.writeFile-1.3 "writeFile procedure: syntax" -body { - writeFile gorp gorp2 gorp3 -} -returnCodes error -result {bad mode "gorp2": must be binary or text} - -test iocmd.writeFile-2.1 "readFile procedure: behaviour" -setup { - set f [makeFile "" writeFile21.txt] - removeFile $f -} -body { - list [writeFile $f "File\nContents\n"] [apply {filename { - set f [open $filename] - set text [read $f] - close $f - return $text - }} $f] -} -cleanup { - file delete $f -} -result [list {} "File\nContents\n"] -test iocmd.writeFile-2.2 "readFile procedure: behaviour" -setup { - set f [makeFile "" writeFile22.txt] - removeFile $f -} -body { - writeFile $f text "File\nContents\n" - apply {filename { - set f [open $filename] - set text [read $f] - close $f - return $text - }} $f -} -cleanup { - file delete $f -} -result "File\nContents\n" -test iocmd.writeFile-2.3 "readFile procedure: behaviour" -setup { - set f [makeFile "" writeFile23.txt] - removeFile $f -} -body { - writeFile $f binary $BIN_DATA - apply {filename { - set f [open $filename rb] - set bytes [read $f] - close $f - binary scan $bytes c* x - return $x - }} $f -} -cleanup { - file delete $f -} -result {0 1 2 3 4 26 27 13 10 0} - -# Tests of foreachLine - -test iocmd.foreachLine-1.1 "foreachLine procedure: syntax" -returnCodes error -body { - foreachLine -} -result {wrong # args: should be "foreachLine varName filename body"} -test iocmd.foreachLine-1.2 "foreachLine procedure: syntax" -returnCodes error -body { - foreachLine a b c d -} -result {wrong # args: should be "foreachLine varName filename body"} -test iocmd.foreachLine-1.3 "foreachLine procedure: basic errors" -setup { - set f [makeFile "" foreachLine13.txt] -} -body { - apply {filename { - array set b {1 1} - foreachLine b $filename {} - }} $f -} -cleanup { - removeFile $f -} -returnCodes error -result {can't set "line": variable is array} -set f [makeFile "" foreachLine14.txt] -removeFile $f -test iocmd.foreachLine-1.4 "foreachLine procedure: basic errors" -body { - apply {filename { - foreachLine var $filename {} - }} $f -} -returnCodes error -result "couldn't open \"$f\": no such file or directory" - -test iocmd.foreachLine-2.1 "foreachLine procedure: behaviour" -setup { - set f [makeFile "a\nb\nc" foreachLine21.txt] -} -body { - apply {filename { - set lines {} - foreachLine var $filename { - lappend lines $var - } - return $lines - }} $f -} -cleanup { - removeFile $f -} -result {a b c} -test iocmd.foreachLine-2.2 "foreachLine procedure: behaviour" -setup { - set f [makeFile "a\nbb\nc\ndd" foreachLine22.txt] -} -body { - apply {filename { - set lines {} - foreachLine var $filename { - if {[string length $var] == 1} continue - lappend lines $var - } - return $lines - }} $f -} -cleanup { - removeFile $f -} -result {bb dd} -test iocmd.foreachLine-2.3 "foreachLine procedure: behaviour" -setup { - set f [makeFile "a\nbb\nccc\ndd\ne" foreachLine23.txt] -} -body { - apply {filename { - set lines {} - foreachLine var $filename { - if {[string length $var] > 2} break - lappend lines $var - } - return $lines - }} $f -} -cleanup { - removeFile $f -} -result {a bb} -test iocmd.foreachLine-2.4 "foreachLine procedure: behaviour" -setup { - set f [makeFile "a\nbb\nccc\ndd\ne" foreachLine24.txt] -} -body { - apply {filename { - set lines {} - foreachLine var $filename { - if {[string length $var] > 2} { - return $var - } - lappend lines $var - } - return $lines - }} $f -} -cleanup { - removeFile $f -} -result {ccc} -test iocmd.foreachLine-2.5 "foreachLine procedure: behaviour" -setup { - set f [makeFile "a\nbb\nccc\ndd\ne" foreachLine25.txt] -} -body { - apply {filename { - set lines {} - foreachLine var $filename { - if {[string length $var] > 2} { - error "line too long" - } - lappend lines $var - } - return $lines - }} $f -} -cleanup { - removeFile $f -} -returnCodes error -result {line too long} - # ### ### ### ######### ######### ######### # ### ### ### ######### ######### ######### rename track {} # cleanup - - -# Eliminate valgrind "still reachable" reports on outstanding "Detached" -# structures in the detached list which stem from PipeClose2Proc not waiting -# around for background processes to complete, meaning that previous calls to -# Tcl_ReapDetachedProcs might not have had a chance to reap all processes. -after 10 -exec [info nameofexecutable] << {} - - foreach file [list test1 test2 test3 test4] { removeFile $file } # delay long enough for background processes to finish after 500 -removeFile test5 +foreach file [list test5] { + removeFile $file +} cleanupTests return |