diff options
Diffstat (limited to 'tests')
124 files changed, 3066 insertions, 3101 deletions
diff --git a/tests/all.tcl b/tests/all.tcl index 05d3024..5872d54 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -15,5 +15,5 @@ package require Tcl 8.5 package require tcltest 2.2 namespace import tcltest::* configure {*}$argv -testdir [file dir [info script]] -runAllTests -proc exit args {} +runAllTests +proc exit {args} {} diff --git a/tests/append.test b/tests/append.test index 69c6381..53023fa 100644 --- a/tests/append.test +++ b/tests/append.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -92,7 +92,7 @@ test append-4.7 {lappend command} { test append-4.8 {lappend command} { set x "\\\{" lappend x abc -} "\\{ abc" +} "\\\{ abc" test append-4.9 {lappend command} -returnCodes error -body { set x " \{" lappend x abc diff --git a/tests/appendComp.test b/tests/appendComp.test index f85c3ba..a9d10cb 100644 --- a/tests/appendComp.test +++ b/tests/appendComp.test @@ -11,11 +11,11 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } -catch {unset x} +unset -nocomplain x test appendComp-1.1 {append command} -setup { unset -nocomplain x @@ -132,7 +132,7 @@ test appendComp-4.8 {lappend command} { lappend x abc } foo -} "\\{ abc" +} "\\\{ abc" test appendComp-4.9 {lappend command} -returnCodes error -body { proc foo {} { set x " \{" @@ -439,7 +439,7 @@ test appendComp-9.3 {bug 3057639, append direct eval, read trace on non-existing unset -nocomplain ::env(__DUMMY__) } -result {0 {new value}} -catch {unset i x result y} +unset -nocomplain i x result y catch {rename foo ""} catch {rename bar ""} catch {rename check ""} diff --git a/tests/apply.test b/tests/apply.test index ba19b81..9329359 100644 --- a/tests/apply.test +++ b/tests/apply.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.2 namespace import -force ::tcltest::* } @@ -21,7 +21,7 @@ if {[info commands ::apply] eq {}} { return } -testConstraint memory [llength [info commands memory]] +tcltest::testConstraint memory [llength [info commands memory]] # Tests for wrong number of arguments @@ -163,7 +163,7 @@ test apply-6.3 {info level} { # Tests for correct namespace scope namespace eval ::testApply { - proc testApply args {return testApply} + proc testApply {args} {return testApply} } test apply-7.1 {namespace access} { diff --git a/tests/assemble.test b/tests/assemble.test index 7d4e5d1..b49992e 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -31,8 +31,8 @@ proc fillTables {} { return $s } -testConstraint memory [llength [info commands memory]] -if {[testConstraint memory]} { +tcltest::testConstraint memory [llength [info commands memory]] +if {[tcltest::testConstraint memory]} { proc getbytes {} { set lines [split [memory info] \n] return [lindex $lines 3 3] @@ -1882,7 +1882,7 @@ test assemble-17.15 {multiple passes of code resizing} { for {set i 0} {$i < 15} {incr i} { append body "label b" $i \ "; push b; concat 2; nop; nop; jump a" \ - [expr {$i+1}] \n + [expr {$i + 1}] \n } append body {label c; push -; concat 2; nop; nop; nop; jump d} \n append body {label b15; push b; concat 2; nop; nop; jump c} \n @@ -1893,8 +1893,8 @@ test assemble-17.15 {multiple passes of code resizing} { x } -cleanup { - catch {unset body} - catch {rename x {}} + unset -nocomplain body + catch {rename x ""} } -result -abababababababababababababababab- } diff --git a/tests/async.test b/tests/async.test index cb67cc2..03cacd3 100644 --- a/tests/async.test +++ b/tests/async.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } diff --git a/tests/autoMkindex.test b/tests/autoMkindex.test index 8f29131..d02a134 100644 --- a/tests/autoMkindex.test +++ b/tests/autoMkindex.test @@ -14,7 +14,7 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } -makeFile {# Test file for: +::tcltest::makeFile {# Test file for: # auto_mkindex # # This file provides example cases for testing the Tcl autoloading facility. @@ -324,7 +324,7 @@ if {[info exists saveCommands]} { } rename AutoMkindexTestReset "" -removeFile autoMkindex.tcl +::tcltest::removeFile autoMkindex.tcl if {[file exists tclIndex]} { file delete -force tclIndex } diff --git a/tests/binary.test b/tests/binary.test index ccd0f29..c342ecc 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -2678,7 +2678,7 @@ test binary-74.4 {binary encode uuencode} -body { } -result [string repeat 86)C 20] test binary-74.5 {binary encode uuencode} -body { binary encode uuencode \0\1\2\3\4\0\1\2\3 -} -result "``\$\"`P0``0(#" +} -result "``\$\"`P0``0\(#" test binary-74.6 {binary encode uuencode} -body { binary encode uuencode \0 } -result {````} @@ -2708,10 +2708,10 @@ test binary-75.3 {binary decode uuencode} -body { binary decode uuencode {} } -result {} test binary-75.4 {binary decode uuencode} -body { - binary decode uuencode [string repeat "86)C" 20] + binary decode uuencode [string repeat "86\)C" 20] } -result [string repeat abc 20] test binary-75.5 {binary decode uuencode} -body { - binary decode uuencode "``\$\"`P0``0(#" + binary decode uuencode "``\$\"`P0``0\(#" } -result "\0\1\2\3\4\0\1\2\3" test binary-75.6 {binary decode uuencode} -body { string length [binary decode uuencode {`}] @@ -2734,7 +2734,7 @@ test binary-75.11 {binary decode uuencode} -body { binary decode uuencode $s } -result [string repeat abc 20] test binary-75.12 {binary decode uuencode} -body { - binary decode uuencode -strict "|86)C" + binary decode uuencode -strict "|86\)C" } -returnCodes error -match glob -result {invalid uuencode character "|" at position 0} test binary-75.13 {binary decode uuencode} -body { set s "[string repeat 86)C 10]|[string repeat 86)C 10]" @@ -2761,11 +2761,11 @@ test binary-75.23 {binary decode uuencode} -body { list [string length $r] $r } -result {3 abc} test binary-75.24 {binary decode uuencode} -body { - set s "04)\# " + set s "04\)\# " binary decode uuencode $s } -result ABC test binary-75.25 {binary decode uuencode} -body { - set s "04)\#z" + set s "04\)\#z" binary decode uuencode $s } -returnCodes error -match glob -result {invalid uuencode character "z" at position 4} test binary-75.26 {binary decode uuencode} -body { diff --git a/tests/case.test b/tests/case.test index 6d63cea..6798bbb 100644 --- a/tests/case.test +++ b/tests/case.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } diff --git a/tests/chan.test b/tests/chan.test index d8390e2..85f0dff 100644 --- a/tests/chan.test +++ b/tests/chan.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -109,7 +109,7 @@ test chan-15.1 {chan command: truncate subcommand} -body { test chan-15.2 {chan command: truncate subcommand} -setup { set file [makeFile {} testTruncate] set f [open $file w+] - fconfigure $f -translation binary + chan configure $f -translation binary } -body { seek $f 0 puts -nonewline $f 12345 @@ -190,7 +190,7 @@ test chan-16.9 {chan command: pending input subcommand} -setup { } set ::server [socket -server chan-16.9-accept -myaddr 127.0.0.1 0] - set ::client [socket 127.0.0.1 [lindex [fconfigure $::server -sockname] 2]] + set ::client [socket 127.0.0.1 [lindex [chan configure $::server -sockname] 2]] set ::chan-16.9-data [list] set ::chan-16.9-done 0 } -body { @@ -245,8 +245,8 @@ test chan-17.2 {chan command: pipe subcommand} -body { test chan-17.3 {chan command: pipe subcommand} -body { set l [chan pipe] - foreach {pr pw} $l break - list [llength $l] [fconfigure $pr -blocking] [fconfigure $pw -blocking] + lassign $l pr pw + list [llength $l] [chan configure $pr -blocking] [chan configure $pw -blocking] } -result [list 2 1 1] -cleanup { close $pw close $pr @@ -254,7 +254,7 @@ test chan-17.3 {chan command: pipe subcommand} -body { test chan-17.4 {chan command: pipe subcommand} -body { set ::done 0 - foreach {::pr ::pw} [chan pipe] break + lassign [chan pipe] ::pr ::pw after 100 {puts $::pw foo;flush $::pw} fileevent $::pr readable {set ::done 1} after 500 {set ::done -1} @@ -267,7 +267,7 @@ test chan-17.4 {chan command: pipe subcommand} -body { close $::pr } -cleanupTests +::tcltest::cleanupTests return # Local Variables: diff --git a/tests/chanio.test b/tests/chanio.test index 665df50..025bb14 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -51,11 +51,11 @@ namespace eval ::tcl::test::io { set umaskValue 0 testConstraint umask [expr {![catch {set umaskValue [scan [exec /bin/sh -c umask] %o]}]}] - testConstraint makeFileInHome [expr {![file exists ~/_test_] && [file writable ~]}] + testConstraint makeFileInHome [expr {(![file exists ~/_test_]) && [file writable ~]}] # set up a long data file for some of the following tests - set path(longfile) [makeFile {} longfile] + set path(longfile) [tcltest::makeFile {} longfile] set f [open $path(longfile) w] chan configure $f -eofchar {} -translation lf for { set i 0 } { $i < 100 } { incr i} { @@ -65,9 +65,9 @@ namespace eval ::tcl::test::io { } chan close $f - set path(cat) [makeFile { + set path(cat) [tcltest::makeFile { set f stdin - if {$argv != ""} { + if {$argv ne ""} { set f [open [lindex $argv 0]] } chan configure $f -encoding binary -translation lf -blocking 0 -eofchar \x1a @@ -102,7 +102,7 @@ namespace eval ::tcl::test::io { test chan-io-1.5 {Tcl_WriteChars: CheckChannelErrors} {emptyTest} { # no test, need to cause an async error. } {} -set path(test1) [makeFile {} test1] +set path(test1) [tcltest::makeFile {} test1] test chan-io-1.6 {Tcl_WriteChars: WriteBytes} { set f [open $path(test1) w] chan configure $f -encoding binary @@ -117,7 +117,7 @@ test chan-io-1.7 {Tcl_WriteChars: WriteChars} { chan close $f contents $path(test1) } "a\x93\xe1\x00" -set path(test2) [makeFile {} test2] +set path(test2) [tcltest::makeFile {} test2] test chan-io-1.8 {Tcl_WriteChars: WriteChars} { # This test written for SF bug #506297. # @@ -129,7 +129,7 @@ test chan-io-1.8 {Tcl_WriteChars: WriteChars} { chan puts -nonewline $f [format %s%c [string repeat " " 4] 12399] chan close $f contents $path(test2) -} " \x1b\$B\$O\x1b(B" +} " \x1b\$B\$O\x1b\(B" test chan-io-1.9 {Tcl_WriteChars: WriteChars} { # When closing a channel with an encoding that appends escape bytes, check # for the case where the escape bytes overflow the current IO buffer. The @@ -1363,7 +1363,7 @@ test chan-io-12.4 {ReadChars: split-up char} -setup { test chan-io-12.5 {ReadChars: chan events on partial characters} -setup { variable x {} } -constraints {stdio openpipe fileevent} -body { - set path(test1) [makeFile { + set path(test1) [tcltest::makeFile { chan configure stdout -encoding binary -buffering none chan gets stdin; chan puts -nonewline "\xe7" chan gets stdin; chan puts -nonewline "\x89" @@ -1573,7 +1573,7 @@ test chan-io-14.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} -setup { } -cleanup { interp delete x } -result {line line none} -set path(test3) [makeFile {} test3] +set path(test3) [tcltest::makeFile {} test3] test chan-io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} -constraints {exec openpipe} -body { set f [open $path(test1) w] chan puts -nonewline $f { @@ -1667,7 +1667,7 @@ test chan-io-14.7 {Tcl_GetChannel: stdio name translation} -setup { } -cleanup { interp delete z } -result {{} {} {can not find channel named "stderr"}} -set path(script) [makeFile {} script] +set path(script) [tcltest::makeFile {} script] test chan-io-14.8 {reuse of stdio special channels} -setup { file delete $path(script) file delete $path(test1) @@ -1877,7 +1877,7 @@ test chan-io-20.3 {Tcl_CreateChannel: initial settings} -constraints {unix} -bod chan close $f } -result {{{} {}} {auto lf}} test chan-io-20.5 {Tcl_CreateChannel: install channel in empty slot} -setup { - set path(stdout) [makeFile {} stdout] + set path(stdout) [tcltest::makeFile {} stdout] } -constraints {stdio openpipe} -body { set f [open $path(script) w] chan puts -nonewline $f { @@ -2033,8 +2033,8 @@ test chan-io-27.5 {FlushChannel, implicit flush when buffer fills and on chan cl chan close $f lappend l [file size $path(test1)] } -result {0 60 72} -set path(pipe) [makeFile {} pipe] -set path(output) [makeFile {} output] +set path(pipe) [tcltest::makeFile {} pipe] +set path(output) [tcltest::makeFile {} output] test chan-io-27.6 {FlushChannel, async flushing, async chan close} -setup { file delete $path(pipe) file delete $path(output) @@ -2175,8 +2175,8 @@ test chan-io-28.5 {Tcl_Chan Close vs standard handles} -setup { lsort $l } -result {file1 file2} test chan-io-28.6 {Tcl_CloseEx (half-close) pipe} -setup { - set cat [makeFile { - fconfigure stdout -buffering line + set cat [tcltest::makeFile { + chan configure stdout -buffering line while {[gets stdin line] >= 0} {puts $line} puts DONE exit 0 @@ -2203,13 +2203,13 @@ test chan-io-28.6 {Tcl_CloseEx (half-close) pipe} -setup { removeFile cat.tcl } -result {Succeeded {Hey DONE}} test chan-io-28.7 {Tcl_CloseEx (half-close) socket} -setup { - set echo [makeFile { + set echo [tcltest::makeFile { proc accept {s args} {set ::sok $s} set s [socket -server accept 0] - puts [lindex [fconfigure $s -sockname] 2] + puts [lindex [chan configure $s -sockname] 2] flush stdout vwait ::sok - fconfigure $sok -buffering line + chan configure $sok -buffering line while {[gets $sok line]>=0} {puts $sok $line} puts $sok DONE exit 0 @@ -3038,7 +3038,7 @@ test chan-io-30.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} -setup { string length [chan read $f] } -cleanup { chan close $f -} -result [expr 700*15+1] +} -result [expr {(700 * 15) + 1}] test chan-io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} -setup { file delete $path(test1) } -body { @@ -3055,7 +3055,7 @@ test chan-io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} -setup { string length [chan read $f] } -cleanup { chan close $f -} -result [expr 700*15+1] +} -result [expr {(700 * 15) + 1}] test chan-io-30.15 {Tcl_Write mixed, Tcl_Read auto} -setup { file delete $path(test1) } -body { @@ -3897,7 +3897,7 @@ test chan-io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} -setup { } chan close $f string length $c -} -result [expr 700*15+1] +} -result [expr {(700 * 15) + 1}] test chan-io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} -setup { file delete $path(test1) set c "" @@ -3917,7 +3917,7 @@ test chan-io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} -setup { } chan close $f string length $c -} -result [expr 700*15+1] +} -result [expr {(700 * 15) + 1}] # Test Tcl_Read and buffering. @@ -4178,7 +4178,7 @@ test chan-io-33.7 {Tcl_Gets and bad variable} -setup { chan puts $f "Line 1" chan puts $f "Line 2" chan close $f - catch {unset x} + unset -nocomplain x set f [open $path(test3) r] } -body { set x 24 @@ -4355,7 +4355,7 @@ test chan-io-34.9 {Tcl_Seek, testing buffered input flushing} -setup { } -cleanup { chan close $f } -result {a d a l Y {} b} -set path(test3) [makeFile {} test3] +set path(test3) [tcltest::makeFile {} test3] test chan-io-34.10 {Tcl_Seek testing flushing of buffered input} { set f [open $path(test3) w] chan configure $f -translation lf @@ -5335,7 +5335,7 @@ test chan-io-40.3 {POSIX open access modes: CREAT} -setup { chan close [open $path(test3) {WRONLY CREAT}] file stat $path(test3) stats format "0%o" [expr $stats(mode)&0o777] -} -result [format %04o [expr {0o666 & ~ $umaskValue}]] +} -result [format %04o [expr {0o666 & ( ~ $umaskValue)}]] test chan-io-40.4 {POSIX open access modes: CREAT} -setup { file delete $path(test3) } -body { @@ -5435,7 +5435,7 @@ test chan-io-40.12 {POSIX open access modes: WRONLY} -match regexp -body { open $path(test3) WRONLY } -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory} test chan-io-40.13 {POSIX open access modes: WRONLY} -body { - makeFile xyzzy test3 + tcltest::makeFile xyzzy test3 set f [open $path(test3) WRONLY] chan configure $f -eofchar {} chan puts -nonewline $f "ab" @@ -5449,7 +5449,7 @@ test chan-io-40.14 {POSIX open access modes: RDWR} -match regexp -body { open $path(test3) RDWR } -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory} test chan-io-40.15 {POSIX open access modes: RDWR} { - makeFile xyzzy test3 + tcltest::makeFile xyzzy test3 set f [open $path(test3) RDWR] chan puts -nonewline $f "ab" chan seek $f 0 current @@ -5458,7 +5458,7 @@ test chan-io-40.15 {POSIX open access modes: RDWR} { lappend x [viewFile test3] } {zzy abzzy} test chan-io-40.16 {tilde substitution in open} -constraints makeFileInHome -setup { - makeFile {Some text} _test_ ~ + tcltest::makeFile {Some text} _test_ ~ } -body { file exists [file join $::env(HOME) _test_] } -cleanup { @@ -5493,7 +5493,7 @@ test chan-io-41.5 {Tcl_FileeventCmd: errors} -constraints fileevent -body { # Test chan event on a file # -set path(foo) [makeFile {} foo] +set path(foo) [tcltest::makeFile {} foo] set f [open $path(foo) w+] test chan-io-42.1 {Tcl_FileeventCmd: creating, deleting, querying} {fileevent} { @@ -5645,7 +5645,7 @@ test chan-io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs openpi } {initial foo eof} chan close $f -makeFile "foo bar" foo +tcltest::makeFile "foo bar" foo test chan-io-45.1 {DeleteFileEvent, cleanup on chan close} {fileevent} { set f [open $path(foo) r] @@ -5849,7 +5849,7 @@ test chan-io-47.6 {file events on shared files, deleting file events} -setup { chan close $f } -result {{script 1} {}} -set path(bar) [makeFile {} bar] +set path(bar) [tcltest::makeFile {} bar] test chan-io-48.1 {testing readability conditions} {fileevent} { set f [open $path(bar) w] @@ -5898,7 +5898,7 @@ test chan-io-48.2 {testing readability conditions} {nonBlockFiles fileevent} { vwait [namespace which -variable x] list $x $l } {done {called called called called called called called}} -set path(my_script) [makeFile {} my_script] +set path(my_script) [tcltest::makeFile {} my_script] test chan-io-48.3 {testing readability conditions} -setup { set l "" } -constraints {stdio unix nonBlockFiles openpipe fileevent} -body { @@ -6714,9 +6714,9 @@ test chan-io-52.8 {TclCopyChannel} -setup { list $s0 [file size $path(test1)] } -result {40 40} # Empty files, to register them with the test facility -set path(kyrillic.txt) [makeFile {} kyrillic.txt] -set path(utf8-fcopy.txt) [makeFile {} utf8-fcopy.txt] -set path(utf8-rp.txt) [makeFile {} utf8-rp.txt] +set path(kyrillic.txt) [tcltest::makeFile {} kyrillic.txt] +set path(utf8-fcopy.txt) [tcltest::makeFile {} utf8-fcopy.txt] +set path(utf8-rp.txt) [tcltest::makeFile {} utf8-rp.txt] # Create kyrillic file, use lf translation to avoid os eol issues set out [open $path(kyrillic.txt) w] chan configure $out -encoding koi8-r -translation lf @@ -6871,10 +6871,10 @@ test chan-io-53.4 {CopyData: background write overflow} -setup { vwait [namespace which -variable x] return $x } -cleanup { - set big {} + set big "" chan close $f1 } -result done -set result {} +set result "" proc FcopyTestAccept {sock args} { after 1000 "chan close $sock" } @@ -6891,7 +6891,7 @@ test chan-io-53.5 {CopyData: error during chan copy} {socket fcopy} { set listen [socket -server [namespace code FcopyTestAccept] -myaddr 127.0.0.1 0] set in [open $thisScript] ;# 126 K set out [socket 127.0.0.1 [lindex [chan configure $listen -sockname] 2]] - catch {unset fcopyTestDone} + unset -nocomplain fcopyTestDone chan close $listen ;# This means the socket open never really succeeds chan copy $in $out -command [namespace code FcopyTestDone] variable fcopyTestDone @@ -6906,7 +6906,7 @@ test chan-io-53.6 {CopyData: error during chan copy} -setup { variable fcopyTestDone file delete $path(pipe) file delete $path(test1) - catch {unset fcopyTestDone} + unset -nocomplain fcopyTestDone } -constraints {stdio openpipe fcopy} -body { set f1 [open $path(pipe) w] chan puts $f1 "exit 1" @@ -6940,7 +6940,7 @@ proc doFcopy {in out {bytes 0} {error {}}} { test chan-io-53.7 {CopyData: Flooding chan copy from pipe} -setup { variable fcopyTestDone file delete $path(pipe) - catch {unset fcopyTestDone} + unset -nocomplain fcopyTestDone } -constraints {stdio openpipe fcopy} -body { set fcopyTestCount 0 set f1 [open $path(pipe) w] @@ -6986,11 +6986,11 @@ test chan-io-53.8 {CopyData: async callback and error handling, Bug 1932639} -se return } # Files we use for our channels - set foo [makeFile ashgdfashdgfasdhgfasdhgf foo] - set bar [makeFile {} bar] + set foo [tcltest::makeFile ashgdfashdgfasdhgfasdhgf foo] + set bar [tcltest::makeFile {} bar] # Channels to copy between - set f [open $foo r] ; fconfigure $f -translation binary - set g [open $bar w] ; fconfigure $g -translation binary -buffering none + set f [open $foo r] ; chan configure $f -translation binary + set g [open $bar w] ; chan configure $g -translation binary -buffering none } -constraints {stdio openpipe fcopy} -body { # Record input size, so that result is always defined lappend ::RES [file size $bar] @@ -7012,9 +7012,8 @@ test chan-io-53.8 {CopyData: async callback and error handling, Bug 1932639} -se } -cleanup { chan close $f chan close $g - catch {unset ::RES} - catch {unset ::forever} - rename ::bgerror {} + unset -nocomplain ::RES ::forever + rename ::bgerror "" removeFile foo removeFile bar } -result {0 sync/OK 0 {CMD 2} {bgerror/OK !STOP}} @@ -7026,8 +7025,8 @@ test chan-io-53.8a {CopyData: async callback and error handling, Bug 1932639, at return } # Files we use for our channels - set foo [makeFile ashgdfashdgfasdhgfasdhgf foo] - set bar [makeFile {} bar] + set foo [tcltest::makeFile ashgdfashdgfasdhgfasdhgf foo] + set bar [tcltest::makeFile {} bar] # Channels to copy between set f [open $foo r] ; chan configure $f -translation binary set g [open $bar w] ; chan configure $g -translation binary -buffering none @@ -7052,14 +7051,13 @@ test chan-io-53.8a {CopyData: async callback and error handling, Bug 1932639, at } -cleanup { chan close $f chan close $g - catch {unset ::RES} - catch {unset ::forever} + unset -nocomplain ::RES ::forever removeFile foo removeFile bar } -result {1 sync/OK {CMD 0}} test chan-io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup { - set out [makeFile {} out] - set err [makeFile {} err] + set out [tcltest::makeFile {} out] + set err [tcltest::makeFile {} err] set pipe [open "|[list [info nameofexecutable] 2> $err]" r+] chan configure $pipe -translation binary -buffering line chan puts $pipe { @@ -7107,10 +7105,10 @@ test chan-io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup { catch {close $out} catch {removeFile out} catch {removeFile err} - catch {unset ::forever} + unset -nocomplain ::forever } -result OK test chan-io-53.10 {Bug 1350564, multi-directional fcopy} -setup { - set err [makeFile {} err] + set err [tcltest::makeFile {} err] set pipe [open "|[list [info nameofexecutable] 2> $err]" r+] chan configure $pipe -translation binary -buffering line chan puts $pipe { @@ -7133,7 +7131,7 @@ test chan-io-53.10 {Bug 1350564, multi-directional fcopy} -setup { lappend l $sok if {[llength $l] == 2} { chan close $srv - foreach {a b} $l break + lassign $l a b chan copy $a $b -command [list geof $a] chan copy $b $a -command [list geof $b] chan puts stderr 2COPY @@ -7178,7 +7176,7 @@ test chan-io-53.10 {Bug 1350564, multi-directional fcopy} -setup { after 1000 ;# Give Windows time to kill the process } removeFile err - catch {unset ::forever} + unset -nocomplain ::forever } -result {AB BA} test chan-io-54.1 {Recursive channel events} {socket fileevent} { @@ -7285,7 +7283,7 @@ test chan-io-54.2 {Testing for busy-wait in recursive channel events} -setup { if {$accept ne {}} {chan close $accept} } -result 1 -set path(fooBar) [makeFile {} fooBar] +set path(fooBar) [tcltest::makeFile {} fooBar] test chan-io-55.1 {ChannelEventScriptInvoker: deletion} -constraints { fileevent @@ -7452,7 +7450,7 @@ test chan-io-60.1 {writing illegal utf sequences} {openpipe fileevent} { } {1 {gets {} catch {error writing "stdout": invalid argument}}} test chan-io-61.1 {Reset eof state after changing the eof char} -setup { - set datafile [makeFile {} eofchar] + set datafile [tcltest::makeFile {} eofchar] set f [open $datafile w] chan configure $f -translation binary chan puts -nonewline $f [string repeat "Ho hum\n" 11] @@ -7483,7 +7481,7 @@ test chan-io-61.1 {Reset eof state after changing the eof char} -setup { # used for that here. test chan-io-70.0 {Cutting & Splicing channels} -setup { - set f [makeFile {... dummy ...} cutsplice] + set f [tcltest::makeFile {... dummy ...} cutsplice] set res {} } -constraints {testchannel} -body { set c [open $f r] @@ -7498,7 +7496,7 @@ test chan-io-70.0 {Cutting & Splicing channels} -setup { } -result {0 1 0} test chan-io-70.1 {Transfer channel} -setup { - set f [makeFile {... dummy ...} cutsplice] + set f [tcltest::makeFile {... dummy ...} cutsplice] set res {} } -constraints {testchannel thread} -body { set c [open $f r] @@ -7683,7 +7681,7 @@ foreach {n msg expected} { f3 {-code boss -code 0 -level X -f ba} {-code 1 -level 0 -f ba} } { test chan-io-71.$n {Tcl_SetChannelError} -setup { - set f [makeFile {... dummy ...} cutsplice] + set f [tcltest::makeFile {... dummy ...} cutsplice] } -constraints {testchannel} -body { set c [open $f r] testchannel setchannelerror $c [lrange $msg 0 end] @@ -7692,7 +7690,7 @@ foreach {n msg expected} { removeFile cutsplice } -result [lrange $expected 0 end] test chan-io-72.$n {Tcl_SetChannelErrorInterp} -setup { - set f [makeFile {... dummy ...} cutsplice] + set f [tcltest::makeFile {... dummy ...} cutsplice] } -constraints {testchannel} -body { set c [open $f r] testchannel setchannelerrorinterp $c [lrange $msg 0 end] @@ -7712,8 +7710,8 @@ test chan-io-73.1 {channel Tcl_Obj SetChannelFromAny} -body { # cleanup foreach file [list fooBar longfile script output test1 pipe my_script \ test2 test3 cat kyrillic.txt utf8-fcopy.txt utf8-rp.txt] { - removeFile $file + tcltest::removeFile $file } -cleanupTests +tcltest::cleanupTests } namespace delete ::tcl::test::io diff --git a/tests/clock.test b/tests/clock.test index 0202fc7..0d7d23e 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -238,7 +238,6 @@ namespace eval ::testClock { DaylightStart \x00\x00\x03\x00\x02\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00]] } - proc ::testClock::registry { cmd path key } { variable reg if { $cmd ne {get} } { @@ -21058,7 +21057,6 @@ test clock-10.8 {parse ccyyddd} { clock scan {2001 365} -format {%Y %j} -locale en_US_roman -gmt 1 } 1009756800 - test clock-10.9 {seconds take precedence over ccyyddd} { list [clock scan {0 2000001} -format {%s %Y%j} -gmt true] \ [clock scan {2000001 0} -format {%Y%j %s} -gmt true] @@ -35850,7 +35848,6 @@ test clock-35.3 {clock seconds tests} { expr "$end > $start" } {1} - test clock-36.1 {clock scan next monthname} { clock format [clock scan "next june" -base [clock scan "june 1, 2000"]] \ -format %m.%Y @@ -35925,7 +35922,6 @@ test clock-38.2 {make sure TZ is not cached after unset} \ } \ -result 1 - test clock-39.1 {regression - synonym timezones} { clock format 0 -format {%H:%M:%S} -timezone :US/Eastern } {19:00:00} @@ -36704,12 +36700,12 @@ test clock-58.1 {clock l10n - Japanese localisation} {*}{ -setup { proc backslashify { string } { - set retval {} - foreach char [split $string {}] { + set retval "" + foreach char [split $string ""] { scan $char %c ccode - if { $ccode >= 0x0020 && $ccode < 0x007f - && $char ne "\{" && $char ne "\}" && $char ne "\[" - && $char ne "\]" && $char ne "\\" && $char ne "\$" } { + if { ($ccode >= 0x0020) && + ($ccode < 0x007f) && + ($char ni "\{ \} \[ \] \\ \$") } { append retval $char } else { append retval \\u [format %04x $ccode] @@ -36860,10 +36856,10 @@ test clock-61.2 {overflow of a wide integer on output} {*}{ } test clock-61.3 {near-miss overflow of a wide integer on output} { clock format 0x7fffffffffffffff -format %s -gmt true -} [expr 0x7fffffffffffffff] +} [expr {0x7fffffffffffffff}] test clock-61.4 {near-miss overflow of a wide integer on output} { clock format -0x8000000000000000 -format %s -gmt true -} [expr -0x8000000000000000] +} [expr {-0x8000000000000000}] test clock-62.1 {Bug 1902423} {*}{ -setup {::tcl::clock::ClearCaches} diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 3051bfb..0782465 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -22,9 +22,9 @@ testConstraint testchmod [llength [info commands testchmod]] testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testvolumetype [llength [info commands testvolumetype]] testConstraint linkDirectory [expr { - ![testConstraint win] || - ([string index $tcl_platform(osVersion) 0] >= 5 - && [lindex [file system [temporaryDirectory]] 1] eq "NTFS") + (![testConstraint win]) || + (([string index $tcl_platform(osVersion) 0] >= 5) && + ([lindex [file system [tcltest::temporaryDirectory]] 1] eq "NTFS")) }] global env @@ -36,15 +36,15 @@ proc waitForEvenSecondForFAT {} { # data in its timestamps for even per-second-accurate timings. :^( # This procedure based on work by Helmut Giese if { - [testConstraint win] && - [lindex [file system [temporaryDirectory]] 1] ne "NTFS" - } then { + [tcltest::testConstraint win] && + ([lindex [file system [tcltest::temporaryDirectory]] 1] ne "NTFS") + } { # Assume non-NTFS means FAT{12,16,32} and hence in need of special # help... set start [clock seconds] while {1} { set now [clock seconds] - if {$now!=$start && !($now & 1)} { + if {($now != $start) && (!($now & 1))} { break } after 50 @@ -80,7 +80,7 @@ test cmdAH-1.5 {Bug 3595576} { test cmdAH-2.1 {Tcl_CdObjCmd} -returnCodes error -body { cd foo bar } -result {wrong # args: should be "cd ?dirName?"} -set foodir [file join [temporaryDirectory] foo] +set foodir [file join [::tcltest::temporaryDirectory] foo] test cmdAH-2.2 {Tcl_CdObjCmd} -setup { file delete -force $foodir set oldpwd [pwd] @@ -649,10 +649,10 @@ test cmdAH-10.34 {Tcl_FileObjCmd: rootname} testsetplatform { file rootname a\\b.c\\ } a\\b.c\\ set num 35 -foreach outer { {} a .a a. a.a } { - foreach inner { {} a .a a. a.a } { +foreach outer { "" a .a a. a.a } { + foreach inner { "" a .a a. a.a } { set thing [format %s/%s $outer $inner] - ;test cmdAH-10.$num {Tcl_FileObjCmd: rootname and extension options} testsetplatform " + test cmdAH-10.$num {Tcl_FileObjCmd: rootname and extension options} testsetplatform " testsetplatform unix [list format %s%s [file rootname $thing] [file ext $thing]] " $thing @@ -817,8 +817,8 @@ test cmdAH-15.1 {Tcl_FileObjCmd} -constraints testsetplatform -body { catch {testsetplatform $platform} # readable -set gorpfile [makeFile abcde gorp.file] -set dirfile [makeDirectory dir.file] +set gorpfile [tcltest::makeFile abcde gorp.file] +set dirfile [tcltest::makeDirectory dir.file] test cmdAH-16.1 {Tcl_FileObjCmd: readable} { -returnCodes error -body {file readable a b} @@ -857,10 +857,10 @@ test cmdAH-17.3 {Tcl_FileObjCmd: writable} { } # executable -removeFile $gorpfile -removeDirectory $dirfile -set dirfile [makeDirectory dir.file] -set gorpfile [makeFile abcde gorp.file] +tcltest::removeFile $gorpfile +tcltest::removeDirectory $dirfile +set dirfile [tcltest::makeDirectory dir.file] +set gorpfile [tcltest::makeFile abcde gorp.file] test cmdAH-18.1 {Tcl_FileObjCmd: executable} -returnCodes error -body { file executable a b } -result {wrong # args: should be "file executable name"} @@ -894,10 +894,10 @@ test cmdAH-18.6 {Tcl_FileObjCmd: executable} {} { file exe $dirfile } 1 -removeDirectory $dirfile -removeFile $gorpfile -set linkfile [file join [temporaryDirectory] link.file] -file delete $linkfile +tcltest::removeDirectory $dirfile +tcltest::removeFile $gorpfile +set linkfile [file join [tcltest::temporaryDirectory] link.file] +file delete -- $linkfile # exists test cmdAH-19.1 {Tcl_FileObjCmd: exists} -returnCodes error -body { @@ -905,12 +905,12 @@ test cmdAH-19.1 {Tcl_FileObjCmd: exists} -returnCodes error -body { } -result {wrong # args: should be "file exists name"} test cmdAH-19.2 {Tcl_FileObjCmd: exists} {file exists $gorpfile} 0 test cmdAH-19.3 {Tcl_FileObjCmd: exists} { - file exists [file join [temporaryDirectory] dir.file gorp.file] + file exists [file join [tcltest::temporaryDirectory] dir.file gorp.file] } 0 catch { - set gorpfile [makeFile abcde gorp.file] - set dirfile [makeDirectory dir.file] - set subgorp [makeFile 12345 [file join $dirfile gorp.file]] + set gorpfile [tcltest::makeFile abcde gorp.file] + set dirfile [tcltest::makeDirectory dir.file] + set subgorp [tcltest::makeFile 12345 [file join $dirfile gorp.file]] } test cmdAH-19.4 {Tcl_FileObjCmd: exists} { file exists $gorpfile @@ -958,15 +958,15 @@ test cmdAH-19.11 {Tcl_FileObjCmd: exists} -constraints {unix notRoot} -setup { # Stat related commands catch {testsetplatform $platform} -removeFile $gorpfile -set gorpfile [makeFile "Test string" gorp.file] +tcltest::removeFile $gorpfile +set gorpfile [tcltest::makeFile "Test string" gorp.file] catch {file attributes $gorpfile -permissions 0765} # avoid problems with non-local filesystems -if {[testConstraint unix] && [file exists /tmp]} { - set file [makeFile "data" touch.me /tmp] +if {[tcltest::testConstraint unix] && [file exists /tmp]} { + set file [tcltest::makeFile "data" touch.me /tmp] } else { - set file [makeFile "data" touch.me] + set file [tcltest::makeFile "data" touch.me] } # atime @@ -1012,10 +1012,10 @@ test cmdAH-20.6 {Tcl_FileObjCmd: atime touch} -setup { expr {$newatime == $modatime ? 1 : "$newatime != $modatime"} } -result 1 -if {[testConstraint unix] && [file exists /tmp]} { - removeFile touch.me /tmp +if {[::tcltest::testConstraint unix] && [file exists /tmp]} { + ::tcltest::removeFile touch.me /tmp } else { - removeFile touch.me + ::tcltest::removeFile touch.me } # isdirectory @@ -1065,8 +1065,8 @@ test cmdAH-23.6 {Tcl_FileObjCmd: lstat errors} -setup { } -result {1 {can't set "x(dev)": variable isn't array} {TCL LOOKUP VARNAME x}} unset -nocomplain stat # mkdir -set dirA [file join [temporaryDirectory] a] -set dirB [file join [temporaryDirectory] a] +set dirA [file join [::tcltest::temporaryDirectory] a] +set dirB [file join [::tcltest::temporaryDirectory] a] test cmdAH-23.7 {Tcl_FileObjCmd: mkdir} -setup { catch {file delete -force $dirA} } -body { @@ -1106,7 +1106,7 @@ test cmdAH-23.11 {Tcl_FileObjCmd: mkdir} { file mkdir } {} -set file [makeFile "data" touch.me] +set file [::tcltest::makeFile "data" touch.me] # mtime test cmdAH-24.1 {Tcl_FileObjCmd: mtime} -returnCodes error -body { file mtime a b c @@ -1283,7 +1283,7 @@ test cmdAH-27.1 {Tcl_FileObjCmd: size} -returnCodes error -body { test cmdAH-27.2 {Tcl_FileObjCmd: size} { set oldsize [file size $gorpfile] set f [open $gorpfile a] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} puts $f "More text" close $f expr {[file size $gorpfile] - $oldsize} @@ -1572,10 +1572,10 @@ unset -nocomplain platform # Tcl_ForObjCmd is tested in for.test catch {file attributes $dirfile -permissions 0777} -removeDirectory $dirfile -removeFile $gorpfile +tcltest::removeDirectory $dirfile +tcltest::removeFile $gorpfile # No idea how well [removeFile] copes with links... -file delete $linkfile +file delete -- $linkfile cd $cmdAHwd diff --git a/tests/cmdIL.test b/tests/cmdIL.test index 721773f..c34a6a6 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index 2d68138..9368b0e 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.test @@ -289,8 +289,8 @@ test cmdMZ-4.9 {Tcl_SplitObjCmd: basic split commands} { } {{} {} {} {}} test cmdMZ-4.10 {Tcl_SplitObjCmd: basic split commands} { apply {{} { - set x {} - foreach f [split {]\n} {}] { + set x "" + foreach f [split {]\n} ""] { append x $f } return $x diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test index bae26a0..058dade 100644 --- a/tests/compExpr-old.test +++ b/tests/compExpr-old.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -20,7 +20,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] -if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} { +if {[catch {expr T1()} msg] && ($msg eq {invalid command name "tcl::mathfunc::T1"})} { testConstraint testmathfunctions 0 } else { testConstraint testmathfunctions 1 @@ -84,8 +84,8 @@ proc testIEEE {} { } testConstraint ieeeFloatingPoint [testIEEE] -testConstraint longIs32bit [expr {int(0x80000000) < 0}] -testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] +testConstraint longIs32bit [expr { ( int (0x80000000) ) < 0}] +testConstraint longIs64bit [expr { ( int (0x8000000000000000) ) < 0}] # procedures used below @@ -98,32 +98,33 @@ proc hello_world {} { global a set a "" set L1 [set l0 [set h_1 [set q 0]]] - for {put_hello_char [expr [put_hello_char [expr [set h 7]*10+2]]+29]} {$l0?[put_hello_char $l0] - :!$h_1} {put_hello_char $ll;expr {$L1==2?[set ll [expr 32+0-0+[set bar 0]]]:0}} {expr {[incr L1]==[expr 1+([string length "abc"]-[string length "abc"])] - ?[set ll [set l0 [expr 54<<1]]]:$ll==108&&$L1<3? - [incr ll [expr 1|1<<1]; set ll $ll; set ll $ll; set ll $ll; set ll $ll; set l0 [expr ([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])]; set l0; set l0 $l0; set l0; set l0]:$L1==4&&$ll==32?[set ll [expr 19+$h1+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+[set foo [expr ([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])]]]] - :[set q [expr $q-$h1+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])]]};expr {$L1==5?[incr ll -8; set ll $ll; set ll]:$q&&$h1&&1};expr {$L1==4+2 - ?[incr ll 3]:[expr ([string length "abc"]-[string length "abc"])+1]};expr {$ll==($h<<4)+2+0&&$L1!=6?[incr ll -6]:[set h1 [expr 100+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])]]} - expr {$L1!=1<<3?[incr q [expr ([string length "abc"]-[string length "abc"])-1]]:[set h_1 [set ll $h1]]} + for {put_hello_char [expr [put_hello_char [expr [set h 7] * 10 + 2]]+29]} {$l0 ? [put_hello_char $l0] + : (!$h_1)} {put_hello_char $ll;expr {($L1 == 2) ? [set ll [expr 32 + 0 - 0 + [set bar 0]]] : 0}} { + expr {([incr L1] == [expr 1 + ([string length "abc"] - [string length "abc"])]) + ? [set ll [set l0 [expr 54 << 1]]] : (($ll == 108) && ($L1 < 3)) ? + [incr ll [expr 1 | 1 << 1]; set ll $ll; set ll $ll; set ll $ll; set ll $ll; set l0 [expr ([string length "abc"] - [string length "abc"]) + ([string length "abc"] - [string length "abc"]) - ([string length "abc"] - [string length "abc"]) + ([string length "abc"] - [string length "abc"])]; set l0; set l0 $l0; set l0; set l0] : (($L1 == 4) && ($ll == 32)) ? [set ll [expr 19 + $h1 + ([string length "abc"] - [string length "abc"]) - ([string length "abc"] - [string length "abc"]) + ([string length "abc"] - [string length "abc"]) - ([string length "abc"] - [string length "abc"]) + [set foo [expr ([string length "abc"] - [string length "abc"]) + ([string length "abc"] - [string length "abc"]) + ([string length "abc"] - [string length "abc"])]]]] + : [set q [expr $q - $h1 + ([string length "abc"] - [string length "abc"]) - ([string length "abc"] - [string length "abc"])]]};expr {($L1 == 5) ? [incr ll -8; set ll $ll; set ll] : ($q && $h1 && 1)};expr {($L1 == (4 + 2)) + ? [incr ll 3] : [expr ([string length "abc"] - [string length "abc"]) + 1]};expr {(($ll == (($h << 4) + 2 + 0)) && ($L1 != 6)) ? [incr ll -6] : [set h1 [expr 100 + ([string length "abc"] - [string length "abc"]) - ([string length "abc"] - [string length "abc"])]]} + expr {($L1 != (1 << 3)) ? [incr q [expr ([string length "abc"] - [string length "abc"]) - 1]] : [set h_1 [set ll $h1]]} } set a } proc 12days {a b c} { global xxx - expr {1<$a?[expr {$a<3?[12days -79 -13 [string range $c [12days -87 \ - [expr 1-$b] [string range $c [12days -86 0 [string range $c 1 end]] \ - end]] end]]:1};expr {$a<$b?[12days [expr $a+1] $b $c]:3};expr {[12days \ - -94 [expr $a-27] $c]&&$a==2?$b<13?[12days 2 [expr $b+1] "%s %d %d\n"]:9 - :16}]:$a<0?$a<-72?[12days $b $a "@n'+,#'/*\{\}w+/w#cdnr/+,\{\}r/*de\}+,/*\{*+,/w\{%+,/w#q#n+,/#\{l+,/n\{n+,/+#n+,/#;#q#n+,/+k#;*+,/'r :'d*'3,\}\{w+K w'K:'+\}e#';dq#'l q#'+d'K#!/+k#;q#'r\}eKK#\}w'r\}eKK\{nl\]'/#;#q#n')\{)#\}w')\{)\{nl\]'/+#n';d\}rw' i;# )\{nl\]!/n\{n#'; r\{#w'r nc\{nl\]'/#\{l,+'K \{rw' iK\{;\[\{nl\]'/w#q#n'wk nw' iwk\{KK\{nl\]!/w\{%'l##w#' i; :\{nl\]'/*\{q#'ld;r'\}\{nlwb!/*de\}'c ;;\{nl'-\{\}rw\]'/+,\}##'*\}#nc,',#nw\]'/+kd'+e\}+;#'rdq#w! nr'/ ') \}+\}\{rl#'\{n' ')# \}'+\}##(!!/"] - :$a<-50?[string compare [format %c $b] [string index $c 0]]==0?[append \ + expr {(1 < $a) ? [expr {($a < 3) ? [12days -79 -13 [string range $c [12days -87 \ + [expr 1 - $b] [string range $c [12days -86 0 [string range $c 1 end]] \ + end]] end]] : 1}; expr {($a < $b) ? [12days [expr ($a + 1)] $b $c] : 3}; expr {([12days \ + -94 [expr $a - 27] $c] && ($a == 2)) ? ($b < 13) ? [12days 2 [expr $b + 1] "%s %d %d\n"] : 9 + : 16}] : ($a < 0) ? ($a < -72) ? [12days $b $a "@n'+,#'/*\{\}w+/w#cdnr/+,\{\}r/*de\}+,/*\{*+,/w\{%+,/w#q#n+,/#\{l+,/n\{n+,/+#n+,/#;#q#n+,/+k#;*+,/'r :'d*'3,\}\{w+K w'K:'+\}e#';dq#'l q#'+d'K#!/+k#;q#'r\}eKK#\}w'r\}eKK\{nl\]'/#;#q#n')\{)#\}w')\{)\{nl\]'/+#n';d\}rw' i;# )\{nl\]!/n\{n#'; r\{#w'r nc\{nl\]'/#\{l,+'K \{rw' iK\{;\[\{nl\]'/w#q#n'wk nw' iwk\{KK\{nl\]!/w\{%'l##w#' i; :\{nl\]'/*\{q#'ld;r'\}\{nlwb!/*de\}'c ;;\{nl'-\{\}rw\]'/+,\}##'*\}#nc,',#nw\]'/+kd'+e\}+;#'rdq#w! nr'/ ') \}+\}\{rl#'\{n' ')# \}'+\}##(!!/"] + : ($a < -50) ? ([string compare [format %c $b] [string index $c 0]] == 0) ? [append \ xxx [string index $c 31];scan [string index $c 31] %c x;set x] - :[12days -65 $b [string range $c 1 end]]:[12days [expr ([string compare \ - [string index $c 0] "/"]==0)+$a] $b [string range $c 1 end]]:0<$a - ?[12days 2 2 "%s"]:[string compare [string index $c 0] "/"]==0|| + :[12days -65 $b [string range $c 1 end]] : [12days [expr ([string compare \ + [string index $c 0] "/"] == 0) + $a] $b [string range $c 1 end]] : (0 < $a) + ? [12days 2 2 "%s"] : (([string compare [string index $c 0] "/"] == 0) || [12days 0 [12days -61 [scan [string index $c 0] %c x; set x] \ "!ek;dc i@bK'(q)-\[w\]*%n+r3#l,\{\}:\nuwloca-O;m .vpbks,fxntdCeghiry"] \ - [string range $c 1 end]]} + [string range $c 1 end]])} } proc do_twelve_days {} { global xxx @@ -136,7 +137,7 @@ proc do_twelve_days {} { # start of tests -catch {unset a b i x} +unset -nocomplain a b i x test compExpr-old-1.1 {TclCompileExprCmd: no expression} { list [catch {expr } msg] $msg @@ -332,7 +333,6 @@ test compExpr-old-8.11 {CompileEqualityExpr: error compiling equality arm} -body expr 2!=x } -returnCodes error -match glob -result * - test compExpr-old-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12 test compExpr-old-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63 test compExpr-old-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1 @@ -490,13 +490,13 @@ test compExpr-old-14.12 {CompilePrimaryExpr: var reference primary} { list [expr {$i}] [expr $i] } {789 789} test compExpr-old-14.13 {CompilePrimaryExpr: var reference primary} { - catch {unset a} + unset -nocomplain a set a(foo) foo set a(bar) bar set a(123) 123 set result "" lappend result [expr $a(123)] [expr {$a(bar)<$a(foo)}] - catch {unset a} + unset -nocomplain a set result } {123 1} test compExpr-old-14.14 {CompilePrimaryExpr: var reference primary} { @@ -619,11 +619,11 @@ test compExpr-old-15.11 {CompileMathFuncCall: call registered math function} tes } -17.5 test compExpr-old-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} { - catch {unset a} + unset -nocomplain a set a(VALUE) ff15 set i 123 if {[expr 0x$a(VALUE)] & 16} { - set i {} + set i "" } set i } {} diff --git a/tests/compExpr.test b/tests/compExpr.test index 14c875d..f5d2bf8 100644 --- a/tests/compExpr.test +++ b/tests/compExpr.test @@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} { ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] -if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} { +if {[catch {expr T1()} msg] && ($msg eq {invalid command name "tcl::mathfunc::T1"})} { testConstraint testmathfunctions 0 } else { testConstraint testmathfunctions 1 @@ -25,7 +25,7 @@ if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1" # Constrain memory leak tests testConstraint memory [llength [info commands memory]] -catch {unset a} +unset -nocomplain a test compExpr-1.1 {TclCompileExpr procedure, successful expr parse and compile} { expr 1+2 @@ -385,8 +385,7 @@ test compExpr-7.2 {[Bug 1869989]: expr parser memleak} -constraints memory -setu } -result 0 # cleanup -catch {unset a} -catch {unset b} +unset -nocomplain a b ::tcltest::cleanupTests return diff --git a/tests/compile.test b/tests/compile.test index 4d91940..a5609d9 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -26,13 +26,11 @@ testConstraint testevalex [llength [info commands testevalex]] catch {rename p ""} catch {namespace delete test_ns_compile} -catch {unset x} -catch {unset y} -catch {unset a} +unset -nocomplain x y a test compile-1.1 {TclCompileString: look up cmds in proc ns, not current ns} -setup { catch {namespace delete test_ns_compile} - catch {unset x} + unset -nocomplain x } -body { set x 123 namespace eval test_ns_compile { @@ -52,13 +50,13 @@ test compile-1.2 {TclCompileString, error result is reset if TclGetLong determin } {1 {wrong # args: should be "p x"}} test compile-2.1 {TclCompileDollarVar: global scalar name with ::s} -setup { - catch {unset x} + unset -nocomplain x } -body { set x 123 list $::x [expr {"x" in [info globals]}] } -result {123 1} test compile-2.2 {TclCompileDollarVar: global scalar name with ::s} -setup { - catch {unset y} + unset -nocomplain y } -body { proc p {} { set ::y 789 @@ -67,13 +65,13 @@ test compile-2.2 {TclCompileDollarVar: global scalar name with ::s} -setup { list [p] $::y [expr {"y" in [info globals]}] } -result {789 789 1} test compile-2.3 {TclCompileDollarVar: global array name with ::s} -setup { - catch {unset a} + unset -nocomplain a } -body { set ::a(1) 2 list $::a(1) [set ::a($::a(1)) 3] $::a(2) [expr {"a" in [info globals]}] } -result {2 3 3 1} test compile-2.4 {TclCompileDollarVar: global scalar name with ::s} -setup { - catch {unset a} + unset -nocomplain a } -body { proc p {} { set ::a(1) 1 @@ -82,7 +80,7 @@ test compile-2.4 {TclCompileDollarVar: global scalar name with ::s} -setup { list [p] $::a(1) [expr {"a" in [info globals]}] } -result {1 1 1} test compile-2.5 {TclCompileDollarVar: global array, called as ${arrName(0)}} -setup { - catch {unset a} + unset -nocomplain a } -body { proc p {} { global a @@ -93,7 +91,7 @@ test compile-2.5 {TclCompileDollarVar: global array, called as ${arrName(0)}} -s } -result {111 1 1} test compile-3.1 {TclCompileCatchCmd: only catch cmds with scalar vars are compiled inline} -setup { - catch {unset a} + unset -nocomplain a } -body { set a(1) xyzzyx proc p {} { @@ -196,8 +194,7 @@ test compile-5.2 {TclCompileForeachCmd: non-local variables} { } 3 test compile-6.1 {TclCompileSetCmd: global scalar names with ::s} -setup { - catch {unset x} - catch {unset y} + unset -nocomplain x y } -body { set x 123 proc p {} { @@ -208,7 +205,7 @@ test compile-6.1 {TclCompileSetCmd: global scalar names with ::s} -setup { [p] $::y [expr {"y" in [info globals]}] } -result {123 1 789 789 1} test compile-6.2 {TclCompileSetCmd: global array names with ::s} -setup { - catch {unset a} + unset -nocomplain a } -body { set ::a(1) 2 proc p {} { @@ -219,7 +216,7 @@ test compile-6.2 {TclCompileSetCmd: global array names with ::s} -setup { } -result {2 1 3 3 1} test compile-6.3 {TclCompileSetCmd: namespace var names with ::s} -setup { catch {namespace delete test_ns_compile} - catch {unset x} + unset -nocomplain x } -body { namespace eval test_ns_compile { variable v hello @@ -248,14 +245,14 @@ test compile-8.2 {CollectArgInfo: binary data} { list [catch "string length foo\000" msg] $msg } {0 4} test compile-8.3 {CollectArgInfo: handle "]" at end of command properly} { - set x ] -} {]} + set x "\]" +} "\]" test compile-9.1 {UpdateStringOfByteCode: called for duplicate of compiled empty object} { proc p {} { - set x {} + set x "" eval $x - append x { } + append x " " eval $x } p @@ -349,7 +346,7 @@ test compile-12.2 {testing error on literal deletion} -constraints {memory exec} # Test to catch buffer overrun in TclCompileTokens from buf 530320 test compile-12.3 {check for a buffer overrun} -body { proc crash {} { - puts $array([expr {a+2}]) + puts $array([expr {a + 2}]) } crash } -returnCodes error -cleanup { @@ -452,12 +449,12 @@ test compile-15.5 {proper TCL_RETURN code from [return]} { for {set noComp 0} {$noComp <= 1} {incr noComp} { -if $noComp { - interp alias {} run {} testevalex +if {$noComp} { + interp alias "" run "" testevalex set constraints testevalex } else { - interp alias {} run {} if 1 - set constraints {} + interp alias "" run "" if 1 + set constraints "" } test compile-16.1.$noComp {TclCompileScript: word expansion} $constraints { @@ -534,30 +531,30 @@ test compile-16.17.$noComp {TclCompileScript: word expansion} $constraints { # suite. # test compile-16.18.$noComp {TclCompileScript: word expansion} -body { - proc LongList {} {return [lrepeat [expr {1<<10}] x]} - llength [run "list [string repeat {{*}[LongList] } [expr {1<<10}]]"] + proc LongList {} {return [lrepeat [expr {1 << 10}] x]} + llength [run "list [string repeat {{*}[LongList] } [expr {1 << 10}]]"] } -constraints [linsert $constraints 0 knownBug] -cleanup { rename LongList {} -} -returnCodes ok -result [expr {1<<20}] +} -returnCodes ok -result [expr {1 << 20}] test compile-16.19.$noComp {TclCompileScript: word expansion} -body { - proc LongList {} {return [lrepeat [expr {1<<11}] x]} - llength [run "list [string repeat {{*}[LongList] } [expr {1<<11}]]"] + proc LongList {} {return [lrepeat [expr {1 << 11}] x]} + llength [run "list [string repeat {{*}[LongList] } [expr {1 << 11}]]"] } -constraints [linsert $constraints 0 knownBug] -cleanup { rename LongList {} -} -returnCodes ok -result [expr {1<<22}] +} -returnCodes ok -result [expr {1 << 22}] test compile-16.20.$noComp {TclCompileScript: word expansion} -body { - proc LongList {} {return [lrepeat [expr {1<<12}] x]} - llength [run "list [string repeat {{*}[LongList] } [expr {1<<12}]]"] + proc LongList {} {return [lrepeat [expr {1 << 12}] x]} + llength [run "list [string repeat {{*}[LongList] } [expr {1 << 12}]]"] } -constraints [linsert $constraints 0 knownBug] -cleanup { - rename LongList {} -} -returnCodes ok -result [expr {1<<24}] + rename LongList "" +} -returnCodes ok -result [expr {1 << 24}] # This is the one that should cause overflow test compile-16.21.$noComp {TclCompileScript: word expansion} -body { - proc LongList {} {return [lrepeat [expr {1<<16}] x]} - llength [run "list [string repeat {{*}[LongList] } [expr {1<<16}]]"] + proc LongList {} {return [lrepeat [expr {1 << 16}] x]} + llength [run "list [string repeat {{*}[LongList] } [expr {1 << 16}]]"] } -constraints [linsert $constraints 0 knownBug] -cleanup { rename LongList {} -} -returnCodes ok -result [expr {wide(1)<<32}] +} -returnCodes ok -result [expr { ( wide (1) ) << 32}] test compile-16.22.$noComp { Bug 845412: TclCompileScript: word expansion not mandatory } -body { @@ -712,9 +709,7 @@ test compile-18.19 {disassembler - basics} -setup { # cleanup catch {rename p ""} catch {namespace delete test_ns_compile} -catch {unset x} -catch {unset y} -catch {unset a} +unset -nocomplain x y a ::tcltest::cleanupTests return diff --git a/tests/config.test b/tests/config.test index d14837e..cc1c13b 100644 --- a/tests/config.test +++ b/tests/config.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -29,7 +29,6 @@ test pkgconfig-1.3 {query value multiple times} { [::tcl::pkgconfig get bindir,install] } 0 - test pkgconfig-2.0 {error: missing subcommand} { catch {::tcl::pkgconfig} msg set msg diff --git a/tests/coroutine.test b/tests/coroutine.test index 8272717..e009dac 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } diff --git a/tests/dict.test b/tests/dict.test index 72a336c..4b54c07 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -17,7 +17,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] if {[testConstraint memory]} { - proc memtest script { + proc memtest {script} { set end [lindex [split [memory info] \n] 3 3] for {set i 0} {$i < 5} {incr i} { uplevel 1 $script diff --git a/tests/encoding.test b/tests/encoding.test index 0374e2d..91056e0 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -92,12 +92,12 @@ test encoding-3.1 {Tcl_GetEncodingName, NULL} -setup { encoding system $old } -result {shiftjis} test encoding-3.2 {Tcl_GetEncodingName, non-null} -setup { - set old [fconfigure stdout -encoding] + set old [chan configure stdout -encoding] } -body { - fconfigure stdout -encoding jis0208 - fconfigure stdout -encoding + chan configure stdout -encoding jis0208 + chan configure stdout -encoding } -cleanup { - fconfigure stdout -encoding $old + chan configure stdout -encoding $old } -result {jis0208} test encoding-4.1 {Tcl_GetEncodingNames} -constraints {testencoding} -setup { @@ -105,8 +105,7 @@ test encoding-4.1 {Tcl_GetEncodingNames} -constraints {testencoding} -setup { makeDirectory [file join tmp encoding] set path [encoding dirs] encoding dirs {} - catch {unset encodings} - catch {unset x} + unset -nocomplain encodings x } -body { foreach encoding [encoding names] { set encodings($encoding) 1 @@ -178,11 +177,11 @@ test encoding-7.2 {Tcl_UtfToExternalDString: big buffer} { test encoding-8.1 {Tcl_ExternalToUtf} { set f [open [file join [temporaryDirectory] dummy] w] - fconfigure $f -translation binary -encoding iso8859-1 + chan configure $f -translation binary -encoding iso8859-1 puts -nonewline $f "ab\x8c\xc1g" close $f set f [open [file join [temporaryDirectory] dummy] r] - fconfigure $f -translation binary -encoding shiftjis + chan configure $f -translation binary -encoding shiftjis set x [read $f] close $f file delete [file join [temporaryDirectory] dummy] @@ -206,11 +205,11 @@ test encoding-9.2 {Tcl_UtfToExternalDString: big buffer} { test encoding-10.1 {Tcl_UtfToExternal} { set f [open [file join [temporaryDirectory] dummy] w] - fconfigure $f -translation binary -encoding shiftjis + chan configure $f -translation binary -encoding shiftjis puts -nonewline $f "ab\u4e4eg" close $f set f [open [file join [temporaryDirectory] dummy] r] - fconfigure $f -translation binary -encoding iso8859-1 + chan configure $f -translation binary -encoding iso8859-1 set x [read $f] close $f file delete [file join [temporaryDirectory] dummy] @@ -219,7 +218,7 @@ test encoding-10.1 {Tcl_UtfToExternal} { proc viewable {str} { set res "" - foreach c [split $str {}] { + foreach c [split $str ""] { if {[string is print $c] && [string is ascii $c]} { append res $c } else { @@ -265,7 +264,7 @@ test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding} makeDirectory tmp makeDirectory [file join tmp encoding] set f [open [file join tmp encoding splat.enc] w] - fconfigure $f -translation binary + chan configure $f -translation binary puts $f "abcdefghijklmnop" close $f encoding convertto splat \u4e4e @@ -366,7 +365,7 @@ set iso2022uniData2 "\u79c1\u3069\u3082\u3067\u306f\u3001\u30c1\u30c3\u30d7\u305 cd [temporaryDirectory] set fid [open iso2022.txt w] -fconfigure $fid -encoding binary +chan configure $fid -encoding binary puts -nonewline $fid $iso2022encData close $fid @@ -377,7 +376,7 @@ test encoding-23.2 {iso2022-jp escape encoding test} { # This checks that 'gets' isn't resetting the encoding inappropriately. # [Bug #523988] set fid [open iso2022.txt r] - fconfigure $fid -encoding iso2022-jp + chan configure $fid -encoding iso2022-jp set out "" set count 0 while {[set num [gets $fid line]] >= 0} { @@ -397,12 +396,12 @@ test encoding-23.2 {iso2022-jp escape encoding test} { test encoding-23.3 {iso2022-jp escape encoding test} { # read $fis <size> reads size in chars, not raw bytes. set fid [open iso2022.txt r] - fconfigure $fid -encoding iso2022-jp + chan configure $fid -encoding iso2022-jp set data [read $fid 50] close $fid return $data } [string range $iso2022uniData 0 49] ; # 0 .. 49 inclusive == 50 -cd [workingDirectory] +cd [::tcltest::workingDirectory] # Code to make the next few tests more intelligible; the code being tested # should be in the body of the test! @@ -418,7 +417,7 @@ proc runInSubprocess {contents {filename iso2022.tcl}} { test encoding-24.1 {EscapeFreeProc on open channels} exec { runInSubprocess { set f [open [file join [file dirname [info script]] iso2022.txt]] - fconfigure $f -encoding iso2022-jp + chan configure $f -encoding iso2022-jp gets $f } } {} @@ -426,7 +425,7 @@ test encoding-24.2 {EscapeFreeProc on open channels} {exec} { # Bug #524674 output viewable [runInSubprocess { encoding system cp1252; # Bug #2891556 crash revelator - fconfigure stdout -encoding iso2022-jp + chan configure stdout -encoding iso2022-jp puts ab\u4e4e\u68d9g set env(TCL_FINALIZE_ON_EXIT) 1 exit @@ -441,14 +440,14 @@ test encoding-24.3 {EscapeFreeProc on open channels} {stdio} { puts $a } iso2022.tcl] set f [open "|[list [interpreter] $file]"] - fconfigure $f -encoding iso2022-jp + chan configure $f -encoding iso2022-jp set count [gets $f line] close $f removeFile iso2022.tcl list $count [viewable $line] } [list 3 "\u4e4e\u4e5e\u4e5f (\\u4e4e\\u4e5e\\u4e5f)"] -file delete [file join [temporaryDirectory] iso2022.txt] +file delete -- [file join [temporaryDirectory] iso2022.txt] # # Begin jajp encoding round-trip conformity tests @@ -478,17 +477,17 @@ proc foreach-jisx0208 {varName command} { } { if {[llength $range] == 2} { # for adhoc range. simple {first last}. inclusive. - scan $range %x%x first last + scan $range "%x%x" first last for {set i $first} {$i <= $last} {incr i} { set code $i uplevel 1 $command } } elseif {[llength $range] == 4} { # for uniform range. - scan $range %x%x%x%x h0 l0 hend lend + scan $range "%x%x%x%x" h0 l0 hend lend for {set hi $h0} {$hi <= $hend} {incr hi} { for {set lo $l0} {$lo <= $lend} {incr lo} { - set code [expr {$hi << 8 | ($lo & 0xff)}] + set code [expr {($hi << 8) | ($lo & 0xff)}] uplevel 1 $command } } @@ -507,20 +506,20 @@ proc gen-jisx0208-iso2022-jp {code} { } proc gen-jisx0208-cp932 {code} { set c1 [expr {($code >> 8) | 0x80}] - set c2 [expr {($code & 0xff)| 0x80}] + set c2 [expr {($code & 0xff) | 0x80}] if {$c1 % 2} { - set c1 [expr {($c1 >> 1) + ($c1 < 0xdf ? 0x31 : 0x71)}] + set c1 [expr {($c1 >> 1) + (($c1 < 0xdf) ? 0x31 : 0x71)}] incr c2 [expr {- (0x60 + ($c2 < 0xe0))}] } else { - set c1 [expr {($c1 >> 1) + ($c1 < 0xdf ? 0x30 : 0x70)}] + set c1 [expr {($c1 >> 1) + (($c1 < 0xdf) ? 0x30 : 0x70)}] incr c2 -2 } binary format cc $c1 $c2 } proc channel-diff {fa fb} { set diff {} - while {[gets $fa la] >= 0 && [gets $fb lb] >= 0} { - if {[string compare $la $lb] == 0} continue + while {([chan gets $fa la] >= 0) && ([chan gets $fb lb] >= 0)} { + if {$la eq $lb} continue # lappend diff $la $lb # For more readable (easy to analyze) output. @@ -536,7 +535,7 @@ proc channel-diff {fa fb} { cd [temporaryDirectory] foreach enc {cp932 euc-jp iso2022-jp} { set f [open $enc.chars w] - fconfigure $f -encoding binary + chan configure $f -encoding binary foreach-jisx0208 code { puts $f [format "%04X %s" $code [gen-jisx0208-$enc $code]] } @@ -552,9 +551,9 @@ foreach from {cp932 shiftjis euc-jp iso2022-jp} { cd [temporaryDirectory] } -body { set f [open $from.chars] - fconfigure $f -encoding $from + chan configure $f -encoding $from set out [open $from.$to.tcltestout w] - fconfigure $out -encoding $to + chan configure $out -encoding $to puts -nonewline $out [read $f] close $out close $f diff --git a/tests/env.test b/tests/env.test index e75d517..8f22f53 100644 --- a/tests/env.test +++ b/tests/env.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -26,7 +26,7 @@ testConstraint exec [llength [info commands exec]] # test env-1.1 {propagation of env values to child interpreters} -setup { catch {interp delete child} - catch {unset env(test)} + unset -nocomplain env(test) } -body { interp create child set env(test) garbage @@ -40,7 +40,7 @@ test env-1.1 {propagation of env values to child interpreters} -setup { # runs. # test env-1.2 {lappend to env value} -setup { - catch {unset env(test)} + unset -nocomplain env(test) } -body { set env(test) aaaaaaaaaaaaaaaa append env(test) bbbbbbbbbbbbbb @@ -48,14 +48,14 @@ test env-1.2 {lappend to env value} -setup { } test env-1.3 {reflection of env by "array names"} -setup { catch {interp delete child} - catch {unset env(test)} + unset -nocomplain env(test) } -body { interp create child child eval {set env(test) garbage} expr {"test" in [array names env]} } -cleanup { interp delete child - catch {unset env(test)} + unset -nocomplain env(test) } -result {1} set printenvScript [makeFile { @@ -103,9 +103,9 @@ set printenvScript [makeFile { # processes. proc getenv {} { global printenvScript tcltest - catch {exec [interpreter] $printenvScript} out + catch {exec -- [interpreter] $printenvScript} out if {$out eq "child process exited abnormally"} { - set out {} + set out "" } return $out } diff --git a/tests/error.test b/tests/error.test index 97bcc0a..b3ebe63 100644 --- a/tests/error.test +++ b/tests/error.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -135,11 +135,11 @@ test error-3.2 {errors in catch command} { list [catch {catch a b c} msg] $msg } {0 1} test error-3.3 {errors in catch command} { - catch {unset a} + unset -nocomplain a set a(0) 22 list [catch {catch {format 44} a} msg] $msg } {1 {can't set "a": variable is array}} -catch {unset a} +unset -nocomplain a # More tests related to errorInfo and errorCode @@ -532,7 +532,7 @@ foreach level {0 1 2 3} { # Following cases have different -errorinfo; avoid false alarms # TODO: examine whether these difference are as they ought to be. - if {$level == 0 && $code == 1} continue + if {($level == 0) && ($code == 1)} continue foreach extras {{} {-bar soom}} { @@ -823,7 +823,7 @@ test error-19.5 {multiple unrelated fallthroughs #2} { } set RES } {err} -proc addmsg msg { +proc addmsg {msg} { variable RES lappend RES $msg } diff --git a/tests/event.test b/tests/event.test index 0d1b06c..ddf436c 100644 --- a/tests/event.test +++ b/tests/event.test @@ -18,7 +18,6 @@ catch { set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1] } - testConstraint testfilehandler [llength [info commands testfilehandler]] testConstraint testexithandler [llength [info commands testexithandler]] testConstraint testfilewait [llength [info commands testfilewait]] @@ -514,7 +513,7 @@ test event-11.2 {Tcl_VwaitCmd procedure} -returnCodes error -body { vwait a b } -result {wrong # args: should be "vwait name"} test event-11.3 {Tcl_VwaitCmd procedure} -setup { - catch {unset x} + unset -nocomplain x } -body { set x 1 vwait x(1) @@ -549,7 +548,7 @@ test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} -set } set s1 [socket -server accept -myaddr 127.0.0.1 0] after 1000 - set s2 [socket 127.0.0.1 [lindex [fconfigure $s1 -sockname] 2]] + set s2 [socket 127.0.0.1 [lindex [chan configure $s1 -sockname] 2]] close $s1 set x 0 set y 0 diff --git a/tests/exec.test b/tests/exec.test index 871c0c5..a354440 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -37,7 +37,7 @@ set path(cat) [makeFile { if {$argv eq ""} { set argv - } - fconfigure stdout -translation binary + chan configure stdout -translation binary foreach name $argv { if {$name eq "-"} { set f stdin @@ -45,8 +45,8 @@ set path(cat) [makeFile { puts stderr $f continue } - fconfigure $f -translation binary - while {[eof $f] == 0} { + chan configure $f -translation binary + while {[chan eof $f] == 0} { puts -nonewline [read $f] } if {$f ne "stdin"} { @@ -108,10 +108,10 @@ set path(exit) [makeFile { exit $argv } exit] -proc readfile filename { +proc readfile {filename} { set f [open $filename] - set d [read $f] - close $f + set d [chan read $f] + chan close $f return [string trimright $d \n] } @@ -174,7 +174,7 @@ test exec-2.6 {redirecting input from immediate source, with UTF} -setup { # I/O redirection: output to file. set path(gorp.file) [makeFile {} gorp.file] -file delete $path(gorp.file) +file delete -- $path(gorp.file) test exec-3.1 {redirecting output to file} {exec} { exec [interpreter] $path(echo) "Some simple words" > $path(gorp.file) @@ -215,7 +215,7 @@ test exec-3.7 {redirecting output to file} {exec} { # I/O redirection: output and stderr to file. -file delete $path(gorp.file) +file delete -- $path(gorp.file) test exec-4.1 {redirecting output and stderr to file} {exec} { exec [interpreter] $path(echo) "test output" >& $path(gorp.file) @@ -254,7 +254,7 @@ test exec-4.5 {redirecting output and stderr to file} {exec} { # I/O redirection: input from file. if {[testConstraint exec]} { - exec [interpreter] $path(echo) "Just a few thoughts" > $path(gorp.file) + exec -- [interpreter] $path(echo) "Just a few thoughts" > $path(gorp.file) } test exec-5.1 {redirecting input from file} {exec} { exec [interpreter] $path(cat) < $path(gorp.file) @@ -299,8 +299,8 @@ test exec-6.3 {redirecting stderr through a pipeline} {exec stdio} { # I/O redirection: combinations. -set path(gorp.file2) [makeFile {} gorp.file2] -file delete $path(gorp.file2) +set path(gorp.file2) [makeFile "" gorp.file2] +file delete -- $path(gorp.file2) test exec-7.1 {multiple I/O redirections} {exec} { exec << "command input" > $path(gorp.file2) [interpreter] $path(cat) < $path(gorp.file) @@ -465,7 +465,7 @@ test exec-11.5 {commands in background} {exec} { if {[testConstraint exec] && [testConstraint nonPortable]} { after 1300 - exec [interpreter] $path(sleep) 1 + exec -- [interpreter] $path(sleep) 1 } test exec-12.1 {reaping background processes} {exec unix nonPortable} { for {set i 0} {$i < 20} {incr i} { diff --git a/tests/execute.test b/tests/execute.test index 94af158..42a793e 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -24,17 +24,15 @@ catch [list package require -exact Tcltest [info patchlevel]] catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename foo ""} -catch {unset x} -catch {unset y} -catch {unset msg} +unset -nocomplain x y msg testConstraint testobj [expr { - [llength [info commands testobj]] - && [llength [info commands testdoubleobj]] - && [llength [info commands teststringobj]] + [llength [info commands testobj]] && + [llength [info commands testdoubleobj]] && + [llength [info commands teststringobj]] }] -testConstraint longIs32bit [expr {int(0x80000000) < 0}] +testConstraint longIs32bit [expr { ( int (0x80000000) ) < 0}] testConstraint testexprlongobj [llength [info commands testexprlongobj]] # Tests for the omnibus TclExecuteByteCode function: @@ -1053,9 +1051,7 @@ catch {rename foo ""} catch {rename p ""} catch {rename {} ""} catch {rename { } ""} -catch {unset x} -catch {unset y} -catch {unset msg} +unset -nocomplain x y msg ::tcltest::cleanupTests return diff --git a/tests/expr.test b/tests/expr.test index 6ad7208..7d340b4 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.1 namespace import -force ::tcltest::* } @@ -25,10 +25,10 @@ testConstraint testmathfunctions [expr { # Determine if "long int" type is a 32 bit number and if the wide # type is a 64 bit number on this machine. -testConstraint longIs32bit [expr {int(0x80000000) < 0}] -testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] +testConstraint longIs32bit [expr { ( int (0x80000000) ) < 0}] +testConstraint longIs64bit [expr { ( int (0x8000000000000000) ) < 0}] testConstraint wideIs64bit \ - [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] + [expr {( ( wide (0x80000000) ) > 0) && ( ( wide (0x8000000000000000) ) < 0)}] # Big test for correct ordering of data in [expr] @@ -103,32 +103,34 @@ proc hello_world {} { global a set a "" set L1 [set l0 [set h_1 [set q 0]]] - for {put_hello_char [expr [put_hello_char [expr [set h 7]*10+2]]+29]} {$l0?[put_hello_char $l0] - :!$h_1} {put_hello_char $ll;expr {$L1==2?[set ll [expr 32+0-0+[set bar 0]]]:0}} {expr {[incr L1]==[expr 1+([string length "abc"]-[string length "abc"])] - ?[set ll [set l0 [expr 54<<1]]]:$ll==108&&$L1<3? - [incr ll [expr 1|1<<1]; set ll $ll; set ll $ll; set ll $ll; set ll $ll; set l0 [expr ([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])]; set l0; set l0 $l0; set l0; set l0]:$L1==4&&$ll==32?[set ll [expr 19+$h1+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+[set foo [expr ([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])]]]] - :[set q [expr $q-$h1+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])]]};expr {$L1==5?[incr ll -8; set ll $ll; set ll]:$q&&$h1&&1};expr {$L1==4+2 - ?[incr ll 3]:[expr ([string length "abc"]-[string length "abc"])+1]};expr {$ll==($h<<4)+2+0&&$L1!=6?[incr ll -6]:[set h1 [expr 100+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])]]} - expr {$L1!=1<<3?[incr q [expr ([string length "abc"]-[string length "abc"])-1]]:[set h_1 [set ll $h1]]} + for {put_hello_char [expr {[put_hello_char [expr {([set h 7] * 10) + 2}]] + 29}]} {$l0 ? [put_hello_char $l0] : (!$h_1)} {put_hello_char $ll;expr {($L1 == 2) ? [set ll [expr {((32 + 0) - 0) + [set bar 0]}]] : 0}} { + expr {([incr L1] == [expr {1 + ([string length "abc"] - [string length "abc"])}]) + ? [set ll [set l0 [expr {54 << 1}]]] : (($ll == 108) && ($L1 < 3)) ? + [incr ll [expr {1 | (1 << 1)}]; set ll $ll; set ll $ll; set ll $ll; set ll $ll; set l0 [expr {((([string length "abc"] - [string length "abc"]) + ([string length "abc"] - [string length "abc"])) - ([string length "abc"] - [string length "abc"])) + ([string length "abc"] - [string length "abc"])}]; set l0; set l0 $l0; set l0; set l0] : (($L1 == 4) && ($ll == 32)) ? [set ll [expr {(((19 + $h1 + ([string length "abc"] - [string length "abc"])) - ([string length "abc"] - [string length "abc"])) + ([string length "abc"] - [string length "abc"])) - ([string length "abc"] - [string length "abc"]) + [set foo [expr {([string length "abc"] - [string length "abc"]) + ([string length "abc"] - [string length "abc"]) + ([string length "abc"] - [string length "abc"])}]]}]] + : [set q [expr {(($q - $h1) + ([string length "abc"] - [string length "abc"])) - ([string length "abc"] - [string length "abc"])}]]} + expr {($L1 == 5) ? [incr ll -8; set ll $ll; set ll] : ($q && $h1 && 1)} + expr {($L1 == (4 + 2)) ? [incr ll 3] : [expr {([string length "abc"] - [string length "abc"]) + 1}]} + expr {(($ll == (($h << 4) + 2 + 0)) && ($L1 != 6)) ? [incr ll -6] : [set h1 [expr {(100 + ([string length "abc"] - [string length "abc"])) - ([string length "abc"] - [string length "abc"])}]]} + expr {($L1 != (1 << 3)) ? [incr q [expr {([string length "abc"] - [string length "abc"]) - 1}]] : [set h_1 [set ll $h1]]} } set a } proc 12days {a b c} { global xxx - expr {1<$a?[expr {$a<3?[12days -79 -13 [string range $c [12days -87 \ - [expr 1-$b] [string range $c [12days -86 0 [string range $c 1 end]] \ - end]] end]]:1};expr {$a<$b?[12days [expr $a+1] $b $c]:3};expr {[12days \ - -94 [expr $a-27] $c]&&$a==2?$b<13?[12days 2 [expr $b+1] "%s %d %d\n"]:9 - :16}]:$a<0?$a<-72?[12days $b $a "@n'+,#'/*\{\}w+/w#cdnr/+,\{\}r/*de\}+,/*\{*+,/w\{%+,/w#q#n+,/#\{l+,/n\{n+,/+#n+,/#;#q#n+,/+k#;*+,/'r :'d*'3,\}\{w+K w'K:'+\}e#';dq#'l q#'+d'K#!/+k#;q#'r\}eKK#\}w'r\}eKK\{nl\]'/#;#q#n')\{)#\}w')\{)\{nl\]'/+#n';d\}rw' i;# )\{nl\]!/n\{n#'; r\{#w'r nc\{nl\]'/#\{l,+'K \{rw' iK\{;\[\{nl\]'/w#q#n'wk nw' iwk\{KK\{nl\]!/w\{%'l##w#' i; :\{nl\]'/*\{q#'ld;r'\}\{nlwb!/*de\}'c ;;\{nl'-\{\}rw\]'/+,\}##'*\}#nc,',#nw\]'/+kd'+e\}+;#'rdq#w! nr'/ ') \}+\}\{rl#'\{n' ')# \}'+\}##(!!/"] - :$a<-50?[string compare [format %c $b] [string index $c 0]]==0?[append \ + expr {(1 < $a) ? [expr {($a < 3) ? [12days -79 -13 [string range $c [12days -87 \ + [expr {1 - $b}] [string range $c [12days -86 0 [string range $c 1 end]] \ + end]] end]] : 1};expr {($a < $b) ? [12days [expr {$a + 1}] $b $c] : 3};expr {(([12days \ + -94 [expr {$a - 27}] $c]) && ($a == 2)) ? ($b < 13) ? [12days 2 [expr {$b + 1}] "%s %d %d\n"] : 9 + : 16}] : ($a < 0) ? ($a < -72) ? [12days $b $a "@n'+,#'/*\{\}w+/w#cdnr/+,\{\}r/*de\}+,/*\{*+,/w\{%+,/w#q#n+,/#\{l+,/n\{n+,/+#n+,/#;#q#n+,/+k#;*+,/'r :'d*'3,\}\{w+K w'K:'+\}e#';dq#'l q#'+d'K#!/+k#;q#'r\}eKK#\}w'r\}eKK\{nl\]'/#;#q#n')\{)#\}w')\{)\{nl\]'/+#n';d\}rw' i;# )\{nl\]!/n\{n#'; r\{#w'r nc\{nl\]'/#\{l,+'K \{rw' iK\{;\[\{nl\]'/w#q#n'wk nw' iwk\{KK\{nl\]!/w\{%'l##w#' i; :\{nl\]'/*\{q#'ld;r'\}\{nlwb!/*de\}'c ;;\{nl'-\{\}rw\]'/+,\}##'*\}#nc,',#nw\]'/+kd'+e\}+;#'rdq#w! nr'/ ') \}+\}\{rl#'\{n' ')# \}'+\}##(!!/"] + : ($a < -50) ? ([format %c $b] eq [string index $c 0]) ? [append \ xxx [string index $c 31];scan [string index $c 31] %c x;set x] - :[12days -65 $b [string range $c 1 end]]:[12days [expr ([string compare \ - [string index $c 0] "/"]==0)+$a] $b [string range $c 1 end]]:0<$a - ?[12days 2 2 "%s"]:[string compare [string index $c 0] "/"]==0|| + : [12days -65 $b [string range $c 1 end]] : [12days [expr {([string compare \ + [string index $c 0] "/"] == 0) + $a}] $b [string range $c 1 end]] : (0 < $a) + ? [12days 2 2 "%s"] : (([string compare [string index $c 0] "/"] == 0) || [12days 0 [12days -61 [scan [string index $c 0] %c x; set x] \ "!ek;dc i@bK'(q)-\[w\]*%n+r3#l,\{\}:\nuwloca-O;m .vpbks,fxntdCeghiry"] \ - [string range $c 1 end]]} + [string range $c 1 end]])} } proc do_twelve_days {} { global xxx @@ -141,7 +143,7 @@ proc do_twelve_days {} { # start of tests -catch {unset a b i x} +unset -nocomplain a b i x test expr-1.1 {TclCompileExprCmd: no expression} { list [catch {expr } msg] $msg @@ -573,13 +575,13 @@ test expr-14.12 {CompilePrimaryExpr: var reference primary} { list [expr {$i}] [expr $i] } {789 789} test expr-14.13 {CompilePrimaryExpr: var reference primary} { - catch {unset a} + unset -nocomplain a set a(foo) foo set a(bar) bar set a(123) 123 set result "" lappend result [expr $a(123)] [expr {$a(bar)<$a(foo)}] - catch {unset a} + unset -nocomplain a set result } {123 1} test expr-14.14 {CompilePrimaryExpr: var reference primary} { @@ -721,13 +723,12 @@ test expr-15.17 {ExprCallMathFunc: non-numeric arg} -constraints { expr T3(0,"a") } -returnCodes error -result {argument to math function didn't have numeric value} - test expr-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} { - catch {unset a} + unset -nocomplain a set a(VALUE) ff15 set i 123 if {[expr 0x$a(VALUE)] & 16} { - set i {} + set i "" } set i } {} @@ -779,11 +780,7 @@ test expr-19.1 {expr and interpreter result object resetting} { # Test for incorrect "double evaluation" semantics test expr-20.1 {wrong brace matching} { - catch {unset l} - catch {unset r} - catch {unset q} - catch {unset cmd} - catch {unset a} + unset -nocomplain l r q cmd a set l "\{"; set r "\}"; set q "\"" set cmd "expr $l$q|$q == $q$r$q$r" list [catch $cmd a] $a @@ -812,7 +809,7 @@ test expr-20.3 {broken substitution of integer digits} { list [set a 000; expr 0x1$a] [set a 1; expr ${a}000] } {4096 1000} test expr-20.4 {proper double evaluation compilation, error case} { - catch {unset a}; # make sure $a doesn't exist + unset -nocomplain a; # make sure $a doesn't exist list [catch {expr 1?{$a}:0} msg] $msg } {1 {can't read "a": no such variable}} test expr-20.5 {proper double evaluation compilation, working case} { @@ -969,17 +966,17 @@ test expr-23.38 {INST_EXPON: big integer} {expr {10**19}} 1[string repeat 0 19] test expr-23.39 {INST_EXPON: big integer} { expr 1[string repeat 0 30]**2 } 1[string repeat 0 60] -test expr-23.40 {INST_EXPON: overflow to big integer} {expr {(-10)**3}} -1000 -test expr-23.41 {INST_EXPON: overflow to big integer} {expr 2**64} [expr 1<<64] -test expr-23.42 {INST_EXPON: overflow to big integer} {expr 4**32} [expr 1<<64] -test expr-23.43 {INST_EXPON: overflow to big integer} {expr 16**16} [expr 1<<64] -test expr-23.44 {INST_EXPON: overflow to big integer} {expr 256**8} [expr 1<<64] -test expr-23.45 {INST_EXPON: Bug 1555371} {expr 2**1} 2 +test expr-23.40 {INST_EXPON: overflow to big integer} {expr {(-10) ** 3}} -1000 +test expr-23.41 {INST_EXPON: overflow to big integer} {expr {2 ** 64}} [expr {1 << 64}] +test expr-23.42 {INST_EXPON: overflow to big integer} {expr {4 ** 32}} [expr {1 << 64}] +test expr-23.43 {INST_EXPON: overflow to big integer} {expr {16 ** 16}} [expr {1 << 64}] +test expr-23.44 {INST_EXPON: overflow to big integer} {expr {256 ** 8}} [expr {1 << 64}] +test expr-23.45 {INST_EXPON: Bug 1555371} {expr {2 ** 1}} 2 test expr-23.46 {INST_EXPON: Bug 1561260} -body { - expr 5**28 + expr {5 ** 28} } -match glob -result *5 test expr-23.47 {INST_EXPON: Bug 1561260} { - expr 2**32*5**32 + expr {(2 ** 32) * (5 ** 32)} } 1[string repeat 0 32] test expr-23.48 {INST_EXPON: TIP 274: right assoc} { expr 2**3**4 @@ -5684,7 +5681,7 @@ foreach s {yes true on} { test expr-31.$i.2 {boolean conversion} {expr bool("$s")} 1 test expr-31.$i.3 {boolean conversion} {expr bool(!"$s")} 0 set j 1 - while {$j < [string length $s]-1} { + while {$j < ([string length $s] - 1)} { test expr-31.$i.4.$j {boolean conversion} { expr bool([string range $s 0 $j]) } 1 @@ -5711,7 +5708,7 @@ foreach s {no false off} { test expr-31.$i.2 {boolean conversion} {expr bool("$s")} 0 test expr-31.$i.3 {boolean conversion} {expr bool(!"$s")} 1 set j 1 - while {$j < [string length $s]-1} { + while {$j < ([string length $s] - 1)} { test expr-31.$i.4.$j {boolean conversion} { expr bool([string range $s 0 $j]) } 0 @@ -5818,17 +5815,17 @@ test expr-32.2 {expr div basics} { ] test expr-32.3 {Bug 1585704} { - expr 1%(1<<63) + expr {1 % (1 << 63)} } 1 test expr-32.4 {Bug 1585704} { - expr -1%(1<<63) -} [expr (1<<63)-1] + expr {-1 % (1 << 63)} +} [expr {(1 << 63) - 1}] test expr-32.5 {Bug 1585704} { - expr (1<<32)%(1<<63) -} [expr 1<<32] + expr {(1 << 32) % (1 << 63)} +} [expr {1 << 32}] test expr-32.6 {Bug 1585704} { - expr -(1<<32)%(1<<63) -} [expr (1<<63)-(1<<32)] + expr {-(1 << 32) % (1 << 63)} +} [expr {(1 << 63) - (1 << 32)}] test expr-33.1 {parse largest long value} longIs32bit { set max_long_str 2147483647 @@ -5844,7 +5841,7 @@ test expr-33.1 {parse largest long value} longIs32bit { [expr {$max_long + 0}] \ [expr {2147483647 + 0}] \ [expr {$max_long == $max_long_hex}] \ - [expr {int(2147483647 + 1) < 0}] \ + [expr { int (2147483647 + 1) < 0}] \ } {2147483647 2147483647 2147483647 2147483647 1 1} test expr-33.2 {parse smallest long value} longIs32bit { @@ -5864,7 +5861,7 @@ test expr-33.2 {parse smallest long value} longIs32bit { [expr {$min_long + 0}] \ [expr {-2147483648 + 0}] \ [expr {$min_long == $min_long_hex}] \ - [expr {int(-2147483648 - 1) == 0x7FFFFFFF}] \ + [expr { int (-2147483648 - 1) == 0x7FFFFFFF}] \ } {-2147483648 -2147483648 -2147483648 -2147483648 1 1} test expr-33.3 {parse largest wide value} wideIs64bit { @@ -5881,7 +5878,7 @@ test expr-33.3 {parse largest wide value} wideIs64bit { [expr {$max_wide + 0}] \ [expr {9223372036854775807 + 0}] \ [expr {$max_wide == $max_wide_hex}] \ - [expr {wide(9223372036854775807 + 1) < 0}] \ + [expr { wide (9223372036854775807 + 1) < 0}] \ } {9223372036854775807 9223372036854775807 9223372036854775807 9223372036854775807 1 1} test expr-33.4 {parse smallest wide value} wideIs64bit { @@ -5901,7 +5898,7 @@ test expr-33.4 {parse smallest wide value} wideIs64bit { [expr {$min_wide + 0}] \ [expr {-9223372036854775808 + 0}] \ [expr {$min_wide == $min_wide_hex}] \ - [expr {wide(-9223372036854775808 - 1) == 0x7FFFFFFFFFFFFFFF}] \ + [expr { wide (-9223372036854775808 - 1) == 0x7FFFFFFFFFFFFFFF}] \ } {-9223372036854775808 -9223372036854775808 -9223372036854775808 -9223372036854775808 1 1} @@ -6814,48 +6811,48 @@ test expr-39.25 {Tcl_ExprDoubleObj and NaN} \ } {1 {domain error: argument not in valid range}} test expr-40.1 {large octal shift} { - expr 0o100000000000000000000000000000000 -} [expr 0x1000000000000000000000000] + expr {0o100000000000000000000000000000000} +} [expr {0x1000000000000000000000000}] test expr-40.2 {large octal shift} { - expr 0o100000000000000000000000000000001 -} [expr 0x1000000000000000000000001] + expr {0o100000000000000000000000000000001} +} [expr {0x1000000000000000000000001}] test expr-41.1 {exponent overflow} { - expr 1.0e2147483630 + expr {1.0e2147483630} } Inf test expr-41.2 {exponent underflow} { - expr 1.0e-2147483630 + expr {1.0e-2147483630} } 0.0 test expr-42.1 {denormals} ieeeFloatingPoint { - expr 7e-324 + expr {7e-324} } 5e-324 # TIP 114 test expr-43.1 {0b notation} { - expr 0b0 + expr {0b0} } 0 test expr-43.2 {0b notation} { - expr 0b1 + expr {0b1} } 1 test expr-43.3 {0b notation} { - expr 0b10 + expr {0b10} } 2 test expr-43.4 {0b notation} { - expr 0b11 + expr {0b11} } 3 test expr-43.5 {0b notation} { - expr 0b100 + expr {0b100} } 4 test expr-43.6 {0b notation} { - expr 0b101 + expr {0b101} } 5 test expr-43.7 {0b notation} { - expr 0b1000 + expr {0b1000} } 8 test expr-43.8 {0b notation} { - expr 0b1001 + expr {0b1001} } 9 test expr-43.9 {0b notation} { expr 0b1[string repeat 0 31] @@ -6874,31 +6871,31 @@ test expr-43.13 {0b notation} { } 18446744073709551617 test expr-44.1 {0o notation} { - expr 0o0 + expr {0o0} } 0 test expr-44.2 {0o notation} { - expr 0o1 + expr {0o1} } 1 test expr-44.3 {0o notation} { - expr 0o7 + expr {0o7} } 7 test expr-44.4 {0o notation} { - expr 0o10 + expr {0o10} } 8 test expr-44.5 {0o notation} { - expr 0o11 + expr {0o11} } 9 test expr-44.6 {0o notation} { - expr 0o100 + expr {0o100} } 64 test expr-44.7 {0o notation} { - expr 0o101 + expr {0o101} } 65 test expr-44.8 {0o notation} { - expr 0o1000 + expr {0o1000} } 512 test expr-44.9 {0o notation} { - expr 0o1001 + expr {0o1001} } 513 test expr-44.10 {0o notation} { expr 0o1[string repeat 7 21] @@ -6913,25 +6910,25 @@ test expr-44.12 {0o notation} { # TIP 237 again test expr-45.1 {entier} { - expr entier(0) + expr {entier(0)} } 0 test expr-45.2 {entier} { - expr entier(0.5) + expr {entier(0.5)} } 0 test expr-45.3 {entier} { - expr entier(1.0) + expr {entier(1.0)} } 1 test expr-45.4 {entier} { - expr entier(1.5) + expr {entier(1.5)} } 1 test expr-45.5 {entier} { - expr entier(2.0) + expr {entier(2.0)} } 2 test expr-45.6 {entier} { - expr entier(1e+22) + expr {entier(1e+22)} } 10000000000000000000000 test expr-45.7 {entier} { - list [catch {expr entier(Inf)} result] $result + list [catch {expr { entier (Inf)}} result] $result } {1 {integer value too large to represent}} test expr-45.8 {entier} ieeeFloatingPoint { list [catch {expr {entier($ieeeValues(NaN))}} result] $result @@ -6941,7 +6938,7 @@ test expr-45.9 {entier} ieeeFloatingPoint { } {1 {floating point value is Not a Number}} test expr-46.1 {round() rounds to +-infinity} { - expr round(0.5) + expr {round(0.5)} } 1 test expr-46.2 {round() rounds to +-infinity} { expr round(1.5) @@ -7021,7 +7018,7 @@ test expr-46.14 {round() boundary case - round up} { test expr-46.15 {round() boundary case - round up to wide} { expr {round(2147483647 + 0.50)} -} [expr {wide(2147483647) + 1}] +} [expr { ( wide (2147483647) ) + 1}] test expr-46.16 {round() boundary case - round up} { expr {round(-2147483648 + 0.51)} @@ -7032,7 +7029,7 @@ test expr-46.17 {round() boundary case - round down} { } -2147483648 test expr-46.18 {round() boundary case - round down to wide} { expr {round(-2147483648 - 0.50)} -} [expr {wide(-2147483648) - 1}] +} [expr { ( wide (-2147483648) ) - 1}] test expr-46.19 {round() handling of long/bignum boundary} { expr {round(double(0x7fffffffffffffff))} @@ -7171,7 +7168,7 @@ test expr-49.1 {Bug 2823282} { } 1 test expr-50.1 {test sqrt() of bignums with non-Inf answer} { - expr {sqrt("1[string repeat 0 616]") == 1e308} + expr { sqrt ("1[string repeat 0 616]") == 1e308} } 1 @@ -7180,8 +7177,7 @@ test expr-50.1 {test sqrt() of bignums with non-Inf answer} { if {[info exists a]} { unset a } -catch {unset min} -catch {unset max} +unset -nocomplain min max ::tcltest::cleanupTests return diff --git a/tests/fCmd.test b/tests/fCmd.test index 325b374..c93b121 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -53,20 +53,20 @@ if {[testConstraint unix]} { testConstraint foundGroup 1 } - proc dev dir { + proc dev {dir} { file stat $dir stat return $stat(dev) } - if {[catch {makeDirectory tcl[pid] /tmp} tmpspace] == 0} { - testConstraint xdev [expr {([dev .] != [dev $tmpspace])}] + if {[catch {::tcltest::makeDirectory tcl[pid] /tmp} tmpspace] == 0} { + ::tcltest::testConstraint xdev [expr {([dev .] != [dev $tmpspace])}] } } # Also used in winFCmd... if {[testConstraint win]} { set major [string index $tcl_platform(osVersion) 0] - if {[testConstraint nt] && $major > 4} { + if {[testConstraint nt] && ($major > 4)} { if {$major > 5} { testConstraint winVista 1 } elseif {$major == 5} { @@ -76,9 +76,9 @@ if {[testConstraint win]} { } testConstraint darwin9 [expr { - [testConstraint unix] - && $tcl_platform(os) eq "Darwin" - && [package vsatisfies 1.$tcl_platform(osVersion) 1.9] + [testConstraint unix] && + ($tcl_platform(os) eq "Darwin") && + [package vsatisfies 1.$tcl_platform(osVersion) 1.9] }] testConstraint notDarwin9 [expr {![testConstraint darwin9]}] @@ -95,7 +95,7 @@ if {[testConstraint unix]} { } if {$user eq ""} { catch { - regexp {^[^(]*\(([^)]*)\)} [exec id] -> user + regexp {^[^(]*\(([^)]*)\)} [exec id] ___ user } } if {$user eq ""} { @@ -117,10 +117,11 @@ proc createfile {file {string a}} { # if the file does not exist, or has a different content # proc checkcontent {file matchString} { + set fileString "" try { set f [open $file] - set fileString [read $f] - close $f + set fileString [chan read $f] + chan close $f } on error {} { return 0 } @@ -149,7 +150,7 @@ proc cleanup {args} { if { [catch {file delete -force -- $file}] && [testConstraint testchmod] - } then { + } { catch {openup $file} catch {file delete -force -- $file} } @@ -159,12 +160,11 @@ proc cleanup {args} { proc contents {file} { set f [open $file] - set r [read $f] - close $f + set r [chan read $f] + chan close $f return $r } - set root [lindex [file split [pwd]] 0] # A really long file name. @@ -2314,10 +2314,10 @@ test fCmd-27.6 {TclFileAttrsCmd - setting more than one option} -setup { } -result {} if { - [testConstraint win] && - ([string index $tcl_platform(osVersion) 0] < 5 - || [lindex [file system [temporaryDirectory]] 1] ne "NTFS") -} then { + [testConstraint win] && + (([string index $tcl_platform(osVersion) 0] < 5) || + ([lindex [file system [temporaryDirectory]] 1] ne "NTFS")) +} { testConstraint linkDirectory 0 testConstraint linkFile 0 } @@ -2334,12 +2334,12 @@ test fCmd-28.3 {file link} -returnCodes error -body { test fCmd-28.4 {file link} -returnCodes error -body { file link -abc b c } -result {bad switch "-abc": must be -symbolic or -hard} -cd [workingDirectory] -makeDirectory abc.dir -makeDirectory abc2.dir -makeFile contents abc.file -makeFile contents abc2.file -cd [temporaryDirectory] +cd [::tcltest::workingDirectory] +::tcltest::makeDirectory abc.dir +::tcltest::makeDirectory abc2.dir +::tcltest::makeFile contents abc.file +::tcltest::makeFile contents abc2.file +cd [::tcltest::temporaryDirectory] test fCmd-28.5 {file link: source already exists} -setup { cd [temporaryDirectory] } -constraints {linkDirectory} -body { @@ -2388,9 +2388,9 @@ test fCmd-28.9.1 {file link: success with file} -setup { } -cleanup { cd [workingDirectory] } -result {1 0 abc.file 2} -cd [temporaryDirectory] +cd [::tcltest::temporaryDirectory] catch {file delete -force abc.link} -cd [workingDirectory] +cd [::tcltest::workingDirectory] test fCmd-28.10 {file link: linking to nonexistent path} -setup { cd [temporaryDirectory] file delete -force abc.link @@ -2481,7 +2481,7 @@ test fCmd-28.15.2 {file link: copies link not dir} -setup { } -cleanup { cd [workingDirectory] } -result {link abc.dir} -cd [temporaryDirectory] +cd [::tcltest::temporaryDirectory] file delete -force abc.link file delete -force abc2.link cd abc.dir @@ -2490,7 +2490,7 @@ file delete -force abc2.file cd .. file copy abc.file abc.dir file copy abc2.file abc.dir -cd [workingDirectory] +cd [::tcltest::workingDirectory] test fCmd-28.16 {file link: glob inside link} -setup { cd [temporaryDirectory] file delete -force abc.link @@ -2559,10 +2559,10 @@ try { } finally { cd [workingDirectory] } -removeFile abc2.file -removeFile abc.file -removeDirectory abc2.dir -removeDirectory abc.dir +::tcltest::removeFile abc2.file +::tcltest::removeFile abc.file +::tcltest::removeDirectory abc2.dir +::tcltest::removeDirectory abc.dir test fCmd-29.1 {weird memory corruption fault} -body { open [file join ~a_totally_bogus_user_id/foo bar] @@ -2592,8 +2592,8 @@ test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints {win} -body { # cleanup cleanup -if {[testConstraint unix]} { - removeDirectory tcl[pid] /tmp +if {[::tcltest::testConstraint unix]} { + ::tcltest::removeDirectory tcl[pid] /tmp } ::tcltest::cleanupTests return diff --git a/tests/fileName.test b/tests/fileName.test index 51f00d1..e256815 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -23,8 +23,8 @@ testConstraint testtranslatefilename [llength [info commands testtranslatefilena testConstraint linkDirectory 1 testConstraint symbolicLinkFile 1 if {[testConstraint win]} { - if {[string index $tcl_platform(osVersion) 0] < 5 \ - || [lindex [file system [temporaryDirectory]] 1] ne "NTFS"} { + if {([string index $tcl_platform(osVersion) 0] < 5) || + ([lindex [file system [temporaryDirectory]] 1] ne "NTFS")} { testConstraint linkDirectory 0 } testConstraint symbolicLinkFile 0 @@ -38,7 +38,7 @@ customMatch compareWords {apply {{a b} { expr {$a eq "equal" ? $w1 eq $w2 : $w1 ne $w2} }}} -proc touch filename {catch {close [open $filename w]}} +proc touch {filename} {catch {chan close [open $filename w]}} global env if {[testConstraint testsetplatform]} { set platform [testgetplatform] @@ -915,7 +915,7 @@ test filename-11.21.1 {Tcl_GlobCmd} -body { # Get rid of file/dir if it exists, since it will have been left behind by a # previous failed run. if {[file exists $horribleglobname]} { - file delete -force $horribleglobname + file delete -force -- $horribleglobname } file rename globTest $horribleglobname set globname $horribleglobname @@ -1076,24 +1076,24 @@ test filename-11.49 {Tcl_GlobCmd} -returnCodes error -body { glob -types abcde -path foo -join * * } -result {bad argument to "-types": abcde} -file rename $horribleglobname globTest +file rename -- $horribleglobname globTest set globname globTest unset horribleglobname test filename-12.1 {simple globbing} {unixOrPc} { - glob {} + glob "" } {.} test filename-12.1.1 {simple globbing} -constraints {unixOrPc} -body { - glob -types f {} + glob -types f "" } -returnCodes error -result {no files matched glob pattern ""} test filename-12.1.2 {simple globbing} {unixOrPc} { - glob -types d {} + glob -types d "" } {.} test filename-12.1.3 {simple globbing} {unix} { - glob -types hidden {} + glob -types hidden "" } {.} test filename-12.1.4 {simple globbing} -constraints {win} -body { - glob -types hidden {} + glob -types hidden "" } -returnCodes error -result {no files matched glob pattern ""} test filename-12.1.5 {simple globbing} -constraints {win} -body { glob -types hidden c:/ @@ -1141,7 +1141,7 @@ test filename-12.10 {globbing with volume relative paths} -setup { test filename-13.1 {globbing with brace substitution} { glob globTest/\{\} -} "$globPreResult" +} $globPreResult test filename-13.2 {globbing with brace substitution} -body { glob globTest/\{ } -returnCodes error -result {unmatched open-brace in file name} @@ -1620,9 +1620,9 @@ catch {removeDirectory tcl[pid]} set env(HOME) $oldhome if {[testConstraint testsetplatform]} { testsetplatform $platform - catch {unset platform} + unset -nocomplain platform } -catch {unset oldhome temp result globPreResult} +unset -nocomplain oldhome temp result globPreResult ::tcltest::cleanupTests return diff --git a/tests/fileSystem.test b/tests/fileSystem.test index b098f35..e46e411 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -16,7 +16,7 @@ namespace eval ::tcl::test::fileSystem { catch { file delete -force link.file file delete -force dir.link - file delete -force [file join dir.dir linkinside.file] + file delete -force -- [file join dir.dir linkinside.file] } testConstraint loaddll 0 @@ -252,7 +252,7 @@ file delete -force dir2.file file delete -force dir2.link file delete -force link.file dir.link file delete -force dir2 -file delete -force [file join dir.dir dirinside.link] +file delete -force -- [file join dir.dir dirinside.link] removeFile [file join dir.dir inside.file] removeDirectory [file join dir.dir dirinside.dir] removeDirectory dir.dir diff --git a/tests/for-old.test b/tests/for-old.test index a11a791..6f1a76f 100644 --- a/tests/for-old.test +++ b/tests/for-old.test @@ -12,14 +12,14 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } # Check "for" and its use of continue and break. -catch {unset a i} +unset -nocomplain a i test for-old-1.1 {for tests} { set a {} for {set i 1} {$i<6} {set i [expr $i+1]} { diff --git a/tests/for.test b/tests/for.test index ff4dc0e..daad937 100644 --- a/tests/for.test +++ b/tests/for.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -24,7 +24,7 @@ test for-1.2 {TclCompileForCmd: error in initial command} -body { } -match glob -result {1 {wrong # args: should be "for start test next command"} {wrong # args: should be "for start test next command" while *ing "for {set}"}} -catch {unset i} +unset -nocomplain i test for-1.3 {TclCompileForCmd: missing test expression} { catch {for {set i 0}} msg set msg @@ -53,7 +53,7 @@ test for-1.8 {TclCompileForCmd: error compiling command body} -body { } -match glob -result {wrong # args: should be "set varName ?newValue?" while *ing "set"*} -catch {unset a} +unset -nocomplain a test for-1.9 {TclCompileForCmd: simple command body} { set a {} for {set i 1} {$i<6} {set i [expr $i+1]} { @@ -68,9 +68,7 @@ test for-1.10 {TclCompileForCmd: command body in quotes} { set a } {xxxxx} test for-1.11 {TclCompileForCmd: computed command body} { - catch {unset x1} - catch {unset bb} - catch {unset x2} + unset -nocomplain x1 bb x2 set x1 {append a x1; } set bb {break} set x2 {; append a x2} @@ -89,27 +87,27 @@ test for-1.13 {TclCompileForCmd: long command body} { for {set i 1} {$i<6} {set i [expr $i+1]} { if $i==4 break if $i>5 continue - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg @@ -168,27 +166,27 @@ test for-2.6 {continue tests, long command body} { if $i==2 continue if $i==4 break if $i>5 continue - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg @@ -244,28 +242,28 @@ test for-3.5 {break tests, long command body} { if $i==2 continue if $i==5 break if $i>5 continue - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } if $i==4 break - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg @@ -356,9 +354,7 @@ proc formatMail {} { set quote 0 } set breakrange {6.42 78.0} - set F1 [lindex $breakrange 0] - set F2 [lindex $breakrange 1] - set breakrange [lrange $breakrange 2 end] + set breakrange [lassign $breakrange F1 F2] if {[string length $F1] == 0} { set F1 -1 set break 0 @@ -382,7 +378,7 @@ proc formatMail {} { continue } } - if $inheaders { + if {$inheaders} { set limit 55 } else { set limit 55 @@ -390,18 +386,16 @@ proc formatMail {} { # Decide whether or not to break the body line if {$plen > 0} { - if {[string first {> } $line] == 0} { + if {[string first "> " $line] == 0} { # This is quoted text from previous message, don't reformat append result $line $NL - if {$quote && !$inheaders} { + if {$quote && (!$inheaders)} { # Fix from <sarr@umich.edu> to handle text/enriched - if {$L > $L1 && $L < $L2 && $line != {}} { + if {(($L > $L1) && ($L < $L2) && $line) ne ""} { # enriched requires two newlines for each one. append result $NL } elseif {$L > $L2} { - set L1 [lindex $ranges 0] - set L2 [lindex $ranges 1] - set ranges [lrange $ranges 2 end] + set ranges [lassign $ranges L1 L2] set quote [llength $L1] } } @@ -418,9 +412,7 @@ proc formatMail {} { continue } elseif {$L > $F2} { # Past formatted block - set F1 [lindex $breakrange 0] - set F2 [lindex $breakrange 1] - set breakrange [lrange $breakrange 2 end] + set breakrange [lassign $breakrange F1 F2] append result $line $NL if {[string length $F1] == 0} { set F1 -1 @@ -428,23 +420,23 @@ proc formatMail {} { continue } } - set climit [expr $limit-1] + set climit [expr {$limit - 1}] set cutoff 50 set continuation 0 while {[string length $line] > $limit} { - for {set c [expr $limit-1]} {$c >= $cutoff} {incr c -1} { + for {set c [expr {$limit - 1}]} {$c >= $cutoff} {incr c -1} { set char [string index $line $c] - if {$char == " " || $char == "\t"} { + if {($char eq " ") || ($char eq "\t")} { break } - if {$char == ">"} { ;# Hack for enriched formatting + if {$char eq ">"} { ;# Hack for enriched formatting break } } if {$c < $cutoff} { - if {! $inheaders} { - set c [expr $limit-1] + if {!$inheaders} { + set c [expr {$limit - 1}] } else { set c [string length $line] } @@ -468,14 +460,12 @@ proc formatMail {} { } } else { append result $line $NL - if {$quote && !$inheaders} { - if {$L > $L1 && $L < $L2 && $line != {}} { + if {$quote && (!$inheaders)} { + if {($L > $L1) && ($L < $L2) && ($line ne "")} { # enriched requires two newlines for each one. append result "" $NL } elseif {$L > $L2} { - set L1 [lindex $ranges 0] - set L2 [lindex $ranges 1] - set ranges [lrange $ranges 2 end] + set ranges [lassign $ranges L1 L2] set quote [llength $L1] } } @@ -594,10 +584,9 @@ test for-4.1 {break must reset the interp result} { test for-5.1 {possible delayed substitution of increment command} { # Increment should be 5, and lappend should always append $a - catch {unset a} - catch {unset i} + unset -nocomplain a i set a 5 - set i {} + set i [list] for {set a 1} {$a < 12} "incr a $a" {lappend i $a} set i } {1 6 11} @@ -607,7 +596,7 @@ test for-5.2 {possible delayed substitution of increment command} { catch {rename p ""} proc p {} { set a 5 - set i {} + set i [list] for {set a 1} {$a < 12} "incr a $a" {lappend i $a} set i } @@ -616,7 +605,7 @@ test for-5.2 {possible delayed substitution of increment command} { test for-5.3 {possible delayed substitution of body command} { # Increment should be $a, and lappend should always append 5 set a 5 - set i {} + set i "" for {set a 1} {$a < 12} {incr a $a} "lappend i $a" set i } {5 5 5 5} @@ -625,7 +614,7 @@ test for-5.4 {possible delayed substitution of body command} { catch {rename p ""} proc p {} { set a 5 - set i {} + set i [list] for {set a 1} {$a < 12} {incr a $a} "lappend i $a" set i } @@ -708,14 +697,12 @@ test for-6.11 {Tcl_ForObjCmd: command body in quotes} { } {xxxxx} test for-6.12 {Tcl_ForObjCmd: computed command body} { set z for - catch {unset x1} - catch {unset bb} - catch {unset x2} + unset -nocomplain x1 bb x2 set x1 {append a x1; } set bb {break} set x2 {; append a x2} - set a {} - $z {set i 1} {$i<6} {set i [expr $i+1]} $x1$bb$x2 + set a "" + $z {set i 1} {$i < 6} {set i [expr {$i + 1}]} $x1$bb$x2 set a } {x1} test for-6.13 {Tcl_ForObjCmd: error in "next" command} -body { @@ -734,27 +721,27 @@ test for-6.14 {Tcl_ForObjCmd: long command body} { $z {set i 1} {$i<6} {set i [expr $i+1]} { if $i==4 break if $i>5 continue - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg diff --git a/tests/foreach.test b/tests/foreach.test index 6c69b29..c91cc98 100644 --- a/tests/foreach.test +++ b/tests/foreach.test @@ -10,18 +10,17 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } -catch {unset a} -catch {unset x} +unset -nocomplain a x # Basic "foreach" operation. test foreach-1.1 {basic foreach tests} { - set a {} + set a "" foreach i {a b c d} { set a [concat $a $i] } @@ -67,9 +66,9 @@ test foreach-1.12 {foreach errors} { test foreach-1.13 {foreach errors} { list [catch {foreach a {{1 2}3} {}} msg] $msg } {1 {list element in braces followed by "3" instead of space}} -catch {unset a} +unset -nocomplain a test foreach-1.14 {foreach errors} { - catch {unset a} + unset -nocomplain a set a(0) 44 list [catch {foreach a {1 2 3} {}} msg o] $msg $::errorInfo } {1 {can't set "a": variable is array} {can't set "a": variable is array @@ -79,7 +78,7 @@ test foreach-1.14 {foreach errors} { test foreach-1.15 {foreach errors} { list [catch {foreach {} {} {}} msg] $msg } {1 {foreach varlist is empty}} -catch {unset a} +unset -nocomplain a test foreach-2.1 {parallel foreach tests} { set x {} @@ -148,7 +147,7 @@ test foreach-2.9 {foreach only supports local scalar variables} { } {1 2 3 4} test foreach-3.1 {compiled foreach backward jump works correctly} { - catch {unset x} + unset -nocomplain x proc foo {arrayName} { upvar 1 $arrayName a set l {} @@ -162,7 +161,7 @@ test foreach-3.1 {compiled foreach backward jump works correctly} { } [lsort {{0 zero} {1 one} {2 two} {3 three}}] test foreach-4.1 {noncompiled foreach and shared variable or value list objects that are converted to another type} { - catch {unset x} + unset -nocomplain x foreach {12.0} {a b c} { set x 12.0 set x [expr $x + 1] @@ -176,7 +175,7 @@ test foreach-5.1 {continue tests} {catch continue} 4 test foreach-5.2 {continue tests} { set a {} foreach i {a b c d} { - if {[string compare $i "b"] == 0} continue + if {$i eq "b"} continue set a [concat $a $i] } set a @@ -184,7 +183,7 @@ test foreach-5.2 {continue tests} { test foreach-5.3 {continue tests} { set a {} foreach i {a b c d} { - if {[string compare $i "b"] != 0} continue + if {$i ne "b"} continue set a [concat $a $i] } set a @@ -201,7 +200,7 @@ test foreach-6.1 {break tests} {catch break} 3 test foreach-6.2 {break tests} { set a {} foreach i {a b c d} { - if {[string compare $i "c"] == 0} break + if {$i eq "c"} break set a [concat $a $i] } set a @@ -276,8 +275,7 @@ test foreach-11.2 {error then dereference loop var (dev bug)} { } 1 # cleanup -catch {unset a} -catch {unset x} -catch {rename foo {}} +unset -nocomplain a x +catch {rename foo ""} ::tcltest::cleanupTests return diff --git a/tests/format.test b/tests/format.test index 27eac31..83c2ace 100644 --- a/tests/format.test +++ b/tests/format.test @@ -10,17 +10,17 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } # %u output depends on word length, so this test is not portable. -testConstraint longIs32bit [expr {int(0x80000000) < 0}] -testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] +testConstraint longIs32bit [expr { ( int (0x80000000) ) < 0}] +testConstraint longIs64bit [expr { ( int (0x8000000000000000) ) < 0}] testConstraint wideIs64bit \ - [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] -testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}] + [expr {( ( wide (0x80000000) ) > 0) && ( ( wide (0x8000000000000000) ) < 0)}] +testConstraint wideBiggerThanInt [expr { ( wide (0x80000000) ) != ( int (0x80000000) )}] test format-1.1 {integer formatting} { format "%*d %d %d %d" 6 34 16923 -12 -1 @@ -429,10 +429,7 @@ test format-12.1 {negative width specifiers} { } {25 } test format-13.1 {tcl_precision fuzzy comparison} { - catch {unset a} - catch {unset b} - catch {unset c} - catch {unset d} + unset -nocomplain a b c d set a 0.0000000000001 set b 0.00000000000001 set c 0.00000000000000001 @@ -440,10 +437,7 @@ test format-13.1 {tcl_precision fuzzy comparison} { format {%0.10f %0.12f %0.15f %0.17f} $d $d $d $d } {0.0000000000 0.000000000000 0.000000000000110 0.00000000000011001} test format-13.2 {tcl_precision fuzzy comparison} { - catch {unset a} - catch {unset b} - catch {unset c} - catch {unset d} + unset -nocomplain a b c d set a 0.000000000001 set b 0.000000000000005 set c 0.0000000000000008 @@ -451,27 +445,21 @@ test format-13.2 {tcl_precision fuzzy comparison} { format {%0.10f %0.12f %0.15f %0.17f} $d $d $d $d } {0.0000000000 0.000000000001 0.000000000001006 0.00000000000100580} test format-13.3 {tcl_precision fuzzy comparison} { - catch {unset a} - catch {unset b} - catch {unset c} + unset -nocomplain a b c set a 0.00000000000099 set b 0.000000000000011 set c [expr $a + $b] format {%0.10f %0.12f %0.15f %0.17f} $c $c $c $c } {0.0000000000 0.000000000001 0.000000000001001 0.00000000000100100} test format-13.4 {tcl_precision fuzzy comparison} { - catch {unset a} - catch {unset b} - catch {unset c} + unset -nocomplain a b c set a 0.444444444444 set b 0.33333333333333 set c [expr $a + $b] format {%0.10f %0.12f %0.15f %0.16f} $c $c $c $c } {0.7777777778 0.777777777777 0.777777777777330 0.7777777777773300} test format-13.5 {tcl_precision fuzzy comparison} { - catch {unset a} - catch {unset b} - catch {unset c} + unset -nocomplain a b c set a 0.444444444444 set b 0.99999999999999 set c [expr $a + $b] @@ -510,7 +498,7 @@ for {set i 0} {$i < 290} {incr i} { append b $a } for {set i 290} {$i < 400} {incr i} { - test format-16.[expr $i -289] {testing MAX_FLOAT_SIZE} { + test format-16.[expr {$i - 289}] {testing MAX_FLOAT_SIZE} { format {%s} $b } $b append b "x" @@ -569,10 +557,7 @@ test format-20.1 {Bug 2932421: plain %s caused intrep change of args} -body { } -match glob -result {value is a dict with *, string representation "*"} # cleanup -catch {unset a} -catch {unset b} -catch {unset c} -catch {unset d} +unset -nocomplain a b c d ::tcltest::cleanupTests return diff --git a/tests/get.test b/tests/get.test index d51ec6d..699be4b 100644 --- a/tests/get.test +++ b/tests/get.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -19,8 +19,8 @@ if {[lsearch [namespace children] ::tcltest] == -1} { catch [list package require -exact Tcltest [info patchlevel]] testConstraint testgetint [llength [info commands testgetint]] -testConstraint longIs32bit [expr {int(0x80000000) < 0}] -testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] +testConstraint longIs32bit [expr { ( int (0x80000000) ) < 0}] +testConstraint longIs64bit [expr { ( int (0x8000000000000000) ) < 0}] test get-1.1 {Tcl_GetInt procedure} testgetint { testgetint 44 { 22} diff --git a/tests/history.test b/tests/history.test index c562796..6c1c4c5 100644 --- a/tests/history.test +++ b/tests/history.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -129,7 +129,7 @@ test history-4.6 {change option} history { catch {history change Foo [expr {[history n]-4}]} } 1 if {[testConstraint history]} { - set num [expr {[history n]-4}] + set num [expr {[history n] - 4}] } test history-4.7 {change option} history { catch {history change Foo $num} msg @@ -149,11 +149,11 @@ test history-5.1 {info option} history {history info} [format {%6d set a {b %6d set b 1234 %6d set c {a b - c}} $num [expr $num+1] [expr $num+2]] + c}} $num [expr {$num + 1}] [expr {$num + 2}]] test history-5.2 {info option} history {history i 2} [format {%6d set b 1234 %6d set c {a b - c}} [expr $num+1] [expr $num+2]] + c}} [expr {$num + 1}] [expr {$num + 2}]] test history-5.3 {info option} history {catch {history i 2 3}} 1 test history-5.4 {info option} history { catch {history i 2 3} msg @@ -164,7 +164,7 @@ test history-5.5 {info option} history {history} [format {%6d set a {b %6d set b 1234 %6d set c {a b - c}} $num [expr $num+1] [expr $num+2]] + c}} $num [expr {$num + 1}] [expr {$num + 2}]] # "history keep" @@ -174,7 +174,7 @@ if {[testConstraint history]} { history add "foo3" history keep 2 } -test history-6.1 {keep option} history {history event [expr [history n]-1]} foo3 +test history-6.1 {keep option} history {history event [expr {[history n] - 1}]} foo3 test history-6.2 {keep option} history {history event -1} foo2 test history-6.3 {keep option} history {catch {history event -3}} 1 test history-6.4 {keep option} history { @@ -216,7 +216,7 @@ if {[testConstraint history]} { history add "Testing2" } test history-7.1 {nextid option} history {history event} "Testing" -test history-7.2 {nextid option} history {history next} [expr $num+2] +test history-7.2 {nextid option} history {history next} [expr {$num + 2}] test history-7.3 {nextid option} history {catch {history nextid garbage}} 1 test history-7.4 {nextid option} history { catch {history nextid garbage} msg diff --git a/tests/http.test b/tests/http.test index e2de7d8..cd64f6d 100644 --- a/tests/http.test +++ b/tests/http.test @@ -38,7 +38,7 @@ proc bgerror {args} { set port 8010 set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null" -catch {unset data} +unset -nocomplain data # Ensure httpd file exists @@ -46,13 +46,13 @@ set origFile [file join [pwd] [file dirname [info script]] httpd] set httpdFile [file join [temporaryDirectory] httpd_[pid]] if {![file exists $httpdFile]} { makeFile "" $httpdFile - file delete $httpdFile - file copy $origFile $httpdFile + file delete -- $httpdFile + file copy -- $origFile $httpdFile set removeHttpd 1 } catch {package require Thread 2.7-} -if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} { +if {(![catch {package present Thread}]) && [file exists $httpdFile]} { set httpthread [thread::create -preserved] thread::send $httpthread [list source $httpdFile] thread::send $httpthread [list set port $port] @@ -72,7 +72,7 @@ if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} { unset port return } else { - set port [lindex [fconfigure $listen -sockname] 2] + set port [lindex [chan configure $listen -sockname] 2] } } @@ -246,12 +246,12 @@ test http-3.11 {http::geturl querychannel with -command} -setup { set testRes [list [http::status $t] [string length $query] [http::data $t]] # Now do async http::cleanup $t - close $fp + chan close $fp set fp [open $file] set t [http::geturl $posturl -querychannel $fp -command asyncCB] set postResult [list PostStart] http::wait $t - close $fp + chan close $fp lappend testRes [http::status $t] $postResult } -cleanup { removeFile outdata @@ -433,12 +433,12 @@ test http-4.4 {http::Event} -setup { } -body { set out [open $testfile w] set token [http::geturl $url -channel $out] - close $out + chan close $out set in [open $testfile] set x [read $in] } -cleanup { - catch {close $in} - catch {close $out} + catch {chan close $in} + catch {chan close $out} removeFile $testfile http::cleanup $token } -result "<html><head><title>HTTP/1.0 TEST</title></head><body> @@ -449,9 +449,9 @@ test http-4.5 {http::Event} -setup { set testfile [makeFile "" testfile] } -body { set out [open $testfile w] - fconfigure $out -translation lf + chan configure $out -translation lf set token [http::geturl $url -channel $out] - close $out + chan close $out upvar #0 $token data expr {$data(currentsize) == $data(totalsize)} } -cleanup { @@ -463,13 +463,13 @@ test http-4.6 {http::Event} -setup { } -body { set out [open $testfile w] set token [http::geturl $binurl -channel $out] - close $out + chan close $out set in [open $testfile] - fconfigure $in -translation binary + chan configure $in -translation binary read $in } -cleanup { - catch {close $in} - catch {close $out} + catch {chan close $in} + catch {chan close $out} removeFile $testfile http::cleanup $token } -result "$bindata[string trimleft $binurl /]" @@ -480,7 +480,7 @@ proc myProgress {token total current} { } set progress [list $total $current] } -if 0 { +if {0} { # This test hangs on Windows95 because the client never gets EOF set httpLog 1 test http-4.6.1 {http::Event} knownBug { @@ -624,14 +624,11 @@ test http-7.4 {http::formatQuery} -setup { } -result {%3F} # cleanup -catch {unset url} -catch {unset badurl} -catch {unset port} -catch {unset data} +unset -nocomplain url badurl port data if {[info exists httpthread]} { thread::release $httpthread } else { - close $listen + chan close $listen } if {[info exists removeHttpd]} { diff --git a/tests/http11.test b/tests/http11.test index 230ce5a..7e78c5b 100644 --- a/tests/http11.test +++ b/tests/http11.test @@ -17,21 +17,21 @@ variable httpd_output proc create_httpd {} { proc httpd_read {chan} { variable httpd_output - if {[gets $chan line] != -1} { + if {[chan gets $chan line] != -1} { #puts stderr "read '$line'" set httpd_output $line } - if {[eof $chan]} { - puts stderr "eof from httpd" - fileevent $chan readable {} - close $chan + if {[chan eof $chan]} { + chan puts stderr "eof from httpd" + chan event $chan readable "" + chan close $chan } } variable httpd_output set httpd_script [file join [pwd] [file dirname [info script]] httpd11.tcl] set httpd [open "|[list [interpreter] -encoding utf-8 $httpd_script]" r+] - fconfigure $httpd -buffering line -blocking 0 - fileevent $httpd readable [list httpd_read $httpd] + chan configure $httpd -buffering line -blocking 0 + chan event $httpd readable [list httpd_read $httpd] vwait httpd_output variable httpd_port [lindex $httpd_output 2] return $httpd diff --git a/tests/httpd b/tests/httpd index f810797..5546a4a 100644 --- a/tests/httpd +++ b/tests/httpd @@ -37,7 +37,7 @@ proc httpdAccept {newsock ipaddr port} { global httpd upvar #0 httpd$newsock data - fconfigure $newsock -blocking 0 -translation {auto crlf} + chan configure $newsock -blocking 0 -translation {auto crlf} httpd_log $newsock Connect $ipaddr $port set data(ipaddr) $ipaddr fileevent $newsock readable [list httpdRead $newsock] @@ -65,7 +65,7 @@ proc httpdRead { sock } { httpdSockDone $sock } return - } elseif {$data(state) == "mime"} { + } elseif {$data(state) eq "mime"} { # Read the HTTP headers @@ -74,7 +74,7 @@ proc httpdRead { sock } { lappend data(meta) $key [string trim $val] } - } elseif {$data(state) == "query"} { + } elseif {$data(state) eq "query"} { # Read the query data @@ -194,7 +194,7 @@ proc httpdRespond { sock } { append html "<h2>Query</h2>\n<dl>\n" foreach {key value} [split $data(query) &=] { append html "<dt>$key<dd>$value\n" - if {$key == "timeout"} { + if {$key eq "timeout"} { after $value ;# pause } } @@ -207,7 +207,7 @@ proc httpdRespond { sock } { # Catch errors from premature client closes catch { - if {$data(proto) == "HEAD"} { + if {$data(proto) eq "HEAD"} { puts $sock "HTTP/1.0 200 OK" } else { # Split the response to test for [Bug 26245326] @@ -226,8 +226,8 @@ proc httpdRespond { sock } { } puts $sock "" flush $sock - if {$data(proto) != "HEAD"} { - fconfigure $sock -translation binary + if {$data(proto) ne "HEAD"} { + chan configure $sock -translation binary puts -nonewline $sock $html } } diff --git a/tests/httpd11.tcl b/tests/httpd11.tcl index 9c543dc..64601a9 100644 --- a/tests/httpd11.tcl +++ b/tests/httpd11.tcl @@ -38,11 +38,12 @@ proc make-chunk-generator {data {size 4096}} { return $name } -proc get-chunks {data {compression gzip}} { +proc get-chunks {a_data {compression gzip}} { switch -exact -- $compression { - gzip { set data [zlib gzip $data] } - deflate { set data [zlib deflate $data] } - compress { set data [zlib compress $data] } + gzip { set data [zlib gzip $a_data] } + deflate { set data [zlib deflate $a_data] } + compress { set data [zlib compress $a_data] } + default { set data [zlib gzip $a_data] } } set data "" @@ -53,11 +54,12 @@ proc get-chunks {data {compression gzip}} { return $data } -proc blow-chunks {data {ochan stdout} {compression gzip}} { +proc blow-chunks {a_data {ochan stdout} {compression gzip}} { switch -exact -- $compression { - gzip { set data [zlib gzip $data] } - deflate { set data [zlib deflate $data] } - compress { set data [zlib compress $data] } + gzip { set data [zlib gzip $a_data] } + deflate { set data [zlib deflate $a_data] } + compress { set data [zlib compress $a_data] } + default { set data [zlib gzip $a_data] } } set chunker [make-chunk-generator $data 512] @@ -78,31 +80,42 @@ proc mime-type {filename} { .xhtml {return {text application/xml+html} } .svg { return {text image/svg+xml} } .txt - .tcl - .c - .h { return {text text/plain}} + default {return {binary text/plain}} } - return {binary text/plain} } -proc Puts {chan s} {puts $chan $s; puts $s} +proc Puts {chan s} { + puts $chan $s + puts $s +} proc Service {chan addr port} { chan event $chan readable [info coroutine] while {1} { - set meta {} + set meta [list] chan configure $chan -buffering line -encoding iso8859-1 -translation crlf chan configure $chan -blocking 0 yield - while {[gets $chan line] < 0} { - if {[eof $chan]} {chan event $chan readable {}; close $chan; return} + while {[chan gets $chan line] < 0} { + if {[chan eof $chan]} { + chan event $chan readable {} + chan close $chan + return + } yield } - if {[eof $chan]} {chan event $chan readable {}; close $chan; return} - foreach {req url protocol} {GET {} HTTP/1.1} break - regexp {^(\S+)\s+(.*)\s(\S+)?$} $line -> req url protocol - - puts $line - while {[gets $chan line] > 0} { - if {[regexp {^([^:]+):(.*)$} $line -> key val]} { - puts [list $key [string trim $val]] + if {[eof $chan]} { + chan event $chan readable {} + chan close $chan + return + } + lassign {GET {} HTTP/1.1} req url protocol + regexp {^(\S+)\s+(.*)\s(\S+)?$} $line ___ req url protocol + + chan puts $line + while {[chan gets $chan line] > 0} { + if {[regexp {^([^:]+):(.*)$} $line ___ key val]} { + chan puts [list $key [string trim $val]] lappend meta [string tolower $key] [string trim $val] } yield @@ -129,7 +142,7 @@ proc Service {chan addr port} { if {[string is integer -strict $qlen]} { chan configure $chan -buffering none -translation binary while {[string length $query] < $qlen} { - append query [read $chan $qlen] + append query [chan read $chan $qlen] if {[string length $query] < $qlen} {yield} } # Check for excess query bytes [Bug 2715421] @@ -148,11 +161,11 @@ proc Service {chan addr port} { set path [string trimleft $path /] set path [file join [pwd] $path] if {[file exists $path] && [file isfile $path]} { - foreach {what type} [mime-type $path] break + lassign [mime-type $path] what type set f [open $path r] if {$what eq "binary"} {chan configure $f -translation binary} - set data [read $f] - close $f + set data [chan read $f] + chan close $f set code "200 OK" set close [expr {[dict get? $meta connection] eq "close"}] } @@ -173,9 +186,13 @@ proc Service {chan addr port} { foreach pair [split $query &] { if {[scan $pair {%[^=]=%s} key val] != 2} {set val ""} switch -exact -- $key { - close {set close 1 ; set transfer 0} + close { + set close 1 + set transfer 0 + } transfer {set transfer $val} content-type {set type $val} + default {} } } @@ -197,27 +214,27 @@ proc Service {chan addr port} { if {$transfer eq "chunked"} { Puts $chan "transfer-encoding: chunked" } - puts $chan "" - flush $chan + chan puts $chan "" + chan flush $chan chan configure $chan -buffering full -translation binary if {$transfer eq "chunked"} { blow-chunks $data $chan $encoding } elseif {$encoding ne "identity"} { - puts -nonewline $chan [zlib $encoding $data] + chan puts -nonewline $chan [zlib $encoding $data] } else { - puts -nonewline $chan $data + chan puts -nonewline $chan $data } if {$close} { chan event $chan readable {} - close $chan - puts "close $chan" + chan close $chan + chan puts "close $chan" return } else { - flush $chan + chan flush $chan } - puts "pipeline $chan" + chan puts "pipeline $chan" } } diff --git a/tests/httpold.test b/tests/httpold.test index aeba311..1b40133 100644 --- a/tests/httpold.test +++ b/tests/httpold.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -34,7 +34,7 @@ if {[catch {package require http 1.0}]} { } set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null" -catch {unset data} +unset -nocomplain data ## ## The httpd script implement a stub http server @@ -42,7 +42,7 @@ catch {unset data} source [file join [file dirname [info script]] httpd] set port 8010 -if [catch {httpd_init $port} listen] { +if {[catch {httpd_init $port} listen]} { puts "Cannot start http server, http test skipped" unset port ::tcltest::cleanupTests @@ -156,7 +156,6 @@ test httpold-3.9 {http_get} { http_code $token } "HTTP/1.0 200 OK" - test httpold-4.1 {httpEvent} { set token [http_get $url] upvar #0 $token data @@ -207,7 +206,7 @@ test httpold-4.6 {httpEvent} { set token [http_get $binurl -channel $out] close $out set in [open $testfile] - fconfigure $in -translation binary + chan configure $in -translation binary set x [read $in] close $in removeFile $testfile @@ -221,7 +220,7 @@ proc myProgress {token total current} { } set progress [list $total $current] } -if 0 { +if {0} { # This test hangs on Windows95 because the client never gets EOF set httpLog 1 test httpold-4.6 {httpEvent} { @@ -285,9 +284,7 @@ test httpold-6.1 {httpProxyRequired} { </body></html>" # cleanup -catch {unset url} -catch {unset port} -catch {unset data} -close $listen +unset -nocomplain url port data +chan close $listen ::tcltest::cleanupTests return diff --git a/tests/if-old.test b/tests/if-old.test index fbcf56c..e08ec45 100644 --- a/tests/if-old.test +++ b/tests/if-old.test @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -60,12 +60,11 @@ test if-old-1.8 {taking proper branch} { } {4} test if-old-1.9 {taking proper branch, multiline test expr} { set a {} - if {($tcl_platform(platform) != "foobar1") && \ - ($tcl_platform(platform) != "foobar2")} {set a 3} else {set a 4} + if {($tcl_platform(platform) ne "foobar1") && + ($tcl_platform(platform) ne "foobar2")} {set a 3} else {set a 4} set a } {3} - test if-old-2.1 {optional then-else args} { set a 44 if 0 then {set a 1} elseif 0 then {set a 3} else {set a 2} diff --git a/tests/if.test b/tests/if.test index 040364a..9ef5c72 100644 --- a/tests/if.test +++ b/tests/if.test @@ -10,14 +10,14 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } # Basic "if" operation. -catch {unset a} +unset -nocomplain a test if-1.1 {TclCompileIfCmd: missing if/elseif test} -body { if } -returnCodes error -result {wrong # args: no expression after "if" argument} @@ -46,8 +46,8 @@ test if-1.5 {TclCompileIfCmd: if/elseif test not in braces} -body { test if-1.6 {TclCompileIfCmd: multiline test expr} -setup { set a {} } -body { - if {($tcl_platform(platform) != "foobar1") && \ - ($tcl_platform(platform) != "foobar2")} {set a 3} else {set a 4} + if {($tcl_platform(platform) ne "foobar1") && + ($tcl_platform(platform) ne "foobar2")} {set a 3} else {set a 4} return $a } -cleanup { unset a @@ -75,7 +75,7 @@ test if-1.9 {TclCompileIfCmd: missing "then" body} -setup { } -returnCodes error -result {wrong # args: no script following "then" argument} test if-1.10 {TclCompileIfCmd: error in "then" body} -body { set a {} - list [catch {if {$a!="xxx"} then {set}} msg] $msg $::errorInfo + list [catch {if {$a ne "xxx"} then {set}} msg] $msg $::errorInfo } -match glob -cleanup { unset a msg } -result {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?" @@ -92,8 +92,7 @@ test if-1.12 {TclCompileIfCmd: "then" body in quotes} -body { unset a } -result {x} test if-1.13 {TclCompileIfCmd: computed "then" body} -setup { - catch {unset x1} - catch {unset x2} + unset -nocomplain x1 x2 } -body { set x1 {append a x1} set x2 {; append a x2} @@ -104,7 +103,7 @@ test if-1.13 {TclCompileIfCmd: computed "then" body} -setup { unset a x1 x2 } -result {x1x2} test if-1.14 {TclCompileIfCmd: taking proper branch} -body { - set a {} + set a "" if 1<2 {set a 1} return $a } -cleanup { @@ -118,12 +117,12 @@ test if-1.15 {TclCompileIfCmd: taking proper branch} -body { unset a } -result {} test if-1.16 {TclCompileIfCmd: test jumpFalse instruction replacement after long "then" body} -setup { - catch {unset i} - set a {} + unset -nocomplain i + set a "" } -body { if 1<2 { set a 1 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { if {[string compare $a "bar"] < 0} { @@ -142,11 +141,11 @@ test if-1.16 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 2 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { if {[string compare $a "bar"] < 0} { @@ -165,7 +164,7 @@ test if-1.16 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 3 @@ -215,12 +214,12 @@ test if-2.4 {TclCompileIfCmd: error in expression after "elseif"} -setup { unset a msg } -result {1 * {*"if 3>4 {set a 1} elseif {1>}"}} test if-2.5 {TclCompileIfCmd: test jumpFalse instruction replacement after long "elseif" body} -setup { - catch {unset i} + unset -nocomplain i set a {} } -body { if 1>2 { set a 1 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { if {[string compare $a "bar"] < 0} { @@ -239,11 +238,11 @@ test if-2.5 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 2 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { if {[string compare $a "bar"] < 0} { @@ -262,13 +261,13 @@ test if-2.5 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 3 } elseif 1<2 then { #; this if arm should be taken set a 4 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { if {[string compare $a "bar"] < 0} { @@ -287,11 +286,11 @@ test if-2.5 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 5 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { if {[string compare $a "bar"] < 0} { @@ -310,7 +309,7 @@ test if-2.5 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 6 @@ -323,7 +322,7 @@ test if-2.5 {TclCompileIfCmd: test jumpFalse instruction replacement after long test if-3.1 {TclCompileIfCmd: "else" clause} -body { set a {} - if 3>4 {set a 1} elseif {$a == "foo"} {set a 2} else {set a 3} + if 3>4 {set a 1} elseif {$a eq "foo"} {set a 2} else {set a 3} return $a } -cleanup { unset a @@ -365,12 +364,12 @@ test if-3.5 {TclCompileIfCmd: extra arguments after "else" argument} -setup { # commands are properly relocated because a short jump must be replaced # by a "long distance" one. test if-3.6 {TclCompileIfCmd: test jumpFalse instruction replacement after long "else" clause} -setup { - catch {unset i} - set a {} + unset -nocomplain i + set a "" } -body { if 1>2 { set a 1 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { if {[string compare $a "bar"] < 0} { @@ -389,11 +388,11 @@ test if-3.6 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 2 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { if {[string compare $a "bar"] < 0} { @@ -412,13 +411,13 @@ test if-3.6 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 3 } elseif 1==2 then { #; this if arm should be taken set a 4 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { if {[string compare $a "bar"] < 0} { @@ -437,11 +436,11 @@ test if-3.6 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 5 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { if {[string compare $a "bar"] < 0} { @@ -460,13 +459,13 @@ test if-3.6 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 6 } else { set a 7 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { if {[string compare $a "bar"] < 0} { @@ -485,11 +484,11 @@ test if-3.6 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 8 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { if {[string compare $a "bar"] < 0} { @@ -508,7 +507,7 @@ test if-3.6 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 9 @@ -600,8 +599,8 @@ test if-5.5 {if cmd with computed command names: if/elseif test not in braces} - } -result {1} test if-5.6 {if cmd with computed command names: multiline test expr} -body { set z if - $z {($tcl_platform(platform) != "foobar1") && \ - ($tcl_platform(platform) != "foobar2")} {set a 3} else {set a 4} + $z {($tcl_platform(platform) ne "foobar1") && + ($tcl_platform(platform) ne "foobar2")} {set a 3} else {set a 4} return $a } -cleanup { unset a z @@ -634,14 +633,14 @@ test if-5.9 {if cmd with computed command names: missing "then" body} -setup { test if-5.10 {if cmd with computed command names: error in "then" body} -body { set z if set a {} - list [catch {$z {$a!="xxx"} then {set}} msg] $msg $::errorInfo + list [catch {$z {$a ne "xxx"} then {set}} msg] $msg $::errorInfo } -match glob -cleanup { unset a z msg } -result {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?" while *ing "set" invoked from within -"$z {$a!="xxx"} then {set}"}} +"$z {$a ne "xxx"} then {set}"}} test if-5.11 {if cmd with computed command names: error in "then" body} -body { set z if $z 2 then {[error "error in then clause"]} @@ -658,8 +657,7 @@ test if-5.12 {if cmd with computed command names: "then" body in quotes} -setup unset a z } -result {x} test if-5.13 {if cmd with computed command names: computed "then" body} -setup { - catch {unset x1} - catch {unset x2} + unset -nocomplain x1 x2 } -body { set z if set x1 {append a x1} @@ -688,13 +686,13 @@ test if-5.15 {if cmd with computed command names: taking proper branch} -body { unset a z } -result {} test if-5.16 {if cmd with computed command names: test jumpFalse instruction replacement after long "then" body} -setup { - catch {unset i} + unset -nocomplain i set a {} } -body { set z if $z 1<2 { set a 1 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { $z {[string compare $a "bar"] < 0} { @@ -713,11 +711,11 @@ test if-5.16 {if cmd with computed command names: test jumpFalse instruction rep set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 2 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { $z {[string compare $a "bar"] < 0} { @@ -736,7 +734,7 @@ test if-5.16 {if cmd with computed command names: test jumpFalse instruction rep set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 3 @@ -791,13 +789,13 @@ test if-6.4 {if cmd with computed command names: error in expression after "else unset a z } -result {1 {*"$z 3>4 {set a 1} elseif {1>}"}} test if-6.5 {if cmd with computed command names: test jumpFalse instruction replacement after long "elseif" body} -setup { - catch {unset i} + unset -nocomplain i set a {} } -body { set z if $z 1>2 { set a 1 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { $z {[string compare $a "bar"] < 0} { @@ -816,11 +814,11 @@ test if-6.5 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 2 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { $z {[string compare $a "bar"] < 0} { @@ -839,13 +837,13 @@ test if-6.5 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 3 } elseif 1<2 then { #; this if arm should be taken set a 4 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { $z {[string compare $a "bar"] < 0} { @@ -864,11 +862,11 @@ test if-6.5 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 5 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { $z {[string compare $a "bar"] < 0} { @@ -887,7 +885,7 @@ test if-6.5 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 6 @@ -902,7 +900,7 @@ test if-7.1 {if cmd with computed command names: "else" clause} -setup { set a {} } -body { set z if - $z 3>4 {set a 1} elseif {$a == "foo"} {set a 2} else {set a 3} + $z 3>4 {set a 1} elseif {$a eq "foo"} {set a 2} else {set a 3} return $a } -cleanup { unset a z @@ -950,13 +948,13 @@ test if-7.5 {if cmd with computed command names: extra arguments after "else" ar # commands are properly relocated because a short jump must be replaced # by a "long distance" one. test if-7.6 {if cmd with computed command names: test jumpFalse instruction replacement after long "else" clause} -setup { - catch {unset i} + unset -nocomplain i set a {} } -body { set z if $z 1>2 { set a 1 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { $z {[string compare $a "bar"] < 0} { @@ -975,11 +973,11 @@ test if-7.6 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 2 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { $z {[string compare $a "bar"] < 0} { @@ -998,13 +996,13 @@ test if-7.6 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 3 } elseif 1==2 then { #; this if arm should be taken set a 4 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { $z {[string compare $a "bar"] < 0} { @@ -1023,11 +1021,11 @@ test if-7.6 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 5 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { $z {[string compare $a "bar"] < 0} { @@ -1046,13 +1044,13 @@ test if-7.6 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 6 } else { set a 7 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { $z {[string compare $a "bar"] < 0} { @@ -1071,11 +1069,11 @@ test if-7.6 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 8 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { $z {[string compare $a "bar"] < 0} { @@ -1094,7 +1092,7 @@ test if-7.6 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 9 diff --git a/tests/incr-old.test b/tests/incr-old.test index ed457cf..d965a1b 100644 --- a/tests/incr-old.test +++ b/tests/incr-old.test @@ -13,12 +13,12 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } -catch {unset x} +unset -nocomplain x test incr-old-1.1 {basic incr operation} { set x 23 @@ -44,7 +44,7 @@ test incr-old-2.2 {incr errors} { list [catch {incr a b c} msg] $msg } {1 {wrong # args: should be "incr varName ?increment?"}} test incr-old-2.3 {incr errors} { - catch {unset x} + unset -nocomplain x incr x } 1 test incr-old-2.4 {incr errors} { @@ -69,7 +69,7 @@ test incr-old-2.6 {incr errors} -body { while executing * "incr x 1"}} -catch {unset x} +unset -nocomplain x test incr-old-2.7 {incr errors} { set x - list [catch {incr x 1} msg] $msg diff --git a/tests/incr.test b/tests/incr.test index 9243be0..02b9338 100644 --- a/tests/incr.test +++ b/tests/incr.test @@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} { } unset -nocomplain x i -proc readonly varName { +proc readonly {varName} { upvar 1 $varName var trace add variable var write \ {apply {{args} {error "variable is read-only"}}} @@ -230,7 +230,7 @@ test incr-1.29 {TclCompileIncrCmd: runtime error, bad variable value} -body { incr x 1 } -returnCodes error -result {expected integer but got " - "} test incr-1.30 {TclCompileIncrCmd: array var, braced (no subs)} -setup { - catch {unset array} + unset -nocomplain array } -body { set array(\$foo) 4 incr {array($foo)} diff --git a/tests/indexObj.test b/tests/indexObj.test index 646cb02..67b6ffb 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.test @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } diff --git a/tests/info.test b/tests/info.test index ebc853a..e6d737b 100644 --- a/tests/info.test +++ b/tests/info.test @@ -88,7 +88,7 @@ test info-2.4 {info body option} { # would then try and eval out of the foo context, accessing # compiled local indices test info-2.5 {info body option, returning bytecompiled bodies} -body { - catch {unset args} + unset -nocomplain args proc foo {args} { foreach v $args { upvar $v var @@ -111,7 +111,7 @@ proc testinfocmdcount {} { set x [info cmdcount] set y 12345 set z [info cm] - expr {$z-$x} + expr {$z - $x} } test info-3.1 {info cmdcount compiled} { testinfocmdcount @@ -136,9 +136,8 @@ test info-4.1 {info commands option} -body { } -cleanup {unset x} -result {1 1 1 1} test info-4.2 {info commands option} -body { proc t1 {} {} - rename t1 {} - string match {* t1 *} \ - [info comm] + rename t1 "" + string match "* t1 *" [info comm] } -result 0 test info-4.3 {info commands option} { proc _t1_ {} {} @@ -148,10 +147,10 @@ test info-4.3 {info commands option} { test info-4.4 {info commands option} { proc _t1_ {} {} proc _t2_ {} {} - lsort [info commands _t*] + lsort [info commands "_t*"] } {_t1_ _t2_} -catch {rename _t1_ {}} -catch {rename _t2_ {}} +catch {rename _t1_ ""} +catch {rename _t2_ ""} test info-4.5 {info commands option} -returnCodes error -body { info commands a b } -result {wrong # args: should be "info commands ?pattern?"} @@ -213,14 +212,14 @@ test info-6.8 {info default option} -returnCodes error -body { info default t1 x value } -result {procedure "t1" doesn't have an argument "x"} test info-6.9 {info default option} -returnCodes error -setup { - catch {unset a} + unset -nocomplain a } -cleanup {unset a} -body { set a(0) 88 proc t1 {a b} {} info default t1 a a } -returnCodes error -result {can't set "a": variable is array} test info-6.10 {info default option} -setup { - catch {unset a} + unset -nocomplain a } -cleanup {unset a} -body { set a(0) 88 proc t1 {{a 18} b} {} @@ -239,7 +238,7 @@ test info-7.1 {info exists option} -body { info exists value } -cleanup {unset value} -result 1 -test info-7.2 {info exists option} -setup {catch {unset _nonexistent_}} -body { +test info-7.2 {info exists option} -setup {unset -nocomplain _nonexistent_} -body { info exists _nonexistent_ } -result 0 test info-7.3 {info exists option} { @@ -265,12 +264,12 @@ test info-7.6 {info exists option} { t1 2 } 0 test info-7.7 {info exists option} -setup { - catch {unset x} + unset -nocomplain x } -body { set x(2) 44 list [info exists x] [info exists x(1)] [info exists x(2)] } -result {1 0 1} -catch {unset x} +unset -nocomplain x test info-7.8 {info exists option} -body { info exists } -returnCodes error -result {wrong # args: should be "info exists varName"} @@ -394,7 +393,8 @@ test info-10.3 {info library option} -body { unset tcl_library info library } -returnCodes error -result {no library has been specified for Tcl} -set tcl_library $savedLibrary; unset savedLibrary +set tcl_library $savedLibrary +unset savedLibrary test info-11.1 {info loaded option} -body { info loaded a b @@ -592,7 +592,8 @@ set gorpfile [makeFile {list [info script] [info script foo.bar]} gorp.info] test info-16.8 {info script option} { list [source $gorpfile] [file tail [info script]] } [list [list $gorpfile foo.bar] info.test] -removeFile gorp.info; unset gorpfile +removeFile gorp.info +unset gorpfile test info-17.1 {info sharedlibextension option} -returnCodes error -body { info sharedlibextension foo @@ -712,8 +713,9 @@ proc reduce {frame} { } return $frame } - -proc subinterp {} { interp create sub ; interp debug sub -frame 1; +proc subinterp {} { + interp create sub + interp debug sub -frame 1 interp eval sub [list proc reduce [info args reduce] [info body reduce]] } @@ -748,23 +750,23 @@ test info-22.2 {info frame, bad level absolute} {!singleTestInterp} { } {bad level "9"} test info-22.3 {info frame, current, relative} -match glob -body { info frame 0 -} -result {type source line 750 file */info.test cmd {info frame 0} proc ::tcltest::RunTest} +} -result {type source line 753 file */info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-22.4 {info frame, current, relative, nested} -match glob -body { set res [info frame 0] -} -result {type source line 753 file */info.test cmd {info frame 0} proc ::tcltest::RunTest} -cleanup {unset res} +} -result {type source line 756 file */info.test cmd {info frame 0} proc ::tcltest::RunTest} -cleanup {unset res} test info-22.5 {info frame, current, absolute} -constraints {!singleTestInterp} -match glob -body { reduce [info frame 7] -} -result {type source line 756 file info.test cmd {info frame 7} proc ::tcltest::RunTest} +} -result {type source line 759 file info.test cmd {info frame 7} proc ::tcltest::RunTest} test info-22.6 {info frame, global, relative} {!singleTestInterp} { reduce [info frame -6] -} {type source line 758 file info.test cmd test\ info-22.6\ \{info\ frame,\ global,\ relative\}\ \{!singleTestInter level 0} +} {type source line 761 file info.test cmd test\ info-22.6\ \{info\ frame,\ global,\ relative\}\ \{!singleTestInter level 0} test info-22.7 {info frame, global, absolute} {!singleTestInterp} { reduce [info frame 1] -} {type source line 761 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolute\}\ \{!singleTestInter level 0} +} {type source line 764 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolute\}\ \{!singleTestInter level 0} test info-22.8 {info frame, basic trace} -match glob -body { join [lrange [etrace] 0 2] \n -} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0} -* {type source line 765 file info.test cmd etrace proc ::tcltest::RunTest} +} -result {* {type source line 733 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type source line 768 file info.test cmd etrace proc ::tcltest::RunTest} * {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}} unset -nocomplain msg @@ -792,7 +794,7 @@ test info-23.3 {eval'd info frame, literal} -match glob -body { eval { info frame 0 } -} -result {type source line 793 file * cmd {info frame 0} proc ::tcltest::RunTest} +} -result {type source line 796 file * cmd {info frame 0} proc ::tcltest::RunTest} test info-23.4 {eval'd info frame, semi-dynamic} { eval info frame 0 } {type eval line 1 cmd {info frame 0} proc ::tcltest::RunTest} @@ -803,9 +805,9 @@ test info-23.5 {eval'd info frame, dynamic} -cleanup {unset script} -body { test info-23.6 {eval'd info frame, trace} -match glob -cleanup {unset script} -body { set script {etrace} join [lrange [eval $script] 0 2] \n -} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0} +} -result {* {type source line 733 file info.test cmd {info frame $level} proc ::etrace level 0} * {type eval line 1 cmd etrace proc ::tcltest::RunTest} -* {type source line 805 file info.test cmd {eval $script} proc ::tcltest::RunTest}} +* {type source line 808 file info.test cmd {eval $script} proc ::tcltest::RunTest}} # ------------------------------------------------------------------------- @@ -829,7 +831,7 @@ test info-24.0 {info frame, interaction, namespace eval} -body { reduce [foo::bar] } -cleanup { namespace delete foo -} -result {type source line 825 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} -result {type source line 828 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -843,7 +845,7 @@ test info-24.1 {info frame, interaction, if} -body { reduce [foo::bar] } -cleanup { namespace delete foo -} -result {type source line 839 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} -result {type source line 842 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -852,13 +854,14 @@ while {$flag} { namespace eval foo {} proc ::foo::bar {} {info frame 0} set flag 0 -};unset flag +} +unset flag test info-24.2 {info frame, interaction, while} -body { reduce [foo::bar] } -cleanup { namespace delete foo -} -result {type source line 853 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} -result {type source line 856 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -871,7 +874,7 @@ test info-24.3 {info frame, interaction, catch} -body { reduce [foo::bar] } -cleanup { namespace delete foo -} -result {type source line 867 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} -result {type source line 871 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -879,13 +882,14 @@ foreach var val { namespace eval foo {} proc ::foo::bar {} {info frame 0} break -}; unset var +} +unset var test info-24.4 {info frame, interaction, foreach} -body { reduce [foo::bar] } -cleanup { namespace delete foo -} -result {type source line 880 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} -result {type source line 884 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -899,7 +903,7 @@ test info-24.5 {info frame, interaction, for} -body { reduce [foo::bar] } -cleanup { namespace delete foo -} -result {type source line 894 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} -result {type source line 899 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -909,6 +913,7 @@ switch -exact -- $x { foo { proc ::foo::bar {} {info frame 0} } + default {} } test info-24.6.0 {info frame, interaction, switch, list body} -body { @@ -916,7 +921,7 @@ test info-24.6.0 {info frame, interaction, switch, list body} -body { } -cleanup { namespace delete foo unset x -} -result {type source line 910 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} -result {type source line 915 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -931,7 +936,7 @@ test info-24.6.1 {info frame, interaction, switch, multi-body} -body { } -cleanup { namespace delete foo unset x -} -result {type source line 926 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} -result {type source line 932 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -957,9 +962,10 @@ dict for {k v} {foo bar} { test info-24.7 {info frame, interaction, dict for} { reduce [foo::bar] -} {type source line 955 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} {type source line 961 file info.test cmd {info frame 0} proc ::foo::bar level 0} -namespace delete foo; unset k v +namespace delete foo +unset k v # ------------------------------------------------------------------------- @@ -971,7 +977,7 @@ dict with thedict { test info-24.8 {info frame, interaction, dict with} { reduce [foo::bar] -} {type source line 969 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} {type source line 976 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo unset thedict foo @@ -982,11 +988,12 @@ namespace eval foo {} dict filter {foo bar} script {k v} { proc ::foo::bar {} {info frame 0} set x 1 -}; unset k v x +} +unset k v x test info-24.9 {info frame, interaction, dict filter} { reduce [foo::bar] -} {type source line 983 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} {type source line 990 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo #unset x @@ -999,14 +1006,14 @@ eval { test info-25.0 {info frame, proc in eval} { reduce [bar] -} {type source line 997 file info.test cmd {info frame 0} proc ::bar level 0} +} {type source line 1005 file info.test cmd {info frame 0} proc ::bar level 0} # Don't need to clean up yet... proc bar {} {info frame 0} test info-25.1 {info frame, regular proc} { reduce [bar] -} {type source line 1005 file info.test cmd {info frame 0} proc ::bar level 0} +} {type source line 1013 file info.test cmd {info frame 0} proc ::bar level 0} rename bar {} @@ -1024,7 +1031,7 @@ test info-30.0 {bs+nl in literal words} -cleanup {unset res} -body { # offsets of all bs+nl sequences in literal words, then using the # information in the bcc and other places to bump line numbers when # parsing over the location. Also affected: testcases 22.8 and 23.6. -} -result {type source line 1018 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} -result {type source line 1026 file info.test cmd {info frame 0} proc ::tcltest::RunTest} # ------------------------------------------------------------------------- # See 24.0 - 24.5 for similar situations, using literal scripts. @@ -1083,7 +1090,8 @@ set body { namespace eval foo {} set x foo -switch -exact -- $x $body; unset body +switch -exact -- $x $body +unset body test info-31.7 {info frame, interaction, switch, dynamic} -body { reduce [foo::bar] @@ -1118,7 +1126,7 @@ test info-33.0 {{*}, literal, direct} -body { reduce [foo::bar] } -cleanup { namespace delete foo -} -result {type source line 1115 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} -result {type source line 1124 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -1134,7 +1142,7 @@ test info-33.1 {{*}, literal, simple, bytecompiled} -body { reduce [foo::bar] } -cleanup { namespace delete foo -} -result {type source line 1130 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} -result {type source line 1139 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -1145,7 +1153,7 @@ namespace {*}" " test info-33.2 {{*}, literal, direct} { reduce [foo::bar] -} {type source line 1144 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} {type source line 1153 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo @@ -1171,7 +1179,7 @@ proc foo::bar {} { } test info-33.3 {{*}, literal, simple, bytecompiled} { reduce [foo::bar] -} {type source line 1169 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} {type source line 1178 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo @@ -1213,7 +1221,8 @@ set body { {info frame 0} } proc foo::bar {} { - global body ; set flag 1 + global body + set flag 1 if {*}$body } test info-34.1 {{*}, literal, bytecompiled} { @@ -1233,7 +1242,7 @@ proc foo {} { } test info-35.0 {apply, literal} { reduce [foo] -} {type source line 1231 file info.test cmd {info frame 0} lambda { +} {type source line 1241 file info.test cmd {info frame 0} lambda { {x y} {info frame 0} } level 0} @@ -1262,7 +1271,7 @@ proc foo::bar {} { } test info-36.0 {info frame, dict for, bcc} -body { reduce [foo::bar] -} -result {type source line 1259 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} -result {type source line 1269 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo @@ -1273,13 +1282,14 @@ proc foo::bar {} { set x foo switch -exact -- $x { foo {set y [info frame 0]} + default {} } set y } test info-36.1.0 {switch, list literal, bcc} -body { reduce [foo::bar] -} -result {type source line 1275 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} -result {type source line 1285 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo @@ -1294,7 +1304,7 @@ proc foo::bar {} { test info-36.1.1 {switch, multi-body literals, bcc} -body { reduce [foo::bar] -} -result {type source line 1291 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} -result {type source line 1302 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo @@ -1318,7 +1328,7 @@ test info-37.0 {eval pure list, single line} -match glob -body { }] eval $cmd return $res -} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0} +} -result {* {type source line 733 file info.test cmd {info frame $level} proc ::etrace level 0} * {type eval line 2 cmd etrace proc ::tcltest::RunTest} * {type eval line 1 cmd foreac proc ::tcltest::RunTest}} -cleanup {unset foo cmd res b c} @@ -1359,9 +1369,9 @@ test info-38.1 {location information for uplevel, dv, direct-var} -match glob -b etrace } join [lrange [uplevel \#0 $script] 0 2] \n -} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0} +} -result {* {type source line 733 file info.test cmd {info frame $level} proc ::etrace level 0} * {type eval line 3 cmd etrace proc ::tcltest::RunTest} -* {type source line 1361 file info.test cmd {uplevel \\#0 $script} proc ::tcltest::RunTest}} -cleanup {unset script y} +* {type source line 1372 file info.test cmd {uplevel \\#0 $script} proc ::tcltest::RunTest}} -cleanup {unset script y} # 38.2 moved to bottom to not disturb other tests with the necessary changes to this one. @@ -1378,10 +1388,10 @@ test info-38.3 {location information for uplevel, dpv, direct-proc-var} -match g etrace } join [lrange [control y $script] 0 3] \n -} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0} +} -result {* {type source line 733 file info.test cmd {info frame $level} proc ::etrace level 0} * {type eval line 3 cmd etrace proc ::control} -* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control} -* {type source line 1380 file info.test cmd {control y $script} proc ::tcltest::RunTest}} -cleanup {unset script y} +* {type source line 1349 file info.test cmd {uplevel 1 $script} proc ::control} +* {type source line 1391 file info.test cmd {control y $script} proc ::tcltest::RunTest}} -cleanup {unset script y} # 38.4 moved to bottom to not disturb other tests with the necessary changes to this one. @@ -1395,11 +1405,11 @@ test info-38.3 {location information for uplevel, dpv, direct-proc-var} -match g test info-38.5 {location information for uplevel, ppv, proc-proc-var} -match glob -body { join [lrange [datav] 0 4] \n -} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0} +} -result {* {type source line 733 file info.test cmd {info frame $level} proc ::etrace level 0} * {type eval line 3 cmd etrace proc ::control} -* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control} -* {type source line 1353 file info.test cmd {control y $script} proc ::datav level 1} -* {type source line 1397 file info.test cmd datav proc ::tcltest::RunTest}} +* {type source line 1349 file info.test cmd {uplevel 1 $script} proc ::control} +* {type source line 1364 file info.test cmd {control y $script} proc ::datav level 1} +* {type source line 1408 file info.test cmd datav proc ::tcltest::RunTest}} # 38.6 moved to bottom to not disturb other tests with the necessary changes to this one. @@ -1412,10 +1422,10 @@ test info-38.5 {location information for uplevel, ppv, proc-proc-var} -match glo testConstraint testevalex [llength [info commands testevalex]] test info-38.7 {location information for arg substitution} -constraints testevalex -match glob -body { join [lrange [testevalex {return -level 0 [etrace]}] 0 3] \n -} -result {* {type source line 730 file info.test cmd {info frame \$level} proc ::etrace level 0} +} -result {* {type source line 733 file info.test cmd {info frame \$level} proc ::etrace level 0} * {type eval line 1 cmd etrace proc ::tcltest::RunTest} -* {type source line 1414 file info.test cmd {testevalex {return -level 0 \[etrace]}} proc ::tcltest::RunTest} -* {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}} +* {type source line 1425 file info.test cmd {testevalex {return -level 0 \[etrace]}} proc ::tcltest::RunTest} +* {type source line 2325 file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}} # ------------------------------------------------------------------------- # literal sharing @@ -1432,8 +1442,8 @@ test info-39.0 {location information not confused by literal sharing} -body { namespace delete ::foo join $res \n } -cleanup {unset res} -result { -type source line 1427 file info.test cmd {info frame 0} proc ::foo::bar level 0 -type source line 1428 file info.test cmd {info frame 0} proc ::foo::bar level 0} +type source line 1438 file info.test cmd {info frame 0} proc ::foo::bar level 0 +type source line 1439 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- # Additional tests for info-30.*, handling of continuation lines (bs+nl sequences). @@ -1449,88 +1459,88 @@ test info-30.1 {bs+nl in literal words, procedure body, compiled} -body { abra } -cleanup { rename abra {} -} -result {type source line 1446 file info.test cmd {info frame 0} proc ::abra level 0} +} -result {type source line 1457 file info.test cmd {info frame 0} proc ::abra level 0} test info-30.2 {bs+nl in literal words, namespace script} { namespace eval xxx { variable res \ - [info frame 0];# line 1457 + [info frame 0];# line 1468 } return [reduce $xxx::res] -} {type source line 1457 file info.test cmd {info frame 0} level 0} +} {type source line 1468 file info.test cmd {info frame 0} level 0} test info-30.3 {bs+nl in literal words, namespace multi-word script} { namespace eval xxx variable res \ - [list [reduce [info frame 0]]];# line 1464 + [list [reduce [info frame 0]]];# line 1475 return $xxx::res -} {type source line 1464 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} {type source line 1475 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.4 {bs+nl in literal words, eval script} -cleanup {unset res} -body { eval { set ::res \ - [reduce [info frame 0]];# line 1471 + [reduce [info frame 0]];# line 1482 } return $res -} -result {type source line 1471 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} -result {type source line 1482 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.5 {bs+nl in literal words, eval script, with nested words} -body { eval { if {1} \ { set ::res \ - [reduce [info frame 0]];# line 1481 + [reduce [info frame 0]];# line 1492 } } return $res -} -cleanup {unset res} -result {type source line 1481 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} -cleanup {unset res} -result {type source line 1492 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.6 {bs+nl in computed word} -cleanup {unset res} -body { set res "\ -[reduce [info frame 0]]";# line 1489 -} -result { type source line 1489 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +[reduce [info frame 0]]";# line 1500 +} -result { type source line 1500 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.7 {bs+nl in computed word, in proc} -body { proc abra {} { return "\ -[reduce [info frame 0]]";# line 1495 +[reduce [info frame 0]]";# line 1506 } abra } -cleanup { rename abra {} -} -result { type source line 1495 file info.test cmd {info frame 0} proc ::abra level 0} +} -result { type source line 1506 file info.test cmd {info frame 0} proc ::abra level 0} test info-30.8 {bs+nl in computed word, nested eval} -body { eval { set \ res "\ -[reduce [info frame 0]]";# line 1506 +[reduce [info frame 0]]";# line 1517 } -} -cleanup {unset res} -result { type source line 1506 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} -cleanup {unset res} -result { type source line 1517 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.9 {bs+nl in computed word, nested eval} -body { eval { set \ res "\ [reduce \ - [info frame 0]]";# line 1515 + [info frame 0]]";# line 1526 } -} -cleanup {unset res} -result { type source line 1515 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} -cleanup {unset res} -result { type source line 1526 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.10 {bs+nl in computed word, key to array} -body { set tmp([set \ res "\ [reduce \ - [info frame 0]]"]) x ; #1523 + [info frame 0]]"]) x ; #1534 unset tmp set res -} -cleanup {unset res} -result { type source line 1523 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} -cleanup {unset res} -result { type source line 1534 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.11 {bs+nl in subst arguments} -body { subst {[set \ res "\ [reduce \ - [info frame 0]]"]} ; #1532 -} -cleanup {unset res} -result { type source line 1532 file info.test cmd {info frame 0} proc ::tcltest::RunTest} + [info frame 0]]"]} ; #1543 +} -cleanup {unset res} -result { type source line 1543 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.12 {bs+nl in computed word, nested eval} -body { eval { @@ -1538,20 +1548,20 @@ test info-30.12 {bs+nl in computed word, nested eval} -body { res "\ [set x {}] \ [reduce \ - [info frame 0]]";# line 1541 + [info frame 0]]";# line 1552 } -} -cleanup {unset res x} -result { type source line 1541 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} -cleanup {unset res x} -result { type source line 1552 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.13 {bs+nl in literal words, uplevel script, with nested words} -body { subinterp ; set res [interp eval sub { uplevel #0 { if {1} \ { set ::res \ - [reduce [info frame 0]];# line 1550 + [reduce [info frame 0]];# line 1561 } } set res }] ; interp delete sub ; set res -} -cleanup {unset res} -result {type source line 1550 file info.test cmd {info frame 0} level 0} +} -cleanup {unset res} -result {type source line 1561 file info.test cmd {info frame 0} level 0} test info-30.14 {bs+nl, literal word, uplevel through proc} { subinterp ; set res [interp eval sub { proc abra {script} { @@ -1559,11 +1569,11 @@ test info-30.14 {bs+nl, literal word, uplevel through proc} { } set res [abra { return "\ -[reduce [info frame 0]]";# line 1562 +[reduce [info frame 0]]";# line 1573 }] rename abra {} set res }] ; interp delete sub ; set res -} { type source line 1562 file info.test cmd {info frame 0} proc ::abra} +} { type source line 1573 file info.test cmd {info frame 0} proc ::abra} test info-30.15 {bs+nl in literal words, nested proc body, compiled} { proc a {} { @@ -1571,7 +1581,7 @@ test info-30.15 {bs+nl in literal words, nested proc body, compiled} { if {1} \ { return \ - [reduce [info frame 0]];# line 1574 + [reduce [info frame 0]];# line 1585 } } } @@ -1579,29 +1589,29 @@ test info-30.15 {bs+nl in literal words, nested proc body, compiled} { rename a {} rename b {} set res -} {type source line 1574 file info.test cmd {info frame 0} proc ::b level 0} +} {type source line 1585 file info.test cmd {info frame 0} proc ::b level 0} test info-30.16 {bs+nl in multi-body switch, compiled} { proc a {value} { switch -regexp -- $value \ - ^key { info frame 0; # 1587 } \ - \t### { info frame 0; # 1588 } \ - {[0-9]*} { info frame 0; # 1589 } + ^key { info frame 0; # 1598 } \ + \t### { info frame 0; # 1599 } \ + {[0-9]*} { info frame 0; # 1600 } } set res {} lappend res [reduce [a {key }]] lappend res [reduce [a {1alpha}]] set res "\n[join $res \n]" } { -type source line 1587 file info.test cmd {info frame 0} proc ::a level 0 -type source line 1589 file info.test cmd {info frame 0} proc ::a level 0} +type source line 1598 file info.test cmd {info frame 0} proc ::a level 0 +type source line 1600 file info.test cmd {info frame 0} proc ::a level 0} test info-30.17 {bs+nl in multi-body switch, direct} { switch -regexp -- {key } \ - ^key { reduce [info frame 0] ;# 1601 } \ + ^key { reduce [info frame 0] ;# 1612 } \ \t### { } \ {[0-9]*} { } -} {type source line 1601 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} {type source line 1612 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.18 {bs+nl, literal word, uplevel through proc, appended, loss of primary tracking data} { proc abra {script} { @@ -1633,8 +1643,8 @@ test info-30.19 {bs+nl in single-body switch, compiled} { lappend res [a {1alpha}] set res "\n[join $res \n]" } { -type source line 1624 file info.test cmd {info frame 0} proc ::a level 0 -type source line 1628 file info.test cmd {info frame 0} proc ::a level 0} +type source line 1635 file info.test cmd {info frame 0} proc ::a level 0 +type source line 1639 file info.test cmd {info frame 0} proc ::a level 0} test info-30.20 {bs+nl in single-body switch, direct} { switch -regexp -- {key } { \ @@ -1644,50 +1654,50 @@ test info-30.20 {bs+nl in single-body switch, direct} { \t### { } {[0-9]*} { } } -} {type source line 1643 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} {type source line 1654 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.21 {bs+nl in if, full compiled} { proc a {value} { if {$value} \ {info frame 0} \ - {info frame 0} ; # 1653 + {info frame 0} ; # 1664 } set res {} lappend res [reduce [a 1]] lappend res [reduce [a 0]] set res "\n[join $res \n]" } { -type source line 1652 file info.test cmd {info frame 0} proc ::a level 0 -type source line 1653 file info.test cmd {info frame 0} proc ::a level 0} +type source line 1663 file info.test cmd {info frame 0} proc ::a level 0 +type source line 1664 file info.test cmd {info frame 0} proc ::a level 0} test info-30.22 {bs+nl in computed word, key to array, compiled} { proc a {} { set tmp([set \ res "\ [reduce \ - [info frame 0]]"]) x ; #1668 + [info frame 0]]"]) x ; #1679 unset tmp set res } set res [a] rename a {} set res -} { type source line 1668 file info.test cmd {info frame 0} proc ::a level 0} +} { type source line 1679 file info.test cmd {info frame 0} proc ::a level 0} test info-30.23 {bs+nl in multi-body switch, full compiled} { proc a {value} { switch -exact -- $value \ - key { info frame 0; # 1680 } \ - xxx { info frame 0; # 1681 } \ - 000 { info frame 0; # 1682 } + key { info frame 0; # 1691 } \ + xxx { info frame 0; # 1692 } \ + 000 { info frame 0; # 1693 } } set res {} lappend res [reduce [a key]] lappend res [reduce [a 000]] set res "\n[join $res \n]" } { -type source line 1680 file info.test cmd {info frame 0} proc ::a level 0 -type source line 1682 file info.test cmd {info frame 0} proc ::a level 0} +type source line 1691 file info.test cmd {info frame 0} proc ::a level 0 +type source line 1693 file info.test cmd {info frame 0} proc ::a level 0} test info-30.24 {bs+nl in single-body switch, full compiled} { proc a {value} { @@ -1705,130 +1715,130 @@ test info-30.24 {bs+nl in single-body switch, full compiled} { lappend res [a 000] set res "\n[join $res \n]" } { -type source line 1696 file info.test cmd {info frame 0} proc ::a level 0 -type source line 1700 file info.test cmd {info frame 0} proc ::a level 0} +type source line 1707 file info.test cmd {info frame 0} proc ::a level 0 +type source line 1711 file info.test cmd {info frame 0} proc ::a level 0} test info-30.25 {TIP 280 for compiled [subst]} { - subst {[reduce [info frame 0]]} ; # 1712 -} {type source line 1712 file info.test cmd {info frame 0} proc ::tcltest::RunTest} + subst {[reduce [info frame 0]]} ; # 1723 +} {type source line 1723 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.26 {TIP 280 for compiled [subst]} { subst \ - {[reduce [info frame 0]]} ; # 1716 -} {type source line 1716 file info.test cmd {info frame 0} proc ::tcltest::RunTest} + {[reduce [info frame 0]]} ; # 1727 +} {type source line 1727 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.27 {TIP 280 for compiled [subst]} { subst { -[reduce [info frame 0]]} ; # 1720 +[reduce [info frame 0]]} ; # 1731 } { -type source line 1720 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +type source line 1731 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.28 {TIP 280 for compiled [subst]} { subst {\ -[reduce [info frame 0]]} ; # 1725 -} { type source line 1725 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +[reduce [info frame 0]]} ; # 1736 +} { type source line 1736 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.29 {TIP 280 for compiled [subst]} { subst {foo\ -[reduce [info frame 0]]} ; # 1729 -} {foo type source line 1729 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +[reduce [info frame 0]]} ; # 1740 +} {foo type source line 1740 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.30 {TIP 280 for compiled [subst]} { subst {foo -[reduce [info frame 0]]} ; # 1733 +[reduce [info frame 0]]} ; # 1744 } {foo -type source line 1733 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +type source line 1744 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.31 {TIP 280 for compiled [subst]} { - subst {[][reduce [info frame 0]]} ; # 1737 -} {type source line 1737 file info.test cmd {info frame 0} proc ::tcltest::RunTest} + subst {[][reduce [info frame 0]]} ; # 1748 +} {type source line 1748 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.32 {TIP 280 for compiled [subst]} { subst {[\ -][reduce [info frame 0]]} ; # 1741 -} {type source line 1741 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +][reduce [info frame 0]]} ; # 1752 +} {type source line 1752 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.33 {TIP 280 for compiled [subst]} { subst {[ -][reduce [info frame 0]]} ; # 1745 -} {type source line 1745 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +][reduce [info frame 0]]} ; # 1756 +} {type source line 1756 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.34 {TIP 280 for compiled [subst]} { subst {[format %s {} -][reduce [info frame 0]]} ; # 1749 -} {type source line 1749 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +][reduce [info frame 0]]} ; # 1760 +} {type source line 1760 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.35 {TIP 280 for compiled [subst]} { subst {[format %s {} ] -[reduce [info frame 0]]} ; # 1754 +[reduce [info frame 0]]} ; # 1765 } { -type source line 1754 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +type source line 1765 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.36 {TIP 280 for compiled [subst]} { subst { -[format %s {}][reduce [info frame 0]]} ; # 1759 +[format %s {}][reduce [info frame 0]]} ; # 1770 } { -type source line 1759 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +type source line 1770 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.37 {TIP 280 for compiled [subst]} { subst { [format %s {}] -[reduce [info frame 0]]} ; # 1765 +[reduce [info frame 0]]} ; # 1776 } { -type source line 1765 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +type source line 1776 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.38 {TIP 280 for compiled [subst]} { subst {\ -[format %s {}][reduce [info frame 0]]} ; # 1771 -} { type source line 1771 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +[format %s {}][reduce [info frame 0]]} ; # 1782 +} { type source line 1782 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.39 {TIP 280 for compiled [subst]} { subst {\ [format %s {}]\ -[reduce [info frame 0]]} ; # 1776 -} { type source line 1776 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +[reduce [info frame 0]]} ; # 1787 +} { type source line 1787 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.40 {TIP 280 for compiled [subst]} -setup { unset -nocomplain empty } -body { set empty {} - subst {$empty[reduce [info frame 0]]} ; # 1782 + subst {$empty[reduce [info frame 0]]} ; # 1793 } -cleanup { unset empty -} -result {type source line 1782 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} -result {type source line 1793 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.41 {TIP 280 for compiled [subst]} -setup { unset -nocomplain empty } -body { set empty {} subst {$empty -[reduce [info frame 0]]} ; # 1791 +[reduce [info frame 0]]} ; # 1802 } -cleanup { unset empty } -result { -type source line 1791 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +type source line 1802 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.42 {TIP 280 for compiled [subst]} -setup { unset -nocomplain empty } -body { set empty {}; subst {$empty\ -[reduce [info frame 0]]} ; # 1800 +[reduce [info frame 0]]} ; # 1811 } -cleanup { unset empty -} -result { type source line 1800 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} -result { type source line 1811 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.43 {TIP 280 for compiled [subst]} -body { unset -nocomplain a\nb set a\nb {} subst {${a -b}[reduce [info frame 0]]} ; # 1808 -} -cleanup {unset a\nb} -result {type source line 1808 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +b}[reduce [info frame 0]]} ; # 1819 +} -cleanup {unset a\nb} -result {type source line 1819 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.44 {TIP 280 for compiled [subst]} { unset -nocomplain a set a(\n) {} subst {$a( -)[reduce [info frame 0]]} ; # 1814 -} {type source line 1814 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +)[reduce [info frame 0]]} ; # 1825 +} {type source line 1825 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.45 {TIP 280 for compiled [subst]} { unset -nocomplain a set a() {} subst {$a([ -return -level 0])[reduce [info frame 0]]} ; # 1820 -} {type source line 1820 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +return -level 0])[reduce [info frame 0]]} ; # 1831 +} {type source line 1831 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.46 {TIP 280 for compiled [subst]} { unset -nocomplain a - set a(1825) YES; set a(1824) 1824; set a(1826) 1826 - subst {$a([dict get [info frame 0] line])} ; # 1825 + set a(1836) YES; set a(1835) 1835; set a(1837) 1837 + subst {$a([dict get [info frame 0] line])} ; # 1836 } YES test info-30.47 {TIP 280 for compiled [subst]} { unset -nocomplain a - set a(\n1831) YES; set a(\n1830) 1830; set a(\n1832) 1832 + set a(\n1842) YES; set a(\n1841) 1841; set a(\n1843) 1843 subst {$a( -[dict get [info frame 0] line])} ; # 1831 +[dict get [info frame 0] line])} ; # 1842 } YES unset -nocomplain a @@ -1875,8 +1885,8 @@ test info-39.1 {location information not confused by literal sharing, bug 293308 rename get_frame_info {} rename test_info_frame {} rename print_one {} -} -result {type source line 1854 file info.test cmd print_one proc ::test_info_frame level 1 -type source line 1859 file info.test cmd print_one proc ::test_info_frame level 1} +} -result {type source line 1865 file info.test cmd print_one proc ::test_info_frame level 1 +type source line 1870 file info.test cmd print_one proc ::test_info_frame level 1} # ------------------------------------------------------------------------- # Tests moved to the end to not disturb other tests and their locations. @@ -1904,11 +1914,11 @@ test info-38.6 {location information for uplevel, ppl, proc-proc-literal} -match } join [lrange [datal] 0 4] \n } -} -result {* {type source line 1890 file info.test cmd {info frame $level} proc ::etrace level 0} -* {type source line 1902 file info.test cmd etrace proc ::control} -* {type source line 1897 file info.test cmd {uplevel 1 $script} proc ::control} -* {type source line 1900 file info.test cmd control proc ::datal level 1} -* {type source line 1905 file info.test cmd datal level 2}} -cleanup {interp delete sub} +} -result {* {type source line 1901 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type source line 1913 file info.test cmd etrace proc ::control} +* {type source line 1908 file info.test cmd {uplevel 1 $script} proc ::control} +* {type source line 1911 file info.test cmd control proc ::datal level 1} +* {type source line 1916 file info.test cmd datal level 2}} -cleanup {interp delete sub} test info-38.4 {location information for uplevel, dpv, direct-proc-literal} -match glob -setup {subinterp} -body { interp eval sub { @@ -1930,10 +1940,10 @@ test info-38.4 {location information for uplevel, dpv, direct-proc-literal} -mat etrace }] 0 3] \n } -} -result {* {type source line 1919 file info.test cmd {info frame $level} proc ::etrace level 0} -* {type source line 1930 file info.test cmd etrace proc ::control} -* {type source line 1926 file info.test cmd {uplevel 1 $script} proc ::control} -* {type source line 1928 file info.test cmd control level 1}} -cleanup {interp delete sub} +} -result {* {type source line 1930 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type source line 1941 file info.test cmd etrace proc ::control} +* {type source line 1937 file info.test cmd {uplevel 1 $script} proc ::control} +* {type source line 1939 file info.test cmd control level 1}} -cleanup {interp delete sub} test info-38.2 {location information for uplevel, dl, direct-literal} -match glob -setup {subinterp} -body { interp eval sub { @@ -1951,9 +1961,9 @@ test info-38.2 {location information for uplevel, dl, direct-literal} -match glo etrace }] 0 2] \n } -} -result {* {type source line 1944 file info.test cmd {info frame $level} proc ::etrace level 0} -* {type source line 1951 file info.test cmd etrace level 1} -* {type source line 1949 file info.test cmd uplevel\\ \\\\ level 1}} -cleanup {interp delete sub} +} -result {3 {type source line 1955 file info.test cmd {info frame $level} proc ::etrace level 0} +2 {type source line 1962 file info.test cmd etrace level 1} +1 {type source line 1960 file info.test cmd uplevel\ \\ level 1}} -cleanup {interp delete sub} # This test at the end of this file _only_ to avoid disturbing above line # numbers. It _belongs_ after info-9.12 diff --git a/tests/interp.test b/tests/interp.test index 0af9887..f25663a 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -308,13 +308,13 @@ test interp-9.4 {testing aliases and namespace commands} { interp alias {} a {} p set res [a] lappend res [namespace eval tst a] - rename p {} - rename a {} + rename p "" + rename a "" namespace delete tst set res } {GLOBAL GLOBAL} -if {[info command nonexistent-command-in-master] != ""} { +if {[info command nonexistent-command-in-master] ne ""} { rename nonexistent-command-in-master {} } diff --git a/tests/io.test b/tests/io.test index 0688c14..a0f4297 100644 --- a/tests/io.test +++ b/tests/io.test @@ -52,13 +52,13 @@ testConstraint largefileSupport 0 set umaskValue 0 testConstraint umask [expr {![catch {set umaskValue [scan [exec /bin/sh -c umask] %o]}]}] -testConstraint makeFileInHome [expr {![file exists ~/_test_] && [file writable ~]}] +testConstraint makeFileInHome [expr {(![file exists ~/_test_]) && [file writable ~]}] # set up a long data file for some of the following tests set path(longfile) [makeFile {} longfile] set f [open $path(longfile) w] -fconfigure $f -eofchar {} -translation lf +chan configure $f -eofchar {} -translation lf for { set i 0 } { $i < 100 } { incr i} { puts $f "#123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef \#123456789abcdef01 @@ -68,12 +68,12 @@ close $f set path(cat) [makeFile { set f stdin - if {$argv != ""} { + if {$argv ne ""} { set f [open [lindex $argv 0]] } - fconfigure $f -encoding binary -translation lf -blocking 0 -eofchar \x1a - fconfigure stdout -encoding binary -translation lf -buffering none - fileevent $f readable "foo $f" + chan configure $f -encoding binary -translation lf -blocking 0 -eofchar \x1a + chan configure stdout -encoding binary -translation lf -buffering none + chan event $f readable "foo $f" proc foo {f} { set x [read $f] catch {puts -nonewline $x} @@ -89,7 +89,7 @@ set thisScript [file join [pwd] [info script]] proc contents {file} { set f [open $file] - fconfigure $f -translation binary + chan configure $f -translation binary set a [read $f] close $f return $a @@ -101,14 +101,14 @@ test io-1.5 {Tcl_WriteChars: CheckChannelErrors} {emptyTest} { set path(test1) [makeFile {} test1] test io-1.6 {Tcl_WriteChars: WriteBytes} { set f [open $path(test1) w] - fconfigure $f -encoding binary + chan configure $f -encoding binary puts -nonewline $f "a\u4e4d\0" close $f contents $path(test1) } "a\x4d\x00" test io-1.7 {Tcl_WriteChars: WriteChars} { set f [open $path(test1) w] - fconfigure $f -encoding shiftjis + chan configure $f -encoding shiftjis puts -nonewline $f "a\u4e4d\0" close $f contents $path(test1) @@ -122,7 +122,7 @@ test io-1.8 {Tcl_WriteChars: WriteChars} { # go into an infinite loop. set f [open $path(test2) w] - fconfigure $f -encoding iso2022-jp + chan configure $f -encoding iso2022-jp puts -nonewline $f [format %s%c [string repeat " " 4] 12399] close $f contents $path(test2) @@ -140,7 +140,7 @@ test io-1.9 {Tcl_WriteChars: WriteChars} { # With default buffer size set f [open $path(test2) w] - fconfigure $f -encoding iso2022-jp + chan configure $f -encoding iso2022-jp puts -nonewline $f $data close $f lappend sizes [file size $path(test2)] @@ -150,7 +150,7 @@ test io-1.9 {Tcl_WriteChars: WriteChars} { # go into the next buffer. set f [open $path(test2) w] - fconfigure $f -encoding iso2022-jp -buffersize 16 + chan configure $f -encoding iso2022-jp -buffersize 16 puts -nonewline $f $data close $f lappend sizes [file size $path(test2)] @@ -162,7 +162,7 @@ test io-1.9 {Tcl_WriteChars: WriteChars} { # and then again to the second buffer. set f [open $path(test2) w] - fconfigure $f -encoding iso2022-jp -buffersize 17 + chan configure $f -encoding iso2022-jp -buffersize 17 puts -nonewline $f $data close $f lappend sizes [file size $path(test2)] @@ -171,7 +171,7 @@ test io-1.9 {Tcl_WriteChars: WriteChars} { # 3 bytes of escaped data. set f [open $path(test2) w] - fconfigure $f -encoding iso2022-jp -buffersize 18 + chan configure $f -encoding iso2022-jp -buffersize 18 puts -nonewline $f $data close $f lappend sizes [file size $path(test2)] @@ -180,7 +180,7 @@ test io-1.9 {Tcl_WriteChars: WriteChars} { # data and escape bytes. set f [open $path(test2) w] - fconfigure $f -encoding iso2022-jp -buffersize 19 + chan configure $f -encoding iso2022-jp -buffersize 19 puts -nonewline $f $data close $f lappend sizes [file size $path(test2)] @@ -192,7 +192,7 @@ test io-2.1 {WriteBytes} { # loop until all bytes are written set f [open $path(test1) w] - fconfigure $f -encoding binary -buffersize 16 -translation crlf + chan configure $f -encoding binary -buffersize 16 -translation crlf puts $f "abcdefghijklmnopqrstuvwxyz" close $f contents $path(test1) @@ -202,7 +202,7 @@ test io-2.2 {WriteBytes: savedLF > 0} { # \n -> \r\n expansion. It gets stuck at beginning of this buffer. set f [open $path(test1) w] - fconfigure $f -encoding binary -buffersize 16 -translation crlf + chan configure $f -encoding binary -buffersize 16 -translation crlf puts -nonewline $f "123456789012345\n12" set x [list [contents $path(test1)]] close $f @@ -214,7 +214,7 @@ test io-2.3 {WriteBytes: flush on line} { # only up to the \n. set f [open $path(test1) w] - fconfigure $f -encoding binary -buffering line -translation crlf + chan configure $f -encoding binary -buffering line -translation crlf puts -nonewline $f "\n12" set x [contents $path(test1)] close $f @@ -222,7 +222,7 @@ test io-2.3 {WriteBytes: flush on line} { } "\r\n12" test io-2.4 {WriteBytes: reset sawLF after each buffer} { set f [open $path(test1) w] - fconfigure $f -encoding binary -buffering line -translation lf \ + chan configure $f -encoding binary -buffering line -translation lf \ -buffersize 16 puts -nonewline $f "abcdefg\nhijklmnopqrstuvwxyz" set x [list [contents $path(test1)]] @@ -234,7 +234,7 @@ test io-3.1 {WriteChars: compatibility with WriteBytes} { # loop until all bytes are written set f [open $path(test1) w] - fconfigure $f -encoding ascii -buffersize 16 -translation crlf + chan configure $f -encoding ascii -buffersize 16 -translation crlf puts $f "abcdefghijklmnopqrstuvwxyz" close $f contents $path(test1) @@ -244,7 +244,7 @@ test io-3.2 {WriteChars: compatibility with WriteBytes: savedLF > 0} { # \n -> \r\n expansion. It gets stuck at beginning of this buffer. set f [open $path(test1) w] - fconfigure $f -encoding ascii -buffersize 16 -translation crlf + chan configure $f -encoding ascii -buffersize 16 -translation crlf puts -nonewline $f "123456789012345\n12" set x [list [contents $path(test1)]] close $f @@ -256,7 +256,7 @@ test io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} { # only up to the \n. set f [open $path(test1) w] - fconfigure $f -encoding ascii -buffering line -translation crlf + chan configure $f -encoding ascii -buffering line -translation crlf puts -nonewline $f "\n12" set x [contents $path(test1)] close $f @@ -266,7 +266,7 @@ test io-3.4 {WriteChars: loop over stage buffer} { # stage buffer maps to more than can be queued at once. set f [open $path(test1) w] - fconfigure $f -encoding jis0208 -buffersize 16 + chan configure $f -encoding jis0208 -buffersize 16 puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] close $f @@ -278,7 +278,7 @@ test io-3.5 {WriteChars: saved != 0} { # requested buffersize. set f [open $path(test1) w] - fconfigure $f -encoding jis0208 -buffersize 17 + chan configure $f -encoding jis0208 -buffersize 17 puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] close $f @@ -295,7 +295,7 @@ test io-3.6 {WriteChars: (stageRead + dstWrote == 0)} { # (the last byte of \uff21 plus the all of \uff22) appended. set f [open $path(test1) w] - fconfigure $f -encoding shiftjis -buffersize 16 + chan configure $f -encoding shiftjis -buffersize 16 puts -nonewline $f "12345678901234\uff21\uff22" set x [list [contents $path(test1)]] close $f @@ -309,7 +309,7 @@ test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} { # of the next channel buffer. set f [open $path(test1) w] - fconfigure $f -encoding jis0208 -buffersize 17 + chan configure $f -encoding jis0208 -buffersize 17 puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] close $f @@ -317,7 +317,7 @@ test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} { } [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] test io-3.8 {WriteChars: reset sawLF after each buffer} { set f [open $path(test1) w] - fconfigure $f -encoding ascii -buffering line -translation lf \ + chan configure $f -encoding ascii -buffering line -translation lf \ -buffersize 16 puts -nonewline $f "abcdefg\nhijklmnopqrstuvwxyz" set x [list [contents $path(test1)]] @@ -329,7 +329,7 @@ test io-4.1 {TranslateOutputEOL: lf} { # search for \n set f [open $path(test1) w] - fconfigure $f -buffering line -translation lf + chan configure $f -buffering line -translation lf puts $f "abcde" set x [list [contents $path(test1)]] close $f @@ -339,7 +339,7 @@ test io-4.2 {TranslateOutputEOL: cr} { # search for \n, replace with \r set f [open $path(test1) w] - fconfigure $f -buffering line -translation cr + chan configure $f -buffering line -translation cr puts $f "abcde" set x [list [contents $path(test1)]] close $f @@ -349,7 +349,7 @@ test io-4.3 {TranslateOutputEOL: crlf} { # simple case: search for \n, replace with \r set f [open $path(test1) w] - fconfigure $f -buffering line -translation crlf + chan configure $f -buffering line -translation crlf puts $f "abcde" set x [list [contents $path(test1)]] close $f @@ -361,7 +361,7 @@ test io-4.4 {TranslateOutputEOL: crlf} { # dest buffer while (dstEnd < dstMax). set f [open $path(test1) w] - fconfigure $f -translation crlf -buffersize 16 + chan configure $f -translation crlf -buffersize 16 puts -nonewline $f "1234567\n\n\n\n\nA" set x [list [contents $path(test1)]] close $f @@ -371,7 +371,7 @@ test io-4.5 {TranslateOutputEOL: crlf} { # Check for overflow of the destination buffer set f [open $path(test1) w] - fconfigure $f -translation crlf -buffersize 12 + chan configure $f -translation crlf -buffersize 12 puts -nonewline $f "12345678901\n456789012345678901234" close $f set x [contents $path(test1)] @@ -379,7 +379,7 @@ test io-4.5 {TranslateOutputEOL: crlf} { test io-5.1 {CheckFlush: not full} { set f [open $path(test1) w] - fconfigure $f + chan configure $f puts -nonewline $f "12345678901234567890" set x [list [contents $path(test1)]] close $f @@ -387,7 +387,7 @@ test io-5.1 {CheckFlush: not full} { } [list "" "12345678901234567890"] test io-5.2 {CheckFlush: full} { set f [open $path(test1) w] - fconfigure $f -buffersize 16 + chan configure $f -buffersize 16 puts -nonewline $f "12345678901234567890" set x [list [contents $path(test1)]] close $f @@ -395,7 +395,7 @@ test io-5.2 {CheckFlush: full} { } [list "1234567890123456" "12345678901234567890"] test io-5.3 {CheckFlush: not line} { set f [open $path(test1) w] - fconfigure $f -buffering line + chan configure $f -buffering line puts -nonewline $f "12345678901234567890" set x [list [contents $path(test1)]] close $f @@ -403,7 +403,7 @@ test io-5.3 {CheckFlush: not line} { } [list "" "12345678901234567890"] test io-5.4 {CheckFlush: line} { set f [open $path(test1) w] - fconfigure $f -buffering line -translation lf -encoding ascii + chan configure $f -buffering line -translation lf -encoding ascii puts -nonewline $f "1234567890\n1234567890" set x [list [contents $path(test1)]] close $f @@ -411,7 +411,7 @@ test io-5.4 {CheckFlush: line} { } [list "1234567890\n1234567890" "1234567890\n1234567890"] test io-5.5 {CheckFlush: none} { set f [open $path(test1) w] - fconfigure $f -buffering none + chan configure $f -buffering none puts -nonewline $f "1234567890" set x [list [contents $path(test1)]] close $f @@ -434,7 +434,7 @@ test io-6.3 {Tcl_GetsObj: how many have we used?} { # if (bufPtr != NULL) {oldRemoved = bufPtr->nextRemoved} set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf puts $f "abc\ndefg" close $f set f [open $path(test1)] @@ -444,22 +444,22 @@ test io-6.3 {Tcl_GetsObj: how many have we used?} { } {0 3 5 4 defg} test io-6.4 {Tcl_GetsObj: encoding == NULL} { set f [open $path(test1) w] - fconfigure $f -translation binary + chan configure $f -translation binary puts $f "\x81\u1234\0" close $f set f [open $path(test1)] - fconfigure $f -translation binary + chan configure $f -translation binary set x [list [gets $f line] $line] close $f set x } [list 3 "\x81\x34\x00"] test io-6.5 {Tcl_GetsObj: encoding != NULL} { set f [open $path(test1) w] - fconfigure $f -translation binary + chan configure $f -translation binary puts $f "\x88\xea\x92\x9a" close $f set f [open $path(test1)] - fconfigure $f -encoding shiftjis + chan configure $f -encoding shiftjis set x [list [gets $f line] $line] close $f set x @@ -486,7 +486,7 @@ test io-6.7 {Tcl_GetsObj: error in input} {stdio openpipe} { puts -nonewline $f "hi\nwould" flush $f gets $f - fconfigure $f -blocking 0 + chan configure $f -blocking 0 set x [gets $f line] close $f set x @@ -496,7 +496,7 @@ test io-6.8 {Tcl_GetsObj: remember if EOF is seen} { puts $f "abcdef\x1aghijk\nwombat" close $f set f [open $path(test1)] - fconfigure $f -eofchar \x1a + chan configure $f -eofchar \x1a set x [list [gets $f line] $line [gets $f line] $line] close $f set x @@ -506,7 +506,7 @@ test io-6.9 {Tcl_GetsObj: remember if EOF is seen} { puts $f "abcdefghijk\nwom\u001abat" close $f set f [open $path(test1)] - fconfigure $f -eofchar \x1a + chan configure $f -eofchar \x1a set x [list [gets $f line] $line [gets $f line] $line] close $f set x @@ -516,62 +516,62 @@ test io-6.10 {Tcl_GetsObj: lf mode: no chars} { set f [open $path(test1) w] close $f set f [open $path(test1)] - fconfigure $f -translation lf + chan configure $f -translation lf set x [list [gets $f line] $line] close $f set x } {-1 {}} test io-6.11 {Tcl_GetsObj: lf mode: lone \n} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "\n" close $f set f [open $path(test1)] - fconfigure $f -translation lf + chan configure $f -translation lf set x [list [gets $f line] $line [gets $f line] $line] close $f set x } {0 {} -1 {}} test io-6.12 {Tcl_GetsObj: lf mode: lone \r} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "\r" close $f set f [open $path(test1)] - fconfigure $f -translation lf + chan configure $f -translation lf set x [list [gets $f line] $line [gets $f line] $line] close $f set x } [list 1 "\r" -1 ""] test io-6.13 {Tcl_GetsObj: lf mode: 1 char} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f a close $f set f [open $path(test1)] - fconfigure $f -translation lf + chan configure $f -translation lf set x [list [gets $f line] $line [gets $f line] $line] close $f set x } {1 a -1 {}} test io-6.14 {Tcl_GetsObj: lf mode: 1 char followed by EOL} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "a\n" close $f set f [open $path(test1)] - fconfigure $f -translation lf + chan configure $f -translation lf set x [list [gets $f line] $line [gets $f line] $line] close $f set x } {1 a -1 {}} test io-6.15 {Tcl_GetsObj: lf mode: several chars} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" close $f set f [open $path(test1)] - fconfigure $f -translation lf + chan configure $f -translation lf set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line [gets $f line] $line] close $f set x @@ -580,62 +580,62 @@ test io-6.16 {Tcl_GetsObj: cr mode: no chars} { set f [open $path(test1) w] close $f set f [open $path(test1)] - fconfigure $f -translation cr + chan configure $f -translation cr set x [list [gets $f line] $line] close $f set x } {-1 {}} test io-6.17 {Tcl_GetsObj: cr mode: lone \n} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "\n" close $f set f [open $path(test1)] - fconfigure $f -translation cr + chan configure $f -translation cr set x [list [gets $f line] $line [gets $f line] $line] close $f set x } [list 1 "\n" -1 ""] test io-6.18 {Tcl_GetsObj: cr mode: lone \r} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "\r" close $f set f [open $path(test1)] - fconfigure $f -translation cr + chan configure $f -translation cr set x [list [gets $f line] $line [gets $f line] $line] close $f set x } {0 {} -1 {}} test io-6.19 {Tcl_GetsObj: cr mode: 1 char} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f a close $f set f [open $path(test1)] - fconfigure $f -translation cr + chan configure $f -translation cr set x [list [gets $f line] $line [gets $f line] $line] close $f set x } {1 a -1 {}} test io-6.20 {Tcl_GetsObj: cr mode: 1 char followed by EOL} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "a\r" close $f set f [open $path(test1)] - fconfigure $f -translation cr + chan configure $f -translation cr set x [list [gets $f line] $line [gets $f line] $line] close $f set x } {1 a -1 {}} test io-6.21 {Tcl_GetsObj: cr mode: several chars} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" close $f set f [open $path(test1)] - fconfigure $f -translation cr + chan configure $f -translation cr set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line [gets $f line] $line] close $f set x @@ -644,84 +644,84 @@ test io-6.22 {Tcl_GetsObj: crlf mode: no chars} { set f [open $path(test1) w] close $f set f [open $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf set x [list [gets $f line] $line] close $f set x } {-1 {}} test io-6.23 {Tcl_GetsObj: crlf mode: lone \n} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "\n" close $f set f [open $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf set x [list [gets $f line] $line [gets $f line] $line] close $f set x } [list 1 "\n" -1 ""] test io-6.24 {Tcl_GetsObj: crlf mode: lone \r} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "\r" close $f set f [open $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf set x [list [gets $f line] $line [gets $f line] $line] close $f set x } [list 1 "\r" -1 ""] test io-6.25 {Tcl_GetsObj: crlf mode: \r\r} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "\r\r" close $f set f [open $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf set x [list [gets $f line] $line [gets $f line] $line] close $f set x } [list 2 "\r\r" -1 ""] test io-6.26 {Tcl_GetsObj: crlf mode: \r\n} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "\r\n" close $f set f [open $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf set x [list [gets $f line] $line [gets $f line] $line] close $f set x } [list 0 "" -1 ""] test io-6.27 {Tcl_GetsObj: crlf mode: 1 char} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f a close $f set f [open $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf set x [list [gets $f line] $line [gets $f line] $line] close $f set x } {1 a -1 {}} test io-6.28 {Tcl_GetsObj: crlf mode: 1 char followed by EOL} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "a\r\n" close $f set f [open $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf set x [list [gets $f line] $line [gets $f line] $line] close $f set x } {1 a -1 {}} test io-6.29 {Tcl_GetsObj: crlf mode: several chars} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" close $f set f [open $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line] close $f set x @@ -730,25 +730,25 @@ test io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} {testchannel} { # if (eol >= dstEnd) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "123456789012345\r\nabcdefghijklmnoprstuvwxyz" close $f set f [open $path(test1)] - fconfigure $f -translation crlf -buffersize 16 + chan configure $f -translation crlf -buffersize 16 set x [list [gets $f line] $line [testchannel inputbuffered $f]] close $f set x } [list 15 "123456789012345" 15] -test io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio testchannel openpipe fileevent} { +test io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio testchannel openpipe chan event} { # (FilterInputBytes() != 0) set f [open "|[list [interpreter] $path(cat)]" w+] - fconfigure $f -translation {crlf lf} -buffering none + chan configure $f -translation {crlf lf} -buffering none puts -nonewline $f "bbbbbbbbbbbbbb\r\n123456789012345\r" - fconfigure $f -buffersize 16 + chan configure $f -buffersize 16 set x [gets $f] - fconfigure $f -blocking 0 - lappend x [gets $f line] $line [fblocked $f] [testchannel inputbuffered $f] + chan configure $f -blocking 0 + lappend x [gets $f line] $line [chan blocked $f] [testchannel inputbuffered $f] close $f set x } [list "bbbbbbbbbbbbbb" -1 "" 1 16] @@ -756,11 +756,11 @@ test io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} {testchannel} # not (FilterInputBytes() != 0) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "123456789012345\r\n123" close $f set f [open $path(test1)] - fconfigure $f -translation crlf -buffersize 16 + chan configure $f -translation crlf -buffersize 16 set x [list [gets $f line] $line [tell $f] [testchannel inputbuffered $f]] close $f set x @@ -769,11 +769,11 @@ test io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} { # eol still equals dstEnd set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "123456789012345\r" close $f set f [open $path(test1)] - fconfigure $f -translation crlf -buffersize 16 + chan configure $f -translation crlf -buffersize 16 set x [list [gets $f line] $line [eof $f]] close $f set x @@ -782,11 +782,11 @@ test io-6.34 {Tcl_GetsObj: crlf mode: buffer exhausted, not followed by \n} { # not (*eol == '\n') set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "123456789012345\rabcd\r\nefg" close $f set f [open $path(test1)] - fconfigure $f -translation crlf -buffersize 16 + chan configure $f -translation crlf -buffersize 16 set x [list [gets $f line] $line [tell $f]] close $f set x @@ -795,151 +795,151 @@ test io-6.35 {Tcl_GetsObj: auto mode: no chars} { set f [open $path(test1) w] close $f set f [open $path(test1)] - fconfigure $f -translation auto + chan configure $f -translation auto set x [list [gets $f line] $line] close $f set x } {-1 {}} test io-6.36 {Tcl_GetsObj: auto mode: lone \n} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "\n" close $f set f [open $path(test1)] - fconfigure $f -translation auto + chan configure $f -translation auto set x [list [gets $f line] $line [gets $f line] $line] close $f set x } [list 0 "" -1 ""] test io-6.37 {Tcl_GetsObj: auto mode: lone \r} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "\r" close $f set f [open $path(test1)] - fconfigure $f -translation auto + chan configure $f -translation auto set x [list [gets $f line] $line [gets $f line] $line] close $f set x } [list 0 "" -1 ""] test io-6.38 {Tcl_GetsObj: auto mode: \r\r} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "\r\r" close $f set f [open $path(test1)] - fconfigure $f -translation auto + chan configure $f -translation auto set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line] close $f set x } [list 0 "" 0 "" -1 ""] test io-6.39 {Tcl_GetsObj: auto mode: \r\n} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "\r\n" close $f set f [open $path(test1)] - fconfigure $f -translation auto + chan configure $f -translation auto set x [list [gets $f line] $line [gets $f line] $line] close $f set x } [list 0 "" -1 ""] test io-6.40 {Tcl_GetsObj: auto mode: 1 char} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f a close $f set f [open $path(test1)] - fconfigure $f -translation auto + chan configure $f -translation auto set x [list [gets $f line] $line [gets $f line] $line] close $f set x } {1 a -1 {}} test io-6.41 {Tcl_GetsObj: auto mode: 1 char followed by EOL} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "a\r\n" close $f set f [open $path(test1)] - fconfigure $f -translation auto + chan configure $f -translation auto set x [list [gets $f line] $line [gets $f line] $line] close $f set x } {1 a -1 {}} test io-6.42 {Tcl_GetsObj: auto mode: several chars} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" close $f set f [open $path(test1)] - fconfigure $f -translation auto + chan configure $f -translation auto set x [list [gets $f line] $line [gets $f line] $line] lappend x [gets $f line] $line [gets $f line] $line [gets $f line] $line close $f set x } [list 4 "abcd" 4 "efgh" 4 "ijkl" 4 "mnop" -1 ""] -test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel openpipe fileevent} { +test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel openpipe chan event} { # if (chanPtr->flags & INPUT_SAW_CR) set f [open "|[list [interpreter] $path(cat)]" w+] - fconfigure $f -translation {auto lf} -buffering none + chan configure $f -translation {auto lf} -buffering none puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" - fconfigure $f -buffersize 16 + chan configure $f -buffersize 16 set x [list [gets $f]] - fconfigure $f -blocking 0 + chan configure $f -blocking 0 lappend x [gets $f line] $line [testchannel queuedcr $f] - fconfigure $f -blocking 1 + chan configure $f -blocking 1 puts -nonewline $f "\nabcd\refg\x1a" lappend x [gets $f line] $line [testchannel queuedcr $f] lappend x [gets $f line] $line close $f set x } [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"] -test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel openpipe fileevent} { +test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel openpipe chan event} { # not (*eol == '\n') set f [open "|[list [interpreter] $path(cat)]" w+] - fconfigure $f -translation {auto lf} -buffering none + chan configure $f -translation {auto lf} -buffering none puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" - fconfigure $f -buffersize 16 + chan configure $f -buffersize 16 set x [list [gets $f]] - fconfigure $f -blocking 0 + chan configure $f -blocking 0 lappend x [gets $f line] $line [testchannel queuedcr $f] - fconfigure $f -blocking 1 + chan configure $f -blocking 1 puts -nonewline $f "abcd\refg\x1a" lappend x [gets $f line] $line [testchannel queuedcr $f] lappend x [gets $f line] $line close $f set x } [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"] -test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio testchannel openpipe fileevent} { +test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio testchannel openpipe chan event} { # Tcl_ExternalToUtf() set f [open "|[list [interpreter] $path(cat)]" w+] - fconfigure $f -translation {auto lf} -buffering none - fconfigure $f -encoding unicode + chan configure $f -translation {auto lf} -buffering none + chan configure $f -encoding unicode puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" - fconfigure $f -buffersize 16 + chan configure $f -buffersize 16 gets $f - fconfigure $f -blocking 0 + chan configure $f -blocking 0 set x [list [gets $f line] $line [testchannel queuedcr $f]] - fconfigure $f -blocking 1 + chan configure $f -blocking 1 puts -nonewline $f "\nabcd\refg" lappend x [gets $f line] $line [testchannel queuedcr $f] close $f set x } [list 15 "123456789abcdef" 1 4 "abcd" 0] -test io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {stdio testchannel openpipe fileevent} { +test io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {stdio testchannel openpipe chan event} { # memmove() set f [open "|[list [interpreter] $path(cat)]" w+] - fconfigure $f -translation {auto lf} -buffering none + chan configure $f -translation {auto lf} -buffering none puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" - fconfigure $f -buffersize 16 + chan configure $f -buffersize 16 gets $f - fconfigure $f -blocking 0 + chan configure $f -blocking 0 set x [list [gets $f line] $line [testchannel queuedcr $f]] - fconfigure $f -blocking 1 + chan configure $f -blocking 1 puts -nonewline $f "\n\x1a" lappend x [gets $f line] $line [testchannel queuedcr $f] close $f @@ -949,11 +949,11 @@ test io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} {testcha # (eol == dstEnd) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "123456789012345\r\nabcdefghijklmnopq" close $f set f [open $path(test1)] - fconfigure $f -translation auto -buffersize 16 + chan configure $f -translation auto -buffersize 16 set x [list [gets $f] [testchannel inputbuffered $f]] close $f set x @@ -962,11 +962,11 @@ test io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} {testc # PeekAhead() did not get any, so (eol >= dstEnd) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "123456789012345\r" close $f set f [open $path(test1)] - fconfigure $f -translation auto -buffersize 16 + chan configure $f -translation auto -buffersize 16 set x [list [gets $f] [testchannel queuedcr $f]] close $f set x @@ -975,7 +975,7 @@ test io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} {testchannel} { # if (*eol == '\n') {skip++} set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "123456\r\n78901" close $f set f [open $path(test1)] @@ -987,7 +987,7 @@ test io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} {testchannel} { # not (*eol == '\n') set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "123456\r78901" close $f set f [open $path(test1)] @@ -999,7 +999,7 @@ test io-6.51 {Tcl_GetsObj: auto mode: \n} { # else if (*eol == '\n') {goto gotoeol;} set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "123456\n78901" close $f set f [open $path(test1)] @@ -1011,11 +1011,11 @@ test io-6.52 {Tcl_GetsObj: saw EOF character} {testchannel} { # if (eof != NULL) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "123456\x1ak9012345\r" close $f set f [open $path(test1)] - fconfigure $f -eofchar \x1a + chan configure $f -eofchar \x1a set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]] close $f set x @@ -1045,30 +1045,30 @@ test io-6.55 {Tcl_GetsObj: overconverted} { # Tcl_ExternalToUtf(), make sure state updated set f [open $path(test1) w] - fconfigure $f -encoding iso2022-jp + chan configure $f -encoding iso2022-jp puts $f "there\u4e00ok\n\u4e01more bytes\nhere" close $f set f [open $path(test1)] - fconfigure $f -encoding iso2022-jp + chan configure $f -encoding iso2022-jp set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line] close $f set x } [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"] -test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio openpipe fileevent} { +test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio openpipe chan event} { update set f [open "|[list [interpreter] $path(cat)]" w+] - fconfigure $f -buffering none + chan configure $f -buffering none puts -nonewline $f "foobar" - fconfigure $f -blocking 0 + chan configure $f -blocking 0 variable x {} after 500 [namespace code { lappend x timeout }] - fileevent $f readable [namespace code { lappend x [gets $f] }] + chan event $f readable [namespace code { lappend x [gets $f] }] vwait [namespace which -variable x] vwait [namespace which -variable x] - fconfigure $f -blocking 1 + chan configure $f -blocking 1 puts -nonewline $f "baz\n" after 500 [namespace code { lappend x timeout }] - fconfigure $f -blocking 0 + chan configure $f -blocking 0 vwait [namespace which -variable x] vwait [namespace which -variable x] close $f @@ -1079,11 +1079,11 @@ test io-7.1 {FilterInputBytes: split up character at end of buffer} { # (result == TCL_CONVERT_MULTIBYTE) set f [open $path(test1) w] - fconfigure $f -encoding shiftjis + chan configure $f -encoding shiftjis puts $f "1234567890123\uff10\uff11\uff12\uff13\uff14\nend" close $f set f [open $path(test1)] - fconfigure $f -encoding shiftjis -buffersize 16 + chan configure $f -encoding shiftjis -buffersize 16 set x [gets $f] close $f set x @@ -1092,43 +1092,43 @@ test io-7.2 {FilterInputBytes: split up character in middle of buffer} { # (bufPtr->nextAdded < bufPtr->bufLength) set f [open $path(test1) w] - fconfigure $f -encoding binary + chan configure $f -encoding binary puts -nonewline $f "1234567890\n123\x82\x4f\x82\x50\x82" close $f set f [open $path(test1)] - fconfigure $f -encoding shiftjis + chan configure $f -encoding shiftjis set x [list [gets $f line] $line [eof $f]] close $f set x } [list 10 "1234567890" 0] test io-7.3 {FilterInputBytes: split up character at EOF} {testchannel} { set f [open $path(test1) w] - fconfigure $f -encoding binary + chan configure $f -encoding binary puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82" close $f set f [open $path(test1)] - fconfigure $f -encoding shiftjis + chan configure $f -encoding shiftjis set x [list [gets $f line] $line] lappend x [tell $f] [testchannel inputbuffered $f] [eof $f] lappend x [gets $f line] $line close $f set x } [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""] -test io-7.4 {FilterInputBytes: recover from split up character} {stdio openpipe fileevent} { +test io-7.4 {FilterInputBytes: recover from split up character} {stdio openpipe chan event} { set f [open "|[list [interpreter] $path(cat)]" w+] - fconfigure $f -encoding binary -buffering none + chan configure $f -encoding binary -buffering none puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82" - fconfigure $f -encoding shiftjis -blocking 0 - fileevent $f read [namespace code "ready $f"] + chan configure $f -encoding shiftjis -blocking 0 + chan event $f read [namespace code "ready $f"] variable x {} proc ready {f} { variable x - lappend x [gets $f line] $line [fblocked $f] + lappend x [gets $f line] $line [chan blocked $f] } vwait [namespace which -variable x] - fconfigure $f -encoding binary -blocking 1 + chan configure $f -encoding binary -blocking 1 puts $f "\x51\x82\x52" - fconfigure $f -encoding shiftjis + chan configure $f -encoding shiftjis vwait [namespace which -variable x] close $f set x @@ -1138,42 +1138,42 @@ test io-8.1 {PeekAhead: only go to device if no more cached data} {testchannel} # (bufPtr->nextPtr == NULL) set f [open $path(test1) w] - fconfigure $f -encoding ascii -translation lf + chan configure $f -encoding ascii -translation lf puts -nonewline $f "123456789012345\r\n2345678" close $f set f [open $path(test1)] - fconfigure $f -encoding ascii -translation auto -buffersize 16 + chan configure $f -encoding ascii -translation auto -buffersize 16 # here gets $f set x [testchannel inputbuffered $f] close $f set x } "7" -test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testchannel openpipe fileevent} { +test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testchannel openpipe chan event} { # not (bufPtr->nextPtr == NULL) set f [open "|[list [interpreter] $path(cat)]" w+] - fconfigure $f -translation lf -encoding ascii -buffering none + chan configure $f -translation lf -encoding ascii -buffering none puts -nonewline $f "123456789012345\r\nbcdefghijklmnopqrstuvwxyz" variable x {} - fileevent $f read [namespace code "ready $f"] + chan event $f read [namespace code "ready $f"] proc ready {f} { variable x lappend x [gets $f line] $line [testchannel inputbuffered $f] } - fconfigure $f -encoding unicode -buffersize 16 -blocking 0 + chan configure $f -encoding unicode -buffersize 16 -blocking 0 vwait [namespace which -variable x] - fconfigure $f -translation auto -encoding ascii -blocking 1 + chan configure $f -translation auto -encoding ascii -blocking 1 # here vwait [namespace which -variable x] close $f set x } [list -1 "" 42 15 "123456789012345" 25] -test io-8.3 {PeekAhead: no cached data available} {stdio testchannel openpipe fileevent} { +test io-8.3 {PeekAhead: no cached data available} {stdio testchannel openpipe chan event} { # (bytesLeft == 0) set f [open "|[list [interpreter] $path(cat)]" w+] - fconfigure $f -translation {auto binary} + chan configure $f -translation {auto binary} puts -nonewline $f "abcdefghijklmno\r" flush $f set x [list [gets $f line] $line [testchannel queuedcr $f]] @@ -1187,11 +1187,11 @@ test io-8.4 {PeekAhead: cached data available in this buffer} { # not (bytesLeft == 0) set f [open $path(test1) w+] - fconfigure $f -translation binary + chan configure $f -translation binary puts $f "${a}\r\nabcdef" close $f set f [open $path(test1)] - fconfigure $f -encoding binary -translation auto + chan configure $f -encoding binary -translation auto # "${a}\r" was converted in one operation (because ENCODING_LINESIZE # is 30). To check if "\n" follows, calls PeekAhead and determines @@ -1202,11 +1202,11 @@ test io-8.4 {PeekAhead: cached data available in this buffer} { set x } $a unset a -test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel openpipe fileevent} { +test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel openpipe chan event} { # (bufPtr->nextAdded < bufPtr->length) set f [open "|[list [interpreter] $path(cat)]" w+] - fconfigure $f -translation {auto binary} + chan configure $f -translation {auto binary} puts -nonewline $f "abcdefghijklmno\r" flush $f # here @@ -1214,11 +1214,11 @@ test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel op close $f set x } {15 abcdefghijklmno 1} -test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel openpipe fileevent} { +test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel openpipe chan event} { # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) set f [open "|[list [interpreter] $path(cat)]" w+] - fconfigure $f -translation {auto binary} -buffersize 16 + chan configure $f -translation {auto binary} -buffersize 16 puts -nonewline $f "abcdefghijklmno\r" flush $f # here @@ -1226,11 +1226,11 @@ test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel openpipe close $f set x } {15 abcdefghijklmno 1} -test io-8.7 {PeekAhead: cleanup} {stdio testchannel openpipe fileevent} { +test io-8.7 {PeekAhead: cleanup} {stdio testchannel openpipe chan event} { # Make sure bytes are removed from buffer. set f [open "|[list [interpreter] $path(cat)]" w+] - fconfigure $f -translation {auto binary} -buffering none + chan configure $f -translation {auto binary} -buffering none puts -nonewline $f "abcdefghijklmno\r" # here set x [list [gets $f line] $line [testchannel queuedcr $f]] @@ -1268,7 +1268,7 @@ test io-10.3 {Tcl_ReadChars: loop until enough copied} { close $f set f [open $path(test1)] - fconfigure $f -buffersize 16 + chan configure $f -buffersize 16 # here set x [read $f 19] close $f @@ -1308,7 +1308,7 @@ test io-11.1 {ReadBytes: want to read a lot} { puts -nonewline $f abcdefghijkl close $f set f [open $path(test1)] - fconfigure $f -encoding binary + chan configure $f -encoding binary # here set x [read $f 1000] close $f @@ -1321,7 +1321,7 @@ test io-11.2 {ReadBytes: want to read all} { puts -nonewline $f abcdefghijkl close $f set f [open $path(test1)] - fconfigure $f -encoding binary + chan configure $f -encoding binary # here set x [read $f] close $f @@ -1334,7 +1334,7 @@ test io-11.3 {ReadBytes: allocate more space} { puts -nonewline $f abcdefghijklmnopqrstuvwxyz close $f set f [open $path(test1)] - fconfigure $f -buffersize 16 -encoding binary + chan configure $f -buffersize 16 -encoding binary # here set x [read $f] close $f @@ -1347,7 +1347,7 @@ test io-11.4 {ReadBytes: EOF char found} { puts $f abcdefghijklmnopqrstuvwxyz close $f set f [open $path(test1)] - fconfigure $f -eofchar m -encoding binary + chan configure $f -eofchar m -encoding binary # here set x [list [read $f] [eof $f] [read $f] [eof $f]] close $f @@ -1385,46 +1385,46 @@ test io-12.3 {ReadChars: allocate more space} { puts -nonewline $f abcdefghijklmnopqrstuvwxyz close $f set f [open $path(test1)] - fconfigure $f -buffersize 16 + chan configure $f -buffersize 16 # here set x [read $f] close $f set x } {abcdefghijklmnopqrstuvwxyz} -test io-12.4 {ReadChars: split-up char} {stdio testchannel openpipe fileevent} { +test io-12.4 {ReadChars: split-up char} {stdio testchannel openpipe chan event} { # (srcRead == 0) set f [open "|[list [interpreter] $path(cat)]" w+] - fconfigure $f -encoding binary -buffering none -buffersize 16 + chan configure $f -encoding binary -buffering none -buffersize 16 puts -nonewline $f "123456789012345\x96" - fconfigure $f -encoding shiftjis -blocking 0 + chan configure $f -encoding shiftjis -blocking 0 - fileevent $f read [namespace code "ready $f"] + chan event $f read [namespace code "ready $f"] proc ready {f} { variable x lappend x [read $f] [testchannel inputbuffered $f] } variable x {} - fconfigure $f -encoding shiftjis + chan configure $f -encoding shiftjis vwait [namespace which -variable x] - fconfigure $f -encoding binary -blocking 1 + chan configure $f -encoding binary -blocking 1 puts -nonewline $f "\x7b" after 500 ;# Give the cat process time to catch up - fconfigure $f -encoding shiftjis -blocking 0 + chan configure $f -encoding shiftjis -blocking 0 vwait [namespace which -variable x] close $f set x } [list "123456789012345" 1 "\u672c" 0] -test io-12.5 {ReadChars: fileevents on partial characters} {stdio openpipe fileevent} { +test io-12.5 {ReadChars: chan events on partial characters} {stdio openpipe chan event} { set path(test1) [makeFile { - fconfigure stdout -encoding binary -buffering none + chan configure stdout -encoding binary -buffering none gets stdin; puts -nonewline "\xe7" gets stdin; puts -nonewline "\x89" gets stdin; puts -nonewline "\xa6" } test1] set f [open "|[list [interpreter] $path(test1)]" r+] - fileevent $f readable [namespace code { + chan event $f readable [namespace code { lappend x [read $f] if {[eof $f]} { lappend x eof @@ -1432,7 +1432,7 @@ test io-12.5 {ReadChars: fileevents on partial characters} {stdio openpipe filee }] puts $f "go1" flush $f - fconfigure $f -blocking 0 -encoding utf-8 + chan configure $f -blocking 0 -encoding utf-8 variable x {} vwait [namespace which -variable x] after 500 [namespace code { lappend x timeout }] @@ -1452,22 +1452,22 @@ test io-12.5 {ReadChars: fileevents on partial characters} {stdio openpipe filee test io-13.1 {TranslateInputEOL: cr mode} {} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "abcd\rdef\r" close $f set f [open $path(test1)] - fconfigure $f -translation cr + chan configure $f -translation cr set x [read $f] close $f set x } "abcd\ndef\n" test io-13.2 {TranslateInputEOL: crlf mode} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "abcd\r\ndef\r\n" close $f set f [open $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf set x [read $f] close $f set x @@ -1476,11 +1476,11 @@ test io-13.3 {TranslateInputEOL: crlf mode: naked cr} { # (src >= srcMax) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "abcd\r\ndef\r" close $f set f [open $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf set x [read $f] close $f set x @@ -1489,11 +1489,11 @@ test io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} { # (src >= srcMax) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "abcd\r\ndef\rfgh" close $f set f [open $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf set x [read $f] close $f set x @@ -1502,23 +1502,23 @@ test io-13.5 {TranslateInputEOL: crlf mode: naked lf} { # (src >= srcMax) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "abcd\r\ndef\nfgh" close $f set f [open $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf set x [read $f] close $f set x } "abcd\ndef\nfgh" -test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testchannel openpipe fileevent} { +test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testchannel openpipe chan event} { # (chanPtr->flags & INPUT_SAW_CR) # This test may fail on slower machines. set f [open "|[list [interpreter] $path(cat)]" w+] - fconfigure $f -blocking 0 -buffering none -translation {auto lf} + chan configure $f -blocking 0 -buffering none -translation {auto lf} - fileevent $f read [namespace code "ready $f"] + chan event $f read [namespace code "ready $f"] proc ready {f} { variable x lappend x [read $f] [testchannel queuedcr $f] @@ -1541,11 +1541,11 @@ test io-13.7 {TranslateInputEOL: auto mode: naked \r} {testchannel openpipe} { # (src >= srcMax) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "abcd\r" close $f set f [open $path(test1)] - fconfigure $f -translation auto + chan configure $f -translation auto set x [list [read $f] [testchannel queuedcr $f]] close $f set x @@ -1554,22 +1554,22 @@ test io-13.8 {TranslateInputEOL: auto mode: \r\n} { # (*src == '\n') set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "abcd\r\ndef" close $f set f [open $path(test1)] - fconfigure $f -translation auto + chan configure $f -translation auto set x [read $f] close $f set x } "abcd\ndef" test io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "abcd\rdef" close $f set f [open $path(test1)] - fconfigure $f -translation auto + chan configure $f -translation auto set x [read $f] close $f set x @@ -1578,11 +1578,11 @@ test io-13.10 {TranslateInputEOL: auto mode: \n} { # not (*src == '\r') set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "abcd\ndef" close $f set f [open $path(test1)] - fconfigure $f -translation auto + chan configure $f -translation auto set x [read $f] close $f set x @@ -1591,11 +1591,11 @@ test io-13.11 {TranslateInputEOL: EOF char} { # (*chanPtr->inEofChar != '\0') set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "abcd\ndefgh" close $f set f [open $path(test1)] - fconfigure $f -translation auto -eofchar e + chan configure $f -translation auto -eofchar e set x [read $f] close $f set x @@ -1604,11 +1604,11 @@ test io-13.12 {TranslateInputEOL: find EOF char in src} { # (*chanPtr->inEofChar != '\0') set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "\r\n\r\n\r\nab\r\n\r\ndef\r\n\r\n\r\n" close $f set f [open $path(test1)] - fconfigure $f -translation auto -eofchar e + chan configure $f -translation auto -eofchar e set x [read $f] close $f set x @@ -1618,7 +1618,7 @@ test io-13.12 {TranslateInputEOL: find EOF char in src} { # Tcl_SetStdChannel and Tcl_GetStdChannel. Incidentally we are # also testing channel table management. -if {[info commands testchannel] != ""} { +if {[info commands testchannel] ne ""} { set consoleFileNames [lsort [testchannel open]] } else { # just to avoid an error @@ -1627,18 +1627,18 @@ if {[info commands testchannel] != ""} { test io-14.1 {Tcl_SetStdChannel and Tcl_GetStdChannel} {testchannel} { set l "" - lappend l [fconfigure stdin -buffering] - lappend l [fconfigure stdout -buffering] - lappend l [fconfigure stderr -buffering] + lappend l [chan configure stdin -buffering] + lappend l [chan configure stdout -buffering] + lappend l [chan configure stderr -buffering] lappend l [lsort [testchannel open]] set l } [list line line none $consoleFileNames] test io-14.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} { interp create x set l "" - lappend l [x eval {fconfigure stdin -buffering}] - lappend l [x eval {fconfigure stdout -buffering}] - lappend l [x eval {fconfigure stderr -buffering}] + lappend l [x eval {chan configure stdin -buffering}] + lappend l [x eval {chan configure stdout -buffering}] + lappend l [x eval {chan configure stderr -buffering}] interp delete x set l } {line line none} @@ -1755,7 +1755,7 @@ test io-14.8 {reuse of stdio special channels} {stdio openpipe} { close $f set c } hello -test io-14.9 {reuse of stdio special channels} {stdio openpipe fileevent} { +test io-14.9 {reuse of stdio special channels} {stdio openpipe chan event} { file delete $path(script) file delete $path(test1) set f [open $path(script) w] @@ -1919,7 +1919,7 @@ test io-20.1 {Tcl_CreateChannel: initial settings} { set old [encoding system] encoding system ascii set f [open $path(test1) w] - set x [fconfigure $f -encoding] + set x [chan configure $f -encoding] close $f encoding system $old close $a @@ -1927,13 +1927,13 @@ test io-20.1 {Tcl_CreateChannel: initial settings} { } {ascii} test io-20.2 {Tcl_CreateChannel: initial settings} {win} { set f [open $path(test1) w+] - set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]] + set x [list [chan configure $f -eofchar] [chan configure $f -translation]] close $f set x } [list [list \x1a ""] {auto crlf}] test io-20.3 {Tcl_CreateChannel: initial settings} {unix} { set f [open $path(test1) w+] - set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]] + set x [list [chan configure $f -eofchar] [chan configure $f -translation]] close $f set x } {{{} {}} {auto lf}} @@ -1945,8 +1945,8 @@ test io-20.5 {Tcl_CreateChannel: install channel in empty slot} {stdio openpipe} set f1 [} puts $f [list open $path(stdout) w]] puts $f { - fconfigure $f1 -buffersize 777 - puts stderr [fconfigure stdout -buffersize] + chan configure $f1 -buffersize 777 + puts stderr [chan configure stdout -buffersize] } close $f set f [open "|[list [interpreter] $path(script)]"] @@ -1985,7 +1985,7 @@ test io-24.1 {Tcl_GetChannelType} {testchannel} { test io-25.1 {Tcl_GetChannelHandle, input} {testchannel} { set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} puts $f "1234567890\n098765432" close $f set f [open $path(test1) r] @@ -1999,7 +1999,7 @@ test io-25.1 {Tcl_GetChannelHandle, input} {testchannel} { test io-25.2 {Tcl_GetChannelHandle, output} {testchannel} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts $f hello set l "" lappend l [testchannel outputbuffered $f] @@ -2034,7 +2034,7 @@ test io-27.1 {FlushChannel, no output buffered} { test io-27.2 {FlushChannel, some output buffered} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} set l "" puts $f hello lappend l [file size $path(test1)] @@ -2047,7 +2047,7 @@ test io-27.2 {FlushChannel, some output buffered} { test io-27.3 {FlushChannel, implicit flush on close} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} set l "" puts $f hello lappend l [file size $path(test1)] @@ -2058,8 +2058,8 @@ test io-27.3 {FlushChannel, implicit flush on close} { test io-27.4 {FlushChannel, implicit flush when buffer fills} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar {} - fconfigure $f -buffersize 60 + chan configure $f -translation lf -eofchar {} + chan configure $f -buffersize 60 set l "" lappend l [file size $path(test1)] for {set i 0} {$i < 12} {incr i} { @@ -2075,7 +2075,7 @@ test io-27.5 {FlushChannel, implicit flush when buffer fills and on close} \ {unixOrPc} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -buffersize 60 -eofchar {} + chan configure $f -translation lf -buffersize 60 -eofchar {} set l "" lappend l [file size $path(test1)] for {set i 0} {$i < 12} {incr i} { @@ -2097,7 +2097,7 @@ test io-27.6 {FlushChannel, async flushing, async close} \ set f [open $path(pipe) w] puts $f "set f \[[list open $path(output) w]]" puts $f { - fconfigure $f -translation lf -buffering none -eofchar {} + chan configure $f -translation lf -buffering none -eofchar {} while {![eof stdin]} { after 20 puts -nonewline $f [read stdin 1024] @@ -2112,7 +2112,7 @@ test io-27.6 {FlushChannel, async flushing, async close} \ set f [open $path(output) w] close $f set f [open "|[list [interpreter] $path(pipe)]" w] - fconfigure $f -blocking off + chan configure $f -blocking off puts -nonewline $f $x close $f set counter 0 @@ -2168,11 +2168,11 @@ test io-28.3 {CloseChannel, not called before output queue is empty} \ # side of the pipe already closed, so that writing would cause an # error "invalid file". - fconfigure stdout -eofchar {} - fconfigure stderr -eofchar {} + chan configure stdout -eofchar {} + chan configure stderr -eofchar {} set f [open $path(output) w] - fconfigure $f -translation lf -buffering none + chan configure $f -translation lf -buffering none for {set x 0} {$x < 20} {incr x} { after 20 puts -nonewline $f [read stdin 1024] @@ -2187,7 +2187,7 @@ test io-28.3 {CloseChannel, not called before output queue is empty} \ set f [open $path(output) w] close $f set f [open "|[list [interpreter] pipe]" r+] - fconfigure $f -blocking off -eofchar {} + chan configure $f -blocking off -eofchar {} puts -nonewline $f $x close $f @@ -2235,7 +2235,7 @@ test io-29.1 {Tcl_WriteChars, channel not writable} { test io-29.2 {Tcl_WriteChars, empty string} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -eofchar {} + chan configure $f -eofchar {} puts -nonewline $f "" close $f file size $path(test1) @@ -2243,7 +2243,7 @@ test io-29.2 {Tcl_WriteChars, empty string} { test io-29.3 {Tcl_WriteChars, nonempty string} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -eofchar {} + chan configure $f -eofchar {} puts -nonewline $f hello close $f file size $path(test1) @@ -2251,7 +2251,7 @@ test io-29.3 {Tcl_WriteChars, nonempty string} { test io-29.4 {Tcl_WriteChars, buffering in full buffering mode} {testchannel} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -buffering full -eofchar {} + chan configure $f -translation lf -buffering full -eofchar {} puts $f hello set l "" lappend l [testchannel outputbuffered $f] @@ -2265,7 +2265,7 @@ test io-29.4 {Tcl_WriteChars, buffering in full buffering mode} {testchannel} { test io-29.5 {Tcl_WriteChars, buffering in line buffering mode} {testchannel} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -buffering line -eofchar {} + chan configure $f -translation lf -buffering line -eofchar {} puts -nonewline $f hello set l "" lappend l [testchannel outputbuffered $f] @@ -2279,7 +2279,7 @@ test io-29.5 {Tcl_WriteChars, buffering in line buffering mode} {testchannel} { test io-29.6 {Tcl_WriteChars, buffering in no buffering mode} {testchannel} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -buffering none -eofchar {} + chan configure $f -translation lf -buffering none -eofchar {} puts -nonewline $f hello set l "" lappend l [testchannel outputbuffered $f] @@ -2293,7 +2293,7 @@ test io-29.6 {Tcl_WriteChars, buffering in no buffering mode} {testchannel} { test io-29.7 {Tcl_Flush, full buffering} {testchannel} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -buffering full -eofchar {} + chan configure $f -translation lf -buffering full -eofchar {} puts -nonewline $f hello set l "" lappend l [testchannel outputbuffered $f] @@ -2310,7 +2310,7 @@ test io-29.7 {Tcl_Flush, full buffering} {testchannel} { test io-29.8 {Tcl_Flush, full buffering} {testchannel} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -buffering line + chan configure $f -translation lf -buffering line puts -nonewline $f hello set l "" lappend l [testchannel outputbuffered $f] @@ -2333,7 +2333,7 @@ test io-29.9 {Tcl_Flush, channel not writable} { test io-29.10 {Tcl_WriteChars, looping and buffering} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} + chan configure $f1 -translation lf -eofchar {} set f2 [open $path(longfile) r] for {set x 0} {$x < 10} {incr x} { puts $f1 [gets $f2] @@ -2345,7 +2345,7 @@ test io-29.10 {Tcl_WriteChars, looping and buffering} { test io-29.11 {Tcl_WriteChars, no newline, implicit flush} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -eofchar {} + chan configure $f1 -eofchar {} set f2 [open $path(longfile) r] for {set x 0} {$x < 10} {incr x} { puts -nonewline $f1 [gets $f2] @@ -2371,7 +2371,7 @@ test io-29.12 {Tcl_WriteChars on a pipe} {stdio openpipe} { for {set x 0} {$x < 10} {incr x} { set l1 [gets $f1] set l2 [gets $f2] - if {"$l1" != "$l2"} { + if {$l1 ne $l2} { set y broken } } @@ -2390,18 +2390,18 @@ test io-29.13 {Tcl_WriteChars to a pipe, line buffered} {stdio openpipe} { close $f1 set y ok set f1 [open "|[list [interpreter] $path(pipe)]" r+] - fconfigure $f1 -buffering line + chan configure $f1 -buffering line set f2 [open $path(longfile) r] set line [gets $f2] puts $f1 $line set backline [gets $f1] - if {"$line" != "$backline"} { + if {$line ne $backline} { set y broken } set line [gets $f2] puts $f1 $line set backline [gets $f1] - if {"$line" != "$backline"} { + if {$line ne $backline} { set y broken } close $f1 @@ -2440,7 +2440,7 @@ test io-29.16 {Tcl_Flush on pipe opened only for reading} {stdio openpipe} { test io-29.17 {Tcl_WriteChars buffers, then Tcl_Flush flushes} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf + chan configure $f1 -translation lf puts $f1 hello puts $f1 hello puts $f1 hello @@ -2453,7 +2453,7 @@ test io-29.18 {Tcl_WriteChars and Tcl_Flush intermixed} { file delete $path(test1) set x "" set f1 [open $path(test1) w] - fconfigure $f1 -translation lf + chan configure $f1 -translation lf puts $f1 hello puts $f1 hello puts $f1 hello @@ -2471,7 +2471,7 @@ test io-29.18 {Tcl_WriteChars and Tcl_Flush intermixed} { test io-29.19 {Explicit and implicit flushes} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} + chan configure $f1 -translation lf -eofchar {} set x "" puts $f1 hello puts $f1 hello @@ -2489,7 +2489,7 @@ test io-29.19 {Explicit and implicit flushes} { test io-29.20 {Implicit flush when buffer is full} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} + chan configure $f1 -translation lf -eofchar {} set line "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" for {set x 0} {$x < 100} {incr x} { puts $f1 $line @@ -2522,7 +2522,7 @@ test io-29.22 {Tcl_Flush called at other end of pipe} {stdio openpipe} { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 { - fconfigure stdout -buffering full + chan configure stdout -buffering full puts hello puts hello flush stdout @@ -2576,7 +2576,7 @@ test io-29.24 {Tcl_WriteChars and Tcl_Flush move end of file} { close $f set x } "{} {Line 1\nLine 2}" -test io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio openpipe fileevent} { +test io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio openpipe chan event} { file delete $path(test3) set f [open "|[list [interpreter] $path(cat) | [interpreter] $path(cat) > $path(test3)]" w] puts $f "Line 1" @@ -2627,7 +2627,7 @@ test io-29.27 {Tcl_Flush on closed pipeline} {stdio openpipe} { test io-29.28 {Tcl_WriteChars, lf mode} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} puts $f hello\nthere\nand\nhere flush $f set s [file size $path(test1)] @@ -2637,7 +2637,7 @@ test io-29.28 {Tcl_WriteChars, lf mode} { test io-29.29 {Tcl_WriteChars, cr mode} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar {} + chan configure $f -translation cr -eofchar {} puts $f hello\nthere\nand\nhere close $f file size $path(test1) @@ -2645,7 +2645,7 @@ test io-29.29 {Tcl_WriteChars, cr mode} { test io-29.30 {Tcl_WriteChars, crlf mode} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf -eofchar {} + chan configure $f -translation crlf -eofchar {} puts $f hello\nthere\nand\nhere close $f file size $path(test1) @@ -2657,7 +2657,7 @@ test io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} { file delete $path(output) set f [open $path(pipe) w] puts $f "set f \[[list open $path(output) w]]" - puts $f {fconfigure $f -translation lf} + puts $f {chan configure $f -translation lf} set x [list while {![eof stdin]}] set x "$x {" puts $f $x @@ -2673,7 +2673,7 @@ test io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} { set f [open $path(output) w] close $f set f [open "|[list [interpreter] $path(pipe)]" r+] - fconfigure $f -blocking off + chan configure $f -blocking off puts -nonewline $f $x close $f set counter 0 @@ -2700,7 +2700,7 @@ test io-29.32 {Tcl_WriteChars, background flush to slow reader} \ file delete $path(output) set f [open $path(pipe) w] puts $f "set f \[[list open $path(output) w]]" - puts $f {fconfigure $f -translation lf} + puts $f {chan configure $f -translation lf} set x [list while {![eof stdin]}] set x "$x \{" puts $f $x @@ -2717,7 +2717,7 @@ test io-29.32 {Tcl_WriteChars, background flush to slow reader} \ set f [open $path(output) w] close $f set f [open "|[list [interpreter] $path(pipe)]" r+] - fconfigure $f -blocking off + chan configure $f -blocking off puts -nonewline $f $x close $f set counter 0 @@ -2734,7 +2734,7 @@ test io-29.32 {Tcl_WriteChars, background flush to slow reader} \ test io-29.33 {Tcl_Flush, implicit flush on exit} {exec} { set f [open $path(script) w] puts $f "set f \[[list open $path(test1) w]]" - puts $f {fconfigure $f -translation lf + puts $f {chan configure $f -translation lf puts $f hello puts $f bye puts $f strange @@ -2750,7 +2750,7 @@ set path(script2) [makeFile {} script2] test io-29.33b {TIP#398, no implicit flush of nonblocking on exit} {exec} { set f [open $path(script) w] puts $f { - fconfigure stdout -blocking 0 + chan configure stdout -blocking 0 puts -nonewline stdout [string repeat A 655360] flush stdout } @@ -2760,13 +2760,13 @@ test io-29.33b {TIP#398, no implicit flush of nonblocking on exit} {exec} { close $f set t1 [clock milliseconds] set ff [open "|[list [interpreter] $path(script2)]" w] - catch {unset ::env(TCL_FLUSH_NONBLOCKING_ON_EXIT)} + unset -nocomplain ::env(TCL_FLUSH_NONBLOCKING_ON_EXIT) exec [interpreter] $path(script) >@ $ff set t2 [clock milliseconds] close $ff - expr {($t2-$t1)/2000 ? $t2-$t1 : 0} + expr {(($t2 - $t1) / 2000) ? ($t2 - $t1) : 0} } 0 -test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMac fileevent} { +test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMac chan event} { variable c 0 variable x running set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz @@ -2777,8 +2777,8 @@ test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMa } proc accept {s a p} { variable x - fileevent $s readable [namespace code [list readit $s]] - fconfigure $s -blocking off + chan event $s readable [namespace code [list readit $s]] + chan configure $s -blocking off set x accepted } proc readit {s} { @@ -2789,21 +2789,21 @@ test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMa if {[eof $s]} { close $s set x done - } elseif {([string length $l] > 0) || ![fblocked $s]} { + } elseif {([string length $l] > 0) || (![chan blocked $s])} { incr c } } set ss [socket -server [namespace code accept] -myaddr 127.0.0.1 0] - set cs [socket 127.0.0.1 [lindex [fconfigure $ss -sockname] 2]] + set cs [socket 127.0.0.1 [lindex [chan configure $ss -sockname] 2]] vwait [namespace which -variable x] - fconfigure $cs -blocking off + chan configure $cs -blocking off writelots $cs $l close $cs close $ss vwait [namespace which -variable x] set c } 2000 -test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket tempNotMac fileevent} { +test io-29.35 {Tcl_Close vs chan event vs multiple interpreters} {socket tempNotMac fileevent} { # On Mac, this test screws up sockets such that subsequent tests using port 2828 # either cause errors or panic(). @@ -2816,7 +2816,7 @@ test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket tempNotM puts $s hello close $s } - set c [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]] + set c [socket 127.0.0.1 [lindex [chan configure $s -sockname] 2]] interp share {} $c x interp share {} $c y close $c @@ -2836,8 +2836,8 @@ test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket tempNotM } } } - x eval "fileevent $c readable \{readit $c\}" - y eval "fileevent $c readable \{readit $c\}" + x eval "chan event $c readable \{readit $c\}" + y eval "chan event $c readable \{readit $c\}" y eval [list close $c] update close $s @@ -2850,11 +2850,11 @@ test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket tempNotM test io-30.1 {Tcl_Write lf, Tcl_Read lf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation lf + chan configure $f -translation lf set x [read $f] close $f set x @@ -2862,11 +2862,11 @@ test io-30.1 {Tcl_Write lf, Tcl_Read lf} { test io-30.2 {Tcl_Write lf, Tcl_Read cr} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation cr + chan configure $f -translation cr set x [read $f] close $f set x @@ -2874,11 +2874,11 @@ test io-30.2 {Tcl_Write lf, Tcl_Read cr} { test io-30.3 {Tcl_Write lf, Tcl_Read crlf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation crlf + chan configure $f -translation crlf set x [read $f] close $f set x @@ -2886,11 +2886,11 @@ test io-30.3 {Tcl_Write lf, Tcl_Read crlf} { test io-30.4 {Tcl_Write cr, Tcl_Read cr} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr + chan configure $f -translation cr puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation cr + chan configure $f -translation cr set x [read $f] close $f set x @@ -2898,11 +2898,11 @@ test io-30.4 {Tcl_Write cr, Tcl_Read cr} { test io-30.5 {Tcl_Write cr, Tcl_Read lf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr + chan configure $f -translation cr puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation lf + chan configure $f -translation lf set x [read $f] close $f set x @@ -2910,11 +2910,11 @@ test io-30.5 {Tcl_Write cr, Tcl_Read lf} { test io-30.6 {Tcl_Write cr, Tcl_Read crlf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr + chan configure $f -translation cr puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation crlf + chan configure $f -translation crlf set x [read $f] close $f set x @@ -2922,11 +2922,11 @@ test io-30.6 {Tcl_Write cr, Tcl_Read crlf} { test io-30.7 {Tcl_Write crlf, Tcl_Read crlf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation crlf + chan configure $f -translation crlf set x [read $f] close $f set x @@ -2934,11 +2934,11 @@ test io-30.7 {Tcl_Write crlf, Tcl_Read crlf} { test io-30.8 {Tcl_Write crlf, Tcl_Read lf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation lf + chan configure $f -translation lf set x [read $f] close $f set x @@ -2946,11 +2946,11 @@ test io-30.8 {Tcl_Write crlf, Tcl_Read lf} { test io-30.9 {Tcl_Write crlf, Tcl_Read cr} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation cr + chan configure $f -translation cr set x [read $f] close $f set x @@ -2958,12 +2958,12 @@ test io-30.9 {Tcl_Write crlf, Tcl_Read cr} { test io-30.10 {Tcl_Write lf, Tcl_Read auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] set c [read $f] - set x [fconfigure $f -translation] + set x [chan configure $f -translation] close $f list $c $x } {{hello @@ -2974,12 +2974,12 @@ here test io-30.11 {Tcl_Write cr, Tcl_Read auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr + chan configure $f -translation cr puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] set c [read $f] - set x [fconfigure $f -translation] + set x [chan configure $f -translation] close $f list $c $x } {{hello @@ -2990,12 +2990,12 @@ here test io-30.12 {Tcl_Write crlf, Tcl_Read auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] set c [read $f] - set x [fconfigure $f -translation] + set x [chan configure $f -translation] close $f list $c $x } {{hello @@ -3006,7 +3006,7 @@ here test io-30.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf set line "123456789ABCDE" ;# 14 char plus crlf puts -nonewline $f x ;# shift crlf across block boundary for {set i 0} {$i < 700} {incr i} { @@ -3014,15 +3014,15 @@ test io-30.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} { } close $f set f [open $path(test1) r] - fconfigure $f -translation auto + chan configure $f -translation auto set c [read $f] close $f string length $c -} [expr 700*15+1] +} [expr {(700 * 15) + 1}] test io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf set line "123456789ABCDE" ;# 14 char plus crlf puts -nonewline $f x ;# shift crlf across block boundary for {set i 0} {$i < 700} {incr i} { @@ -3030,19 +3030,19 @@ test io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} { } close $f set f [open $path(test1) r] - fconfigure $f -translation crlf + chan configure $f -translation crlf set c [read $f] close $f string length $c -} [expr 700*15+1] +} [expr {(700 * 15) + 1}] test io-30.15 {Tcl_Write mixed, Tcl_Read auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts $f hello\nthere\nand\rhere close $f set f [open $path(test1) r] - fconfigure $f -translation auto + chan configure $f -translation auto set c [read $f] close $f set c @@ -3054,11 +3054,11 @@ here test io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f hello\nthere\nand\rhere\n\x1a close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + chan configure $f -eofchar \x1a -translation auto set c [read $f] close $f set c @@ -3070,11 +3070,11 @@ here test io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {win} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -eofchar \x1a -translation lf + chan configure $f -eofchar \x1a -translation lf puts $f hello\nthere\nand\rhere close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + chan configure $f -eofchar \x1a -translation auto set c [read $f] close $f set c @@ -3086,12 +3086,12 @@ here test io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf set s [format "abc\ndef\n%cghi\nqrs" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + chan configure $f -eofchar \x1a -translation auto set l "" lappend l [gets $f] lappend l [gets $f] @@ -3106,12 +3106,12 @@ test io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} { test io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf set s [format "abc\ndef\n%cghi\nqrs" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + chan configure $f -eofchar \x1a -translation auto set l "" lappend l [gets $f] lappend l [gets $f] @@ -3126,12 +3126,12 @@ test io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} { test io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} set s [format "abc\ndef\n%cghi\nqrs" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} set l "" lappend l [gets $f] lappend l [gets $f] @@ -3148,12 +3148,12 @@ test io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} { test io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} set s [format "abc\ndef\n%cghi\nqrs" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar {} + chan configure $f -translation cr -eofchar {} set l "" set x [gets $f] lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs\n"] @@ -3166,12 +3166,12 @@ test io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} { test io-30.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} set s [format "abc\ndef\n%cghi\nqrs" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar {} + chan configure $f -translation crlf -eofchar {} set l "" set x [gets $f] lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs\n"] @@ -3184,12 +3184,12 @@ test io-30.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} { test io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf set c [format abc\ndef\n%cqrs\ntuv 26] puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1a set c [string length [read $f]] set e [eof $f] close $f @@ -3198,12 +3198,12 @@ test io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} { test io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf set c [format abc\ndef\n%cqrs\ntuv 26] puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar \x1a + chan configure $f -translation lf -eofchar \x1a set c [string length [read $f]] set e [eof $f] close $f @@ -3212,12 +3212,12 @@ test io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} { test io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr + chan configure $f -translation cr set c [format abc\ndef\n%cqrs\ntuv 26] puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1a set c [string length [read $f]] set e [eof $f] close $f @@ -3226,12 +3226,12 @@ test io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} { test io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr + chan configure $f -translation cr set c [format abc\ndef\n%cqrs\ntuv 26] puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar \x1a + chan configure $f -translation cr -eofchar \x1a set c [string length [read $f]] set e [eof $f] close $f @@ -3240,12 +3240,12 @@ test io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} { test io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf set c [format abc\ndef\n%cqrs\ntuv 26] puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1a set c [string length [read $f]] set e [eof $f] close $f @@ -3254,12 +3254,12 @@ test io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} { test io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf set c [format abc\ndef\n%cqrs\ntuv 26] puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1a + chan configure $f -translation crlf -eofchar \x1a set c [string length [read $f]] set e [eof $f] close $f @@ -3271,88 +3271,88 @@ test io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} { test io-31.1 {Tcl_Write lf, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] set l "" lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] close $f set l } {hello 6 auto there 12 auto} test io-31.2 {Tcl_Write cr, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr + chan configure $f -translation cr puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] set l "" lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] close $f set l } {hello 6 auto there 12 auto} test io-31.3 {Tcl_Write crlf, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] set l "" lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] close $f set l } {hello 7 auto there 14 auto} test io-31.4 {Tcl_Write lf, Tcl_Gets lf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation lf + chan configure $f -translation lf set l "" lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] close $f set l } {hello 6 lf there 12 lf} test io-31.5 {Tcl_Write lf, Tcl_Gets cr} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation cr + chan configure $f -translation cr set l "" lappend l [string length [gets $f]] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] close $f set l @@ -3360,19 +3360,19 @@ test io-31.5 {Tcl_Write lf, Tcl_Gets cr} { test io-31.6 {Tcl_Write lf, Tcl_Gets crlf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation crlf + chan configure $f -translation crlf set l "" lappend l [string length [gets $f]] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] close $f set l @@ -3380,19 +3380,19 @@ test io-31.6 {Tcl_Write lf, Tcl_Gets crlf} { test io-31.7 {Tcl_Write cr, Tcl_Gets cr} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr + chan configure $f -translation cr puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation cr + chan configure $f -translation cr set l "" lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] close $f set l @@ -3400,19 +3400,19 @@ test io-31.7 {Tcl_Write cr, Tcl_Gets cr} { test io-31.8 {Tcl_Write cr, Tcl_Gets lf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr + chan configure $f -translation cr puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation lf + chan configure $f -translation lf set l "" lappend l [string length [gets $f]] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] close $f set l @@ -3420,19 +3420,19 @@ test io-31.8 {Tcl_Write cr, Tcl_Gets lf} { test io-31.9 {Tcl_Write cr, Tcl_Gets crlf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr + chan configure $f -translation cr puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation crlf + chan configure $f -translation crlf set l "" lappend l [string length [gets $f]] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] close $f set l @@ -3440,19 +3440,19 @@ test io-31.9 {Tcl_Write cr, Tcl_Gets crlf} { test io-31.10 {Tcl_Write crlf, Tcl_Gets crlf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation crlf + chan configure $f -translation crlf set l "" lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] close $f set l @@ -3460,19 +3460,19 @@ test io-31.10 {Tcl_Write crlf, Tcl_Gets crlf} { test io-31.11 {Tcl_Write crlf, Tcl_Gets cr} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation cr + chan configure $f -translation cr set l "" lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] lappend l [string length [gets $f]] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] close $f set l @@ -3480,19 +3480,19 @@ test io-31.11 {Tcl_Write crlf, Tcl_Gets cr} { test io-31.12 {Tcl_Write crlf, Tcl_Gets lf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation lf + chan configure $f -translation lf set l "" lappend l [string length [gets $f]] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] lappend l [string length [gets $f]] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] close $f set l @@ -3500,8 +3500,8 @@ test io-31.12 {Tcl_Write crlf, Tcl_Gets lf} { test io-31.13 {binary mode is synonym of lf mode} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation binary - set x [fconfigure $f -translation] + chan configure $f -translation binary + set x [chan configure $f -translation] close $f set x } lf @@ -3512,11 +3512,11 @@ test io-31.13 {binary mode is synonym of lf mode} { test io-31.14 {Tcl_Write mixed, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts $f hello\nthere\rand\r\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation auto + chan configure $f -translation auto set l "" lappend l [gets $f] lappend l [gets $f] @@ -3531,11 +3531,11 @@ test io-31.14 {Tcl_Write mixed, Tcl_Gets auto} { test io-31.15 {Tcl_Write mixed, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f hello\nthere\rand\r\nhere\r close $f set f [open $path(test1) r] - fconfigure $f -translation auto + chan configure $f -translation auto set l "" lappend l [gets $f] lappend l [gets $f] @@ -3550,7 +3550,7 @@ test io-31.15 {Tcl_Write mixed, Tcl_Gets auto} { test io-31.16 {Tcl_Write mixed, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f hello\nthere\rand\r\nhere\n close $f set f [open $path(test1) r] @@ -3568,11 +3568,11 @@ test io-31.16 {Tcl_Write mixed, Tcl_Gets auto} { test io-31.17 {Tcl_Write mixed, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f hello\nthere\rand\r\nhere\r\n close $f set f [open $path(test1) r] - fconfigure $f -translation auto + chan configure $f -translation auto set l "" lappend l [gets $f] lappend l [gets $f] @@ -3587,12 +3587,12 @@ test io-31.17 {Tcl_Write mixed, Tcl_Gets auto} { test io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf set s [format "hello\nthere\nand\rhere\n\%c" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + chan configure $f -eofchar \x1a -translation auto set l "" lappend l [gets $f] lappend l [gets $f] @@ -3607,11 +3607,11 @@ test io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} { test io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -eofchar \x1a -translation lf + chan configure $f -eofchar \x1a -translation lf puts $f hello\nthere\nand\rhere close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + chan configure $f -eofchar \x1a -translation auto set l "" lappend l [gets $f] lappend l [gets $f] @@ -3626,13 +3626,13 @@ test io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} { test io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf set s [format "abc\ndef\n%cqrs\ntuv" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a - fconfigure $f -translation auto + chan configure $f -eofchar \x1a + chan configure $f -translation auto set l "" lappend l [gets $f] lappend l [gets $f] @@ -3645,12 +3645,12 @@ test io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} { test io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf set s [format "abc\ndef\n%cqrs\ntuv" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + chan configure $f -eofchar \x1a -translation auto set l "" lappend l [gets $f] lappend l [gets $f] @@ -3663,12 +3663,12 @@ test io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} { test io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} set s [format "abc\ndef\n%cqrs\ntuv" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} set l "" lappend l [gets $f] lappend l [gets $f] @@ -3685,12 +3685,12 @@ test io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} { test io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar {} + chan configure $f -translation cr -eofchar {} set s [format "abc\ndef\n%cqrs\ntuv" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar {} + chan configure $f -translation cr -eofchar {} set l "" lappend l [gets $f] lappend l [gets $f] @@ -3707,12 +3707,12 @@ test io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} { test io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf -eofchar {} + chan configure $f -translation crlf -eofchar {} set s [format "abc\ndef\n%cqrs\ntuv" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar {} + chan configure $f -translation crlf -eofchar {} set l "" lappend l [gets $f] lappend l [gets $f] @@ -3729,12 +3729,12 @@ test io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} { test io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf set s [format "abc\ndef\n%cqrs\ntuv" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1a set l "" lappend l [gets $f] lappend l [gets $f] @@ -3747,12 +3747,12 @@ test io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} { test io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf set s [format "abc\ndef\n%cqrs\ntuv" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar \x1a + chan configure $f -translation lf -eofchar \x1a set l "" lappend l [gets $f] lappend l [gets $f] @@ -3765,12 +3765,12 @@ test io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} { test io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar {} + chan configure $f -translation cr -eofchar {} set s [format "abc\ndef\n%cqrs\ntuv" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1a set l "" lappend l [gets $f] lappend l [gets $f] @@ -3783,12 +3783,12 @@ test io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} { test io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar {} + chan configure $f -translation cr -eofchar {} set s [format "abc\ndef\n%cqrs\ntuv" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar \x1a + chan configure $f -translation cr -eofchar \x1a set l "" lappend l [gets $f] lappend l [gets $f] @@ -3801,12 +3801,12 @@ test io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} { test io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf -eofchar {} + chan configure $f -translation crlf -eofchar {} set s [format "abc\ndef\n%cqrs\ntuv" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1a set l "" lappend l [gets $f] lappend l [gets $f] @@ -3819,12 +3819,12 @@ test io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} { test io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf -eofchar {} + chan configure $f -translation crlf -eofchar {} set s [format "abc\ndef\n%cqrs\ntuv" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1a + chan configure $f -translation crlf -eofchar \x1a set l "" lappend l [gets $f] lappend l [gets $f] @@ -3837,7 +3837,7 @@ test io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} { test io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf set line "123456789ABCDE" ;# 14 char plus crlf puts -nonewline $f x ;# shift crlf across block boundary for {set i 0} {$i < 700} {incr i} { @@ -3845,18 +3845,18 @@ test io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} { } close $f set f [open $path(test1) r] - fconfigure $f -translation crlf + chan configure $f -translation crlf set c "" while {[gets $f line] >= 0} { append c $line\n } close $f string length $c -} [expr 700*15+1] +} [expr {(700 * 15) + 1}] test io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf set line "123456789ABCDE" ;# 14 char plus crlf puts -nonewline $f x ;# shift crlf across block boundary for {set i 0} {$i < 700} {incr i} { @@ -3864,14 +3864,14 @@ test io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { } close $f set f [open $path(test1) r] - fconfigure $f -translation auto + chan configure $f -translation auto set c "" while {[gets $f line] >= 0} { append c $line\n } close $f string length $c -} [expr 700*15+1] +} [expr {(700 * 15) + 1}] # Test Tcl_Read and buffering. @@ -3897,7 +3897,7 @@ test io-32.4 {Tcl_Read, positive byte count} { } 1024 test io-32.5 {Tcl_Read, multiple buffers} { set f [open $path(longfile) r] - fconfigure $f -buffersize 100 + chan configure $f -buffersize 100 set x [read $f 1024] set s [string length $x] unset x @@ -3918,7 +3918,7 @@ test io-32.6 {Tcl_Read, very large read} { } ok test io-32.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} { set f1 [open $path(longfile) r] - fconfigure $f1 -blocking off + chan configure $f1 -blocking off set z [read $f1 20] close $f1 set l [string length $z] @@ -3930,7 +3930,7 @@ test io-32.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} { } ok test io-32.8 {Tcl_Read, nonblocking, file} {nonBlockFiles} { set f1 [open $path(longfile) r] - fconfigure $f1 -blocking off + chan configure $f1 -blocking off set z [read $f1 1000000] close $f1 set x ok @@ -4058,7 +4058,7 @@ test io-33.1 {Tcl_Gets, reading what was written} { set f1 [open $path(test1) r] set x [gets $f1] set z ok - if {"$x" != "$y"} { + if {$x ne $y} { set z broken } close $f1 @@ -4086,7 +4086,7 @@ test io-33.3 {Tcl_Gets from pipe} {stdio openpipe} { set x [gets $f1] close $f1 set z ok - if {"$x" != "hello"} { + if {$x ne "hello"} { set z broken } set z @@ -4132,7 +4132,7 @@ test io-33.7 {Tcl_Gets and bad variable} { puts $f "Line 1" puts $f "Line 2" close $f - catch {unset x} + unset -nocomplain x set x 24 set f [open $path(test3) r] set result [list [catch {gets $f x(0)} msg] $msg] @@ -4141,39 +4141,39 @@ test io-33.7 {Tcl_Gets and bad variable} { } {1 {can't set "x(0)": variable isn't array}} test io-33.8 {Tcl_Gets, exercising double buffering} { set f [open $path(test3) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} set x "" for {set y 0} {$y < 99} {incr y} {set x "a$x"} for {set y 0} {$y < 100} {incr y} {puts $f $x} close $f set f [open $path(test3) r] - fconfigure $f -translation lf + chan configure $f -translation lf for {set y 0} {$y < 100} {incr y} {gets $f} close $f set y } 100 test io-33.9 {Tcl_Gets, exercising double buffering} { set f [open $path(test3) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} set x "" for {set y 0} {$y < 99} {incr y} {set x "a$x"} for {set y 0} {$y < 200} {incr y} {puts $f $x} close $f set f [open $path(test3) r] - fconfigure $f -translation lf + chan configure $f -translation lf for {set y 0} {$y < 200} {incr y} {gets $f} close $f set y } 200 test io-33.10 {Tcl_Gets, exercising double buffering} { set f [open $path(test3) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} set x "" for {set y 0} {$y < 99} {incr y} {set x "a$x"} for {set y 0} {$y < 300} {incr y} {puts $f $x} close $f set f [open $path(test3) r] - fconfigure $f -translation lf + chan configure $f -translation lf for {set y 0} {$y < 300} {incr y} {gets $f} close $f set y @@ -4191,7 +4191,7 @@ test io-34.1 {Tcl_Seek to current position at start of file} { test io-34.2 {Tcl_Seek to offset from start} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} + chan configure $f1 -translation lf -eofchar {} puts $f1 "abcdefghijklmnopqrstuvwxyz" puts $f1 "abcdefghijklmnopqrstuvwxyz" close $f1 @@ -4204,7 +4204,7 @@ test io-34.2 {Tcl_Seek to offset from start} { test io-34.3 {Tcl_Seek to end of file} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} + chan configure $f1 -translation lf -eofchar {} puts $f1 "abcdefghijklmnopqrstuvwxyz" puts $f1 "abcdefghijklmnopqrstuvwxyz" close $f1 @@ -4217,7 +4217,7 @@ test io-34.3 {Tcl_Seek to end of file} { test io-34.4 {Tcl_Seek to offset from end of file} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} + chan configure $f1 -translation lf -eofchar {} puts $f1 "abcdefghijklmnopqrstuvwxyz" puts $f1 "abcdefghijklmnopqrstuvwxyz" close $f1 @@ -4230,7 +4230,7 @@ test io-34.4 {Tcl_Seek to offset from end of file} { test io-34.5 {Tcl_Seek to offset from current position} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} + chan configure $f1 -translation lf -eofchar {} puts $f1 "abcdefghijklmnopqrstuvwxyz" puts $f1 "abcdefghijklmnopqrstuvwxyz" close $f1 @@ -4244,7 +4244,7 @@ test io-34.5 {Tcl_Seek to offset from current position} { test io-34.6 {Tcl_Seek to offset from end of file} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} + chan configure $f1 -translation lf -eofchar {} puts $f1 "abcdefghijklmnopqrstuvwxyz" puts $f1 "abcdefghijklmnopqrstuvwxyz" close $f1 @@ -4259,7 +4259,7 @@ test io-34.6 {Tcl_Seek to offset from end of file} { test io-34.7 {Tcl_Seek to offset from end of file, then to current position} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} + chan configure $f1 -translation lf -eofchar {} puts $f1 "abcdefghijklmnopqrstuvwxyz" puts $f1 "abcdefghijklmnopqrstuvwxyz" close $f1 @@ -4282,7 +4282,7 @@ test io-34.8 {Tcl_Seek on pipes: not supported} {stdio openpipe} { test io-34.9 {Tcl_Seek, testing buffered input flushing} { file delete $path(test3) set f [open $path(test3) w] - fconfigure $f -eofchar {} + chan configure $f -eofchar {} puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" close $f set f [open $path(test3) RDWR] @@ -4305,11 +4305,11 @@ test io-34.9 {Tcl_Seek, testing buffered input flushing} { set path(test3) [makeFile {} test3] test io-34.10 {Tcl_Seek testing flushing of buffered input} { set f [open $path(test3) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts $f xyz\n123 close $f set f [open $path(test3) r+] - fconfigure $f -translation lf + chan configure $f -translation lf set x [gets $f] seek $f 0 current puts $f 456 @@ -4330,11 +4330,11 @@ test io-34.11 {Tcl_Seek testing flushing of buffered output} { } "zzy xyzzy" test io-34.12 {Tcl_Seek testing combination of write, seek back and read} { set f [open $path(test3) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} puts $f xyz\n123 close $f set f [open $path(test3) a+] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} puts $f xyzzy flush $f set x [tell $f] @@ -4355,7 +4355,7 @@ test io-34.13 {Tcl_Tell at start of file} { test io-34.14 {Tcl_Tell after seek to end of file} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} + chan configure $f1 -translation lf -eofchar {} puts $f1 "abcdefghijklmnopqrstuvwxyz" puts $f1 "abcdefghijklmnopqrstuvwxyz" close $f1 @@ -4368,7 +4368,7 @@ test io-34.14 {Tcl_Tell after seek to end of file} { test io-34.15 {Tcl_Tell combined with seeking} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} + chan configure $f1 -translation lf -eofchar {} puts $f1 "abcdefghijklmnopqrstuvwxyz" puts $f1 "abcdefghijklmnopqrstuvwxyz" close $f1 @@ -4398,11 +4398,11 @@ test io-34.17 {Tcl_Tell on pipe: always -1} {stdio openpipe} { test io-34.18 {Tcl_Tell combined with seeking and reading} { file delete $path(test2) set f [open $path(test2) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} puts -nonewline $f "line1\nline2\nline3\nline4\nline5\n" close $f set f [open $path(test2)] - fconfigure $f -translation lf + chan configure $f -translation lf set x [tell $f] read $f 3 lappend x [tell $f] @@ -4417,7 +4417,7 @@ test io-34.18 {Tcl_Tell combined with seeking and reading} { } {0 3 2 12 30} test io-34.19 {Tcl_Tell combined with opening in append mode} { set f [open $path(test3) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} puts $f "abcdefghijklmnopqrstuvwxyz" puts $f "abcdefghijklmnopqrstuvwxyz" close $f @@ -4444,7 +4444,7 @@ test io-34.20 {Tcl_Tell combined with writing} { test io-34.21 {Tcl_Seek and Tcl_Tell on large files} {largefileSupport} { file delete $path(test3) set f [open $path(test3) w] - fconfigure $f -encoding binary + chan configure $f -encoding binary set l "" lappend l [tell $f] puts -nonewline $f abcdef @@ -4530,7 +4530,7 @@ test io-35.4 {Tcl_Eof, eof detection on nonblocking file} {nonBlockFiles} { set f [open $path(test1) w] close $f set f [open $path(test1) r] - fconfigure $f -blocking off + chan configure $f -blocking off set l "" lappend l [gets $f] lappend l [eof $f] @@ -4554,12 +4554,12 @@ test io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} {stdio openpipe} { test io-35.6 {Tcl_Eof, eof char, lf write, auto read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar \x1a + chan configure $f -translation lf -eofchar \x1a puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1a set l [string length [read $f]] set e [eof $f] close $f @@ -4568,12 +4568,12 @@ test io-35.6 {Tcl_Eof, eof char, lf write, auto read} { test io-35.7 {Tcl_Eof, eof char, lf write, lf read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar \x1a + chan configure $f -translation lf -eofchar \x1a puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar \x1a + chan configure $f -translation lf -eofchar \x1a set l [string length [read $f]] set e [eof $f] close $f @@ -4582,12 +4582,12 @@ test io-35.7 {Tcl_Eof, eof char, lf write, lf read} { test io-35.8 {Tcl_Eof, eof char, cr write, auto read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar \x1a + chan configure $f -translation cr -eofchar \x1a puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1a set l [string length [read $f]] set e [eof $f] close $f @@ -4596,12 +4596,12 @@ test io-35.8 {Tcl_Eof, eof char, cr write, auto read} { test io-35.9 {Tcl_Eof, eof char, cr write, cr read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar \x1a + chan configure $f -translation cr -eofchar \x1a puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar \x1a + chan configure $f -translation cr -eofchar \x1a set l [string length [read $f]] set e [eof $f] close $f @@ -4610,12 +4610,12 @@ test io-35.9 {Tcl_Eof, eof char, cr write, cr read} { test io-35.10 {Tcl_Eof, eof char, crlf write, auto read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf -eofchar \x1a + chan configure $f -translation crlf -eofchar \x1a puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1a set l [string length [read $f]] set e [eof $f] close $f @@ -4624,12 +4624,12 @@ test io-35.10 {Tcl_Eof, eof char, crlf write, auto read} { test io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf -eofchar \x1a + chan configure $f -translation crlf -eofchar \x1a puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1a + chan configure $f -translation crlf -eofchar \x1a set l [string length [read $f]] set e [eof $f] close $f @@ -4638,13 +4638,13 @@ test io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} { test io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} set i [format abc\ndef\n%cqrs\nuvw 26] puts $f $i close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1a set l [string length [read $f]] set e [eof $f] close $f @@ -4653,13 +4653,13 @@ test io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} { test io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} set i [format abc\ndef\n%cqrs\nuvw 26] puts $f $i close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar \x1a + chan configure $f -translation lf -eofchar \x1a set l [string length [read $f]] set e [eof $f] close $f @@ -4668,13 +4668,13 @@ test io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} { test io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar {} + chan configure $f -translation cr -eofchar {} set i [format abc\ndef\n%cqrs\nuvw 26] puts $f $i close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1a set l [string length [read $f]] set e [eof $f] close $f @@ -4683,13 +4683,13 @@ test io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} { test io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar {} + chan configure $f -translation cr -eofchar {} set i [format abc\ndef\n%cqrs\nuvw 26] puts $f $i close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar \x1a + chan configure $f -translation cr -eofchar \x1a set l [string length [read $f]] set e [eof $f] close $f @@ -4698,13 +4698,13 @@ test io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} { test io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf -eofchar {} + chan configure $f -translation crlf -eofchar {} set i [format abc\ndef\n%cqrs\nuvw 26] puts $f $i close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1a set l [string length [read $f]] set e [eof $f] close $f @@ -4713,13 +4713,13 @@ test io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} { test io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf -eofchar {} + chan configure $f -translation crlf -eofchar {} set i [format abc\ndef\n%cqrs\nuvw 26] puts $f $i close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1a + chan configure $f -translation crlf -eofchar \x1a set l [string length [read $f]] set e [eof $f] close $f @@ -4733,30 +4733,30 @@ test io-36.1 {Tcl_InputBlocked on nonblocking pipe} {stdio openpipe} { puts $f1 {puts hello_from_pipe} flush $f1 gets $f1 - fconfigure $f1 -blocking off -buffering full + chan configure $f1 -blocking off -buffering full puts $f1 {puts hello} set x "" lappend x [gets $f1] - lappend x [fblocked $f1] + lappend x [chan blocked $f1] flush $f1 after 200 lappend x [gets $f1] - lappend x [fblocked $f1] + lappend x [chan blocked $f1] lappend x [gets $f1] - lappend x [fblocked $f1] + lappend x [chan blocked $f1] close $f1 set x } {{} 1 hello 0 {} 1} test io-36.2 {Tcl_InputBlocked on blocking pipe} {stdio openpipe} { set f1 [open "|[list [interpreter]]" r+] - fconfigure $f1 -buffering line + chan configure $f1 -buffering line puts $f1 {puts hello_from_pipe} set x "" lappend x [gets $f1] - lappend x [fblocked $f1] + lappend x [chan blocked $f1] puts $f1 {exit} lappend x [gets $f1] - lappend x [fblocked $f1] + lappend x [chan blocked $f1] lappend x [eof $f1] close $f1 set x @@ -4768,11 +4768,11 @@ test io-36.3 {Tcl_InputBlocked vs files, short read} { close $f set f [open $path(test1) r] set l "" - lappend l [fblocked $f] + lappend l [chan blocked $f] lappend l [read $f 3] - lappend l [fblocked $f] + lappend l [chan blocked $f] lappend l [read -nonewline $f] - lappend l [fblocked $f] + lappend l [chan blocked $f] lappend l [eof $f] close $f set l @@ -4790,7 +4790,7 @@ test io-36.4 {Tcl_InputBlocked vs files, event driven read} {fileevent} { close $f set f [open $path(test1) r] set l "" - fileevent $f readable [namespace code [list in $f]] + chan event $f readable [namespace code [list in $f]] variable x vwait [namespace which -variable x] set l @@ -4802,13 +4802,13 @@ test io-36.5 {Tcl_InputBlocked vs files, short read, nonblocking} {nonBlockFiles puts $f abcdefghijklmnop close $f set f [open $path(test1) r] - fconfigure $f -blocking off + chan configure $f -blocking off set l "" - lappend l [fblocked $f] + lappend l [chan blocked $f] lappend l [read $f 3] - lappend l [fblocked $f] + lappend l [chan blocked $f] lappend l [read -nonewline $f] - lappend l [fblocked $f] + lappend l [chan blocked $f] lappend l [eof $f] close $f set l @@ -4825,9 +4825,9 @@ test io-36.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles filee puts $f abcdefghijklmnop close $f set f [open $path(test1) r] - fconfigure $f -blocking off + chan configure $f -blocking off set l "" - fileevent $f readable [namespace code [list in $f]] + chan event $f readable [namespace code [list in $f]] variable x vwait [namespace which -variable x] set l @@ -4838,7 +4838,7 @@ test io-36.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles filee test io-37.1 {Tcl_InputBuffered} {testchannel} { set f [open $path(longfile) r] - fconfigure $f -buffersize 4096 + chan configure $f -buffersize 4096 read $f 3 set l "" lappend l [testchannel inputbuffered $f] @@ -4848,7 +4848,7 @@ test io-37.1 {Tcl_InputBuffered} {testchannel} { } {4093 3} test io-37.2 {Tcl_InputBuffered, test input flushing on seek} {testchannel} { set f [open $path(longfile) r] - fconfigure $f -buffersize 4096 + chan configure $f -buffersize 4096 read $f 3 set l "" lappend l [testchannel inputbuffered $f] @@ -4864,26 +4864,26 @@ test io-37.2 {Tcl_InputBuffered, test input flushing on seek} {testchannel} { test io-38.1 {Tcl_GetChannelBufferSize, default buffer size} { set f [open $path(longfile) r] - set s [fconfigure $f -buffersize] + set s [chan configure $f -buffersize] close $f set s } 4096 test io-38.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} { set f [open $path(longfile) r] set l "" - lappend l [fconfigure $f -buffersize] - fconfigure $f -buffersize 10000 - lappend l [fconfigure $f -buffersize] - fconfigure $f -buffersize 1 - lappend l [fconfigure $f -buffersize] - fconfigure $f -buffersize -1 - lappend l [fconfigure $f -buffersize] - fconfigure $f -buffersize 0 - lappend l [fconfigure $f -buffersize] - fconfigure $f -buffersize 100000 - lappend l [fconfigure $f -buffersize] - fconfigure $f -buffersize 10000000 - lappend l [fconfigure $f -buffersize] + lappend l [chan configure $f -buffersize] + chan configure $f -buffersize 10000 + lappend l [chan configure $f -buffersize] + chan configure $f -buffersize 1 + lappend l [chan configure $f -buffersize] + chan configure $f -buffersize -1 + lappend l [chan configure $f -buffersize] + chan configure $f -buffersize 0 + lappend l [chan configure $f -buffersize] + chan configure $f -buffersize 100000 + lappend l [chan configure $f -buffersize] + chan configure $f -buffersize 10000000 + lappend l [chan configure $f -buffersize] close $f set l } {4096 10000 1 1 1 100000 1048576} @@ -4891,9 +4891,9 @@ test io-38.3 {Tcl_SetChannelBufferSize, changing buffersize between reads} { # This test crashes the interp if Bug #427196 is not fixed set chan [open [info script] r] - fconfigure $chan -buffersize 10 + chan configure $chan -buffersize 10 set var [read $chan 2] - fconfigure $chan -buffersize 32 + chan configure $chan -buffersize 32 append var [read $chan] close $chan } {} @@ -4903,7 +4903,7 @@ test io-38.3 {Tcl_SetChannelBufferSize, changing buffersize between reads} { test io-39.1 {Tcl_GetChannelOption} { file delete $path(test1) set f1 [open $path(test1) w] - set x [fconfigure $f1 -blocking] + set x [chan configure $f1 -blocking] close $f1 set x } 1 @@ -4913,15 +4913,15 @@ test io-39.1 {Tcl_GetChannelOption} { test io-39.2 {Tcl_GetChannelOption} { file delete $path(test1) set f1 [open $path(test1) w] - set x [fconfigure $f1 -buffering] + set x [chan configure $f1 -buffering] close $f1 set x } full test io-39.3 {Tcl_GetChannelOption} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -buffering line - set x [fconfigure $f1 -buffering] + chan configure $f1 -buffering line + set x [chan configure $f1 -buffering] close $f1 set x } line @@ -4929,15 +4929,15 @@ test io-39.4 {Tcl_GetChannelOption, Tcl_SetChannelOption} { file delete $path(test1) set f1 [open $path(test1) w] set l "" - lappend l [fconfigure $f1 -buffering] - fconfigure $f1 -buffering line - lappend l [fconfigure $f1 -buffering] - fconfigure $f1 -buffering none - lappend l [fconfigure $f1 -buffering] - fconfigure $f1 -buffering line - lappend l [fconfigure $f1 -buffering] - fconfigure $f1 -buffering full - lappend l [fconfigure $f1 -buffering] + lappend l [chan configure $f1 -buffering] + chan configure $f1 -buffering line + lappend l [chan configure $f1 -buffering] + chan configure $f1 -buffering none + lappend l [chan configure $f1 -buffering] + chan configure $f1 -buffering line + lappend l [chan configure $f1 -buffering] + chan configure $f1 -buffering full + lappend l [chan configure $f1 -buffering] close $f1 set l } {full line none line full} @@ -4945,16 +4945,16 @@ test io-39.5 {Tcl_GetChannelOption, invariance} { file delete $path(test1) set f1 [open $path(test1) w] set l "" - lappend l [fconfigure $f1 -buffering] - lappend l [list [catch {fconfigure $f1 -buffering green} msg] $msg] - lappend l [fconfigure $f1 -buffering] + lappend l [chan configure $f1 -buffering] + lappend l [list [catch {chan configure $f1 -buffering green} msg] $msg] + lappend l [chan configure $f1 -buffering] close $f1 set l } {full {1 {bad value for -buffering: must be one of full, line, or none}} full} test io-39.6 {Tcl_SetChannelOption, multiple options} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -buffering line + chan configure $f1 -translation lf -buffering line puts $f1 hello puts $f1 bye set x [file size $path(test1)] @@ -4964,11 +4964,11 @@ test io-39.6 {Tcl_SetChannelOption, multiple options} { test io-39.7 {Tcl_SetChannelOption, buffering, translation} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf + chan configure $f1 -translation lf puts $f1 hello puts $f1 bye set x "" - fconfigure $f1 -buffering line + chan configure $f1 -buffering line lappend x [file size $path(test1)] puts $f1 really_bye lappend x [file size $path(test1)] @@ -4979,15 +4979,15 @@ test io-39.8 {Tcl_SetChannelOption, different buffering options} { file delete $path(test1) set f1 [open $path(test1) w] set l "" - fconfigure $f1 -translation lf -buffering none -eofchar {} + chan configure $f1 -translation lf -buffering none -eofchar {} puts -nonewline $f1 hello lappend l [file size $path(test1)] puts -nonewline $f1 hello lappend l [file size $path(test1)] - fconfigure $f1 -buffering full + chan configure $f1 -buffering full puts -nonewline $f1 hello lappend l [file size $path(test1)] - fconfigure $f1 -buffering none + chan configure $f1 -buffering none lappend l [file size $path(test1)] puts -nonewline $f1 hello lappend l [file size $path(test1)] @@ -5001,12 +5001,12 @@ test io-39.9 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} { close $f1 set f1 [open $path(test1) r] set x "" - lappend x [fconfigure $f1 -blocking] - fconfigure $f1 -blocking off - lappend x [fconfigure $f1 -blocking] + lappend x [chan configure $f1 -blocking] + chan configure $f1 -blocking off + lappend x [chan configure $f1 -blocking] lappend x [gets $f1] lappend x [read $f1 1000] - lappend x [fblocked $f1] + lappend x [chan blocked $f1] lappend x [eof $f1] close $f1 set x @@ -5023,24 +5023,24 @@ test io-39.10 {Tcl_SetChannelOption, blocking mode} {stdio openpipe} { close $f1 set x "" set f1 [open "|[list [interpreter] $path(pipe)]" r+] - fconfigure $f1 -blocking off -buffering line - lappend x [fconfigure $f1 -blocking] + chan configure $f1 -blocking off -buffering line + lappend x [chan configure $f1 -blocking] lappend x [gets $f1] - lappend x [fblocked $f1] - fconfigure $f1 -blocking on + lappend x [chan blocked $f1] + chan configure $f1 -blocking on puts $f1 hello - fconfigure $f1 -blocking off + chan configure $f1 -blocking off lappend x [gets $f1] - lappend x [fblocked $f1] - fconfigure $f1 -blocking on + lappend x [chan blocked $f1] + chan configure $f1 -blocking on puts $f1 bye - fconfigure $f1 -blocking off + chan configure $f1 -blocking off lappend x [gets $f1] - lappend x [fblocked $f1] - fconfigure $f1 -blocking on - lappend x [fconfigure $f1 -blocking] + lappend x [chan blocked $f1] + chan configure $f1 -blocking on + lappend x [chan configure $f1 -blocking] lappend x [gets $f1] - lappend x [fblocked $f1] + lappend x [chan blocked $f1] lappend x [eof $f1] lappend x [gets $f1] lappend x [eof $f1] @@ -5050,35 +5050,35 @@ test io-39.10 {Tcl_SetChannelOption, blocking mode} {stdio openpipe} { test io-39.11 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size clipped to lower bound} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -buffersize -10 - set x [fconfigure $f -buffersize] + chan configure $f -buffersize -10 + set x [chan configure $f -buffersize] close $f set x } 1 test io-39.12 {Tcl_SetChannelOption, Tcl_GetChannelOption buffer size clipped to upper bound} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -buffersize 10000000 - set x [fconfigure $f -buffersize] + chan configure $f -buffersize 10000000 + set x [chan configure $f -buffersize] close $f set x } 1048576 test io-39.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -buffersize 40000 - set x [fconfigure $f -buffersize] + chan configure $f -buffersize 40000 + set x [chan configure $f -buffersize] close $f set x } 40000 test io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -encoding {} + chan configure $f -encoding {} puts -nonewline $f \xe7\x89\xa6 close $f set f [open $path(test1) r] - fconfigure $f -encoding utf-8 + chan configure $f -encoding utf-8 set x [read $f] close $f set x @@ -5086,11 +5086,11 @@ test io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} { test io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -encoding binary + chan configure $f -encoding binary puts -nonewline $f \xe7\x89\xa6 close $f set f [open $path(test1) r] - fconfigure $f -encoding utf-8 + chan configure $f -encoding utf-8 set x [read $f] close $f set x @@ -5098,26 +5098,26 @@ test io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} { test io-39.16 {Tcl_SetChannelOption: -encoding, errors} { file delete $path(test1) set f [open $path(test1) w] - set result [list [catch {fconfigure $f -encoding foobar} msg] $msg] + set result [list [catch {chan configure $f -encoding foobar} msg] $msg] close $f set result } {1 {unknown encoding "foobar"}} test io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} {stdio openpipe fileevent} { set f [open "|[list [interpreter] $path(cat)]" r+] - fconfigure $f -encoding binary + chan configure $f -encoding binary puts -nonewline $f "\xe7" flush $f - fconfigure $f -encoding utf-8 -blocking 0 + chan configure $f -encoding utf-8 -blocking 0 variable x {} - fileevent $f readable [namespace code { lappend x [read $f] }] + chan event $f readable [namespace code { lappend x [read $f] }] vwait [namespace which -variable x] after 300 [namespace code { lappend x timeout }] vwait [namespace which -variable x] - fconfigure $f -encoding utf-8 + chan configure $f -encoding utf-8 vwait [namespace which -variable x] after 300 [namespace code { lappend x timeout }] vwait [namespace which -variable x] - fconfigure $f -encoding binary + chan configure $f -encoding binary vwait [namespace which -variable x] after 300 [namespace code { lappend x timeout }] vwait [namespace which -variable x] @@ -5128,11 +5128,11 @@ test io-39.18 {Tcl_SetChannelOption, setting read mode independently} \ {socket} { proc accept {s a p} {close $s} set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0] - set port [lindex [fconfigure $s1 -sockname] 2] + set port [lindex [chan configure $s1 -sockname] 2] set s2 [socket 127.0.0.1 $port] update - fconfigure $s2 -translation {auto lf} - set modes [fconfigure $s2 -translation] + chan configure $s2 -translation {auto lf} + set modes [chan configure $s2 -translation] close $s1 close $s2 set modes @@ -5141,11 +5141,11 @@ test io-39.19 {Tcl_SetChannelOption, setting read mode independently} \ {socket} { proc accept {s a p} {close $s} set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0] - set port [lindex [fconfigure $s1 -sockname] 2] + set port [lindex [chan configure $s1 -sockname] 2] set s2 [socket 127.0.0.1 $port] update - fconfigure $s2 -translation {auto crlf} - set modes [fconfigure $s2 -translation] + chan configure $s2 -translation {auto crlf} + set modes [chan configure $s2 -translation] close $s1 close $s2 set modes @@ -5154,11 +5154,11 @@ test io-39.20 {Tcl_SetChannelOption, setting read mode independently} \ {socket} { proc accept {s a p} {close $s} set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0] - set port [lindex [fconfigure $s1 -sockname] 2] + set port [lindex [chan configure $s1 -sockname] 2] set s2 [socket 127.0.0.1 $port] update - fconfigure $s2 -translation {auto cr} - set modes [fconfigure $s2 -translation] + chan configure $s2 -translation {auto cr} + set modes [chan configure $s2 -translation] close $s1 close $s2 set modes @@ -5167,11 +5167,11 @@ test io-39.21 {Tcl_SetChannelOption, setting read mode independently} \ {socket} { proc accept {s a p} {close $s} set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0] - set port [lindex [fconfigure $s1 -sockname] 2] + set port [lindex [chan configure $s1 -sockname] 2] set s2 [socket 127.0.0.1 $port] update - fconfigure $s2 -translation {auto auto} - set modes [fconfigure $s2 -translation] + chan configure $s2 -translation {auto auto} + set modes [chan configure $s2 -translation] close $s1 close $s2 set modes @@ -5180,11 +5180,11 @@ test io-39.22 {Tcl_SetChannelOption, invariance} {unix} { file delete $path(test1) set f1 [open $path(test1) w+] set l "" - lappend l [fconfigure $f1 -eofchar] - fconfigure $f1 -eofchar {ON GO} - lappend l [fconfigure $f1 -eofchar] - fconfigure $f1 -eofchar D - lappend l [fconfigure $f1 -eofchar] + lappend l [chan configure $f1 -eofchar] + chan configure $f1 -eofchar {ON GO} + lappend l [chan configure $f1 -eofchar] + chan configure $f1 -eofchar D + lappend l [chan configure $f1 -eofchar] close $f1 set l } {{{} {}} {O G} {D D}} @@ -5192,11 +5192,11 @@ test io-39.22a {Tcl_SetChannelOption, invariance} { file delete $path(test1) set f1 [open $path(test1) w+] set l [list] - fconfigure $f1 -eofchar {ON GO} - lappend l [fconfigure $f1 -eofchar] - fconfigure $f1 -eofchar D - lappend l [fconfigure $f1 -eofchar] - lappend l [list [catch {fconfigure $f1 -eofchar {1 2 3}} msg] $msg] + chan configure $f1 -eofchar {ON GO} + lappend l [chan configure $f1 -eofchar] + chan configure $f1 -eofchar D + lappend l [chan configure $f1 -eofchar] + lappend l [list [catch {chan configure $f1 -eofchar {1 2 3}} msg] $msg] close $f1 set l } {{O G} {D D} {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}} @@ -5204,7 +5204,7 @@ test io-39.23 {Tcl_GetChannelOption, server socket is not readable or writeable, it should still have valid -eofchar and -translation options } { set l [list] set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0] - lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation] + lappend l [chan configure $sock -eofchar] [chan configure $sock -translation] close $sock set l } {{{}} auto} @@ -5212,8 +5212,8 @@ test io-39.24 {Tcl_SetChannelOption, server socket is not readable or writable so we can't change -eofchar or -translation } { set l [list] set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0] - fconfigure $sock -eofchar D -translation lf - lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation] + chan configure $sock -eofchar D -translation lf + lappend l [chan configure $sock -eofchar] [chan configure $sock -translation] close $sock set l } {{{}} auto} @@ -5252,15 +5252,15 @@ test io-40.3 {POSIX open access modes: CREAT} {unix umask} { close $f file stat $path(test3) stats format "0%o" [expr $stats(mode)&0o777] -} [format %04o [expr {0o666 & ~ $umaskValue}]] +} [format %04o [expr {0o666 & ( ~ $umaskValue )}]] test io-40.4 {POSIX open access modes: CREAT} { file delete $path(test3) set f [open $path(test3) w] - fconfigure $f -eofchar {} + chan configure $f -eofchar {} puts $f xyzzy close $f set f [open $path(test3) {WRONLY CREAT}] - fconfigure $f -eofchar {} + chan configure $f -eofchar {} puts -nonewline $f "ab" close $f set f [open $path(test3) r] @@ -5271,17 +5271,17 @@ test io-40.4 {POSIX open access modes: CREAT} { test io-40.5 {POSIX open access modes: APPEND} { file delete $path(test3) set f [open $path(test3) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} puts $f xyzzy close $f set f [open $path(test3) {WRONLY APPEND}] - fconfigure $f -translation lf + chan configure $f -translation lf puts $f "new line" seek $f 0 puts $f "abc" close $f set f [open $path(test3) r] - fconfigure $f -translation lf + chan configure $f -translation lf set x "" seek $f 6 current lappend x [gets $f] @@ -5299,7 +5299,7 @@ test io-40.6 {POSIX open access modes: EXCL} -match regexp -body { test io-40.7 {POSIX open access modes: EXCL} { file delete $path(test3) set f [open $path(test3) {WRONLY CREAT EXCL}] - fconfigure $f -eofchar {} + chan configure $f -eofchar {} puts $f "A test line" close $f viewFile test3 @@ -5350,7 +5350,7 @@ test io-40.12 {POSIX open access modes: WRONLY} -match regexp -body { test io-40.13 {POSIX open access modes: WRONLY} { makeFile xyzzy test3 set f [open $path(test3) WRONLY] - fconfigure $f -eofchar {} + chan configure $f -eofchar {} puts -nonewline $f "ab" seek $f 0 current set x [list [catch {gets $f} msg] $msg] @@ -5388,82 +5388,81 @@ test io-40.17 {tilde substitution in open} { } {1 {couldn't find HOME environment variable to expand path}} test io-41.1 {Tcl_FileeventCmd: errors} {fileevent} { - list [catch {fileevent foo} msg] $msg -} {1 {wrong # args: should be "fileevent channelId event ?script?"}} + list [catch {chan event foo} msg] $msg +} {1 {wrong # args: should be "chan event channelId event ?script?"}} test io-41.2 {Tcl_FileeventCmd: errors} {fileevent} { - list [catch {fileevent foo bar baz q} msg] $msg -} {1 {wrong # args: should be "fileevent channelId event ?script?"}} + list [catch {chan event foo bar baz q} msg] $msg +} {1 {wrong # args: should be "chan event channelId event ?script?"}} test io-41.3 {Tcl_FileeventCmd: errors} {fileevent} { - list [catch {fileevent gorp readable} msg] $msg + list [catch {chan event gorp readable} msg] $msg } {1 {can not find channel named "gorp"}} test io-41.4 {Tcl_FileeventCmd: errors} {fileevent} { - list [catch {fileevent gorp writable} msg] $msg + list [catch {chan event gorp writable} msg] $msg } {1 {can not find channel named "gorp"}} test io-41.5 {Tcl_FileeventCmd: errors} {fileevent} { - list [catch {fileevent gorp who-knows} msg] $msg + list [catch {chan event gorp who-knows} msg] $msg } {1 {bad event name "who-knows": must be readable or writable}} # -# Test fileevent on a file +# Test chan event on a file # set path(foo) [makeFile {} foo] set f [open $path(foo) w+] test io-42.1 {Tcl_FileeventCmd: creating, deleting, querying} {fileevent} { - list [fileevent $f readable] [fileevent $f writable] + list [chan event $f readable] [chan event $f writable] } {{} {}} test io-42.2 {Tcl_FileeventCmd: replacing} {fileevent} { - set result {} - fileevent $f r "first script" - lappend result [fileevent $f readable] - fileevent $f r "new script" - lappend result [fileevent $f readable] - fileevent $f r "yet another" - lappend result [fileevent $f readable] - fileevent $f r "" - lappend result [fileevent $f readable] + set result [list] + chan event $f r "first script" + lappend result [chan event $f readable] + chan event $f r "new script" + lappend result [chan event $f readable] + chan event $f r "yet another" + lappend result [chan event $f readable] + chan event $f r "" + lappend result [chan event $f readable] } {{first script} {new script} {yet another} {}} test io-42.3 {Tcl_FileeventCmd: replacing, with NULL chars in script} {fileevent} { - set result {} - fileevent $f r "first scr\0ipt" - lappend result [string length [fileevent $f readable]] - fileevent $f r "new scr\0ipt" - lappend result [string length [fileevent $f readable]] - fileevent $f r "yet ano\0ther" - lappend result [string length [fileevent $f readable]] - fileevent $f r "" - lappend result [fileevent $f readable] + set result [list] + chan event $f r "first scr\0ipt" + lappend result [string length [chan event $f readable]] + chan event $f r "new scr\0ipt" + lappend result [string length [chan event $f readable]] + chan event $f r "yet ano\0ther" + lappend result [string length [chan event $f readable]] + chan event $f r "" + lappend result [chan event $f readable] } {13 11 12 {}} - test io-43.1 {Tcl_FileeventCmd: creating, deleting, querying} {stdio unixExecs fileevent} { - set result {} - fileevent $f readable "script 1" - lappend result [fileevent $f readable] [fileevent $f writable] - fileevent $f writable "write script" - lappend result [fileevent $f readable] [fileevent $f writable] - fileevent $f readable {} - lappend result [fileevent $f readable] [fileevent $f writable] - fileevent $f writable {} - lappend result [fileevent $f readable] [fileevent $f writable] + set result [list] + chan event $f readable "script 1" + lappend result [chan event $f readable] [chan event $f writable] + chan event $f writable "write script" + lappend result [chan event $f readable] [chan event $f writable] + chan event $f readable {} + lappend result [chan event $f readable] [chan event $f writable] + chan event $f writable {} + lappend result [chan event $f readable] [chan event $f writable] } {{script 1} {} {script 1} {write script} {} {write script} {} {}} test io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] } -constraints {stdio unixExecs fileevent openpipe} -body { - set result {} - lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] - fileevent $f r "read f" - fileevent $f2 r "read f2" - fileevent $f3 r "read f3" - lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] - fileevent $f2 r {} - lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] - fileevent $f3 r {} - lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] - fileevent $f r {} - lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] + set result [list] + lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r] + chan event $f r "read f" + chan event $f2 r "read f2" + chan event $f3 r "read f3" + lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r] + chan event $f2 r {} + lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r] + chan event $f3 r {} + lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r] + chan event $f r {} + lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r] } -cleanup { catch {close $f2} catch {close $f3} @@ -5473,8 +5472,8 @@ test io-44.1 {FileEventProc procedure: normal read event} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] } -constraints {stdio unixExecs fileevent openpipe} -body { - fileevent $f2 readable [namespace code { - set x [gets $f2]; fileevent $f2 readable {} + chan event $f2 readable [namespace code { + set x [gets $f2]; chan event $f2 readable {} }] puts $f2 text; flush $f2 variable x initial @@ -5495,11 +5494,11 @@ test io-44.2 {FileEventProc procedure: error in read event} -constraints { set handler [interp bgerror {}] interp bgerror {} [namespace which myHandler] } -body { - fileevent $f2 readable {error bogus} + chan event $f2 readable {error bogus} puts $f2 text; flush $f2 variable x initial vwait [namespace which -variable x] - list $x [fileevent $f2 readable] + list $x [chan event $f2 readable] } -cleanup { interp bgerror {} $handler catch {close $f2} @@ -5509,11 +5508,11 @@ test io-44.3 {FileEventProc procedure: normal write event} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] } -constraints {stdio unixExecs fileevent openpipe} -body { - fileevent $f2 writable [namespace code { + chan event $f2 writable [namespace code { lappend x "triggered" incr count -1 if {$count <= 0} { - fileevent $f2 writable {} + chan event $f2 writable {} } }] variable x initial @@ -5537,10 +5536,10 @@ test io-44.4 {FileEventProc procedure: eror in write event} -constraints { set handler [interp bgerror {}] interp bgerror {} [namespace which myHandler] } -body { - fileevent $f2 writable {error bad-write} + chan event $f2 writable {error bad-write} variable x initial vwait [namespace which -variable x] - list $x [fileevent $f2 writable] + list $x [chan event $f2 writable] } -cleanup { interp bgerror {} $handler catch {close $f2} @@ -5548,10 +5547,10 @@ test io-44.4 {FileEventProc procedure: eror in write event} -constraints { } -result {bad-write {}} test io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs openpipe fileevent} { set f4 [open "|[list [interpreter] $path(cat) << foo]" r] - fileevent $f4 readable [namespace code { + chan event $f4 readable [namespace code { if {[gets $f4 line] < 0} { lappend x eof - fileevent $f4 readable {} + chan event $f4 readable {} } else { lappend x $line } @@ -5568,9 +5567,9 @@ makeFile "foo bar" foo test io-45.1 {DeleteFileEvent, cleanup on close} {fileevent} { set f [open $path(foo) r] - fileevent $f readable [namespace code { + chan event $f readable [namespace code { lappend x "binding triggered: \"[gets $f]\"" - fileevent $f readable {} + chan event $f readable {} }] close $f set x initial @@ -5582,13 +5581,13 @@ test io-45.1 {DeleteFileEvent, cleanup on close} {fileevent} { test io-45.2 {DeleteFileEvent, cleanup on close} {fileevent} { set f [open $path(foo) r] set f2 [open $path(foo) r] - fileevent $f readable [namespace code { + chan event $f readable [namespace code { lappend x "f triggered: \"[gets $f]\"" - fileevent $f readable {} + chan event $f readable {} }] - fileevent $f2 readable [namespace code { + chan event $f2 readable [namespace code { lappend x "f2 triggered: \"[gets $f2]\"" - fileevent $f2 readable {} + chan event $f2 readable {} }] close $f variable x initial @@ -5600,22 +5599,22 @@ test io-45.3 {DeleteFileEvent, cleanup on close} {fileevent} { set f [open $path(foo) r] set f2 [open $path(foo) r] set f3 [open $path(foo) r] - fileevent $f readable {f script} - fileevent $f2 readable {f2 script} - fileevent $f3 readable {f3 script} + chan event $f readable {f script} + chan event $f2 readable {f2 script} + chan event $f3 readable {f3 script} set x {} close $f2 - lappend x [catch {fileevent $f readable} msg] $msg \ - [catch {fileevent $f2 readable}] \ - [catch {fileevent $f3 readable} msg] $msg + lappend x [catch {chan event $f readable} msg] $msg \ + [catch {chan event $f2 readable}] \ + [catch {chan event $f3 readable} msg] $msg close $f3 - lappend x [catch {fileevent $f readable} msg] $msg \ - [catch {fileevent $f2 readable}] \ - [catch {fileevent $f3 readable}] + lappend x [catch {chan event $f readable} msg] $msg \ + [catch {chan event $f2 readable}] \ + [catch {chan event $f3 readable}] close $f - lappend x [catch {fileevent $f readable}] \ - [catch {fileevent $f2 readable}] \ - [catch {fileevent $f3 readable}] + lappend x [catch {chan event $f readable}] \ + [catch {chan event $f2 readable}] \ + [catch {chan event $f3 readable}] } {0 {f script} 1 0 {f3 script} 0 {f script} 1 1 1 1 1} # Execute these tests only if the "testfevent" command is present. @@ -5625,9 +5624,9 @@ test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent} { set script "set f \[[list open $path(foo) r]]\n" append script { set x "no event" - fileevent $f readable [namespace code { + chan event $f readable [namespace code { set x "f triggered: [gets $f]" - fileevent $f readable {} + chan event $f readable {} }] } testfevent cmd $script @@ -5663,36 +5662,36 @@ test io-47.1 {fileevent vs multiple interpreters} {testfevent fileevent} { set f [open $path(foo) r] set f2 [open $path(foo) r] set f3 [open $path(foo) r] - fileevent $f readable {script 1} + chan event $f readable {script 1} testfevent create testfevent share $f2 - testfevent cmd "fileevent $f2 readable {script 2}" - fileevent $f3 readable {sript 3} + testfevent cmd "chan event $f2 readable {script 2}" + chan event $f3 readable {sript 3} set x {} - lappend x [fileevent $f2 readable] + lappend x [chan event $f2 readable] testfevent delete - lappend x [fileevent $f readable] [fileevent $f2 readable] \ - [fileevent $f3 readable] + lappend x [chan event $f readable] [chan event $f2 readable] \ + [chan event $f3 readable] close $f close $f2 close $f3 set x } {{} {script 1} {} {sript 3}} -test io-47.2 {deleting fileevent on interpreter delete} {testfevent fileevent} { +test io-47.2 {deleting chan event on interpreter delete} {testfevent fileevent} { set f [open $path(foo) r] set f2 [open $path(foo) r] set f3 [open $path(foo) r] set f4 [open $path(foo) r] - fileevent $f readable {script 1} + chan event $f readable {script 1} testfevent create testfevent share $f2 testfevent share $f3 - testfevent cmd "fileevent $f2 readable {script 2} - fileevent $f3 readable {script 3}" - fileevent $f4 readable {script 4} + testfevent cmd "chan event $f2 readable {script 2} + chan event $f3 readable {script 3}" + chan event $f4 readable {script 4} testfevent delete - set x [list [fileevent $f readable] [fileevent $f2 readable] \ - [fileevent $f3 readable] [fileevent $f4 readable]] + set x [list [chan event $f readable] [chan event $f2 readable] \ + [chan event $f3 readable] [chan event $f4 readable]] close $f close $f2 close $f3 @@ -5707,13 +5706,13 @@ test io-47.3 {deleting fileevent on interpreter delete} {testfevent fileevent} { testfevent create testfevent share $f3 testfevent share $f4 - fileevent $f readable {script 1} - fileevent $f2 readable {script 2} - testfevent cmd "fileevent $f3 readable {script 3} - fileevent $f4 readable {script 4}" + chan event $f readable {script 1} + chan event $f2 readable {script 2} + testfevent cmd "chan event $f3 readable {script 3} + chan event $f4 readable {script 4}" testfevent delete - set x [list [fileevent $f readable] [fileevent $f2 readable] \ - [fileevent $f3 readable] [fileevent $f4 readable]] + set x [list [chan event $f readable] [chan event $f2 readable] \ + [chan event $f3 readable] [chan event $f4 readable]] close $f close $f2 close $f3 @@ -5725,12 +5724,12 @@ test io-47.4 {file events on shared files and multiple interpreters} {testfevent set f2 [open $path(foo) r] testfevent create testfevent share $f - testfevent cmd "fileevent $f readable {script 1}" - fileevent $f readable {script 2} - fileevent $f2 readable {script 3} - set x [list [fileevent $f2 readable] \ - [testfevent cmd "fileevent $f readable"] \ - [fileevent $f readable]] + testfevent cmd "chan event $f readable {script 1}" + chan event $f readable {script 2} + chan event $f2 readable {script 3} + set x [list [chan event $f2 readable] \ + [testfevent cmd "chan event $f readable"] \ + [chan event $f readable]] testfevent delete close $f close $f2 @@ -5740,11 +5739,11 @@ test io-47.5 {file events on shared files, deleting file events} {testfevent fil set f [open $path(foo) r] testfevent create testfevent share $f - testfevent cmd "fileevent $f readable {script 1}" - fileevent $f readable {script 2} - testfevent cmd "fileevent $f readable {}" - set x [list [testfevent cmd "fileevent $f readable"] \ - [fileevent $f readable]] + testfevent cmd "chan event $f readable {script 1}" + chan event $f readable {script 2} + testfevent cmd "chan event $f readable {}" + set x [list [testfevent cmd "chan event $f readable"] \ + [chan event $f readable]] testfevent delete close $f set x @@ -5753,11 +5752,11 @@ test io-47.6 {file events on shared files, deleting file events} {testfevent fil set f [open $path(foo) r] testfevent create testfevent share $f - testfevent cmd "fileevent $f readable {script 1}" - fileevent $f readable {script 2} - fileevent $f readable {} - set x [list [testfevent cmd "fileevent $f readable"] \ - [fileevent $f readable]] + testfevent cmd "chan event $f readable {script 1}" + chan event $f readable {script 2} + chan event $f readable {} + set x [list [testfevent cmd "chan event $f readable"] \ + [chan event $f readable]] testfevent delete close $f set x @@ -5774,7 +5773,7 @@ test io-48.1 {testing readability conditions} {fileevent} { puts $f abcdefg close $f set f [open $path(bar) r] - fileevent $f readable [namespace code [list consume $f]] + chan event $f readable [namespace code [list consume $f]] proc consume {f} { variable l variable x @@ -5800,8 +5799,8 @@ test io-48.2 {testing readability conditions} {nonBlockFiles fileevent} { puts $f abcdefg close $f set f [open $path(bar) r] - fileevent $f readable [namespace code [list consume $f]] - fconfigure $f -blocking off + chan event $f readable [namespace code [list consume $f]] + chan configure $f -blocking off proc consume {f} { variable x variable l @@ -5839,9 +5838,9 @@ test io-48.3 {testing readability conditions} {stdio unix nonBlockFiles openpipe } close $f set f [open "|[list [interpreter]]" r+] - fileevent $f readable [namespace code [list consume $f]] - fconfigure $f -buffering line - fconfigure $f -blocking off + chan event $f readable [namespace code [list consume $f]] + chan configure $f -buffering line + chan configure $f -blocking off proc consume {f} { variable l variable x @@ -5849,9 +5848,9 @@ test io-48.3 {testing readability conditions} {stdio unix nonBlockFiles openpipe set x done } else { gets $f - lappend l [fblocked $f] + lappend l [chan blocked $f] gets $f - lappend l [fblocked $f] + lappend l [chan blocked $f] } } set l "" @@ -5867,7 +5866,7 @@ test io-48.3 {testing readability conditions} {stdio unix nonBlockFiles openpipe test io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {fileevent} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf variable c [format "abc\ndef\n%c" 26] puts -nonewline $f $c close $f @@ -5886,8 +5885,8 @@ test io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {fi set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a - fileevent $f readable [namespace code [list consume $f]] + chan configure $f -translation auto -eofchar \x1a + chan event $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] list $c $l @@ -5895,7 +5894,7 @@ test io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {fi test io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} {fileevent} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf set c [format "abc\ndef\n%cfoo\nbar\n" 26] puts -nonewline $f $c close $f @@ -5914,8 +5913,8 @@ test io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} {file set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto - fileevent $f readable [namespace code [list consume $f]] + chan configure $f -eofchar \x1a -translation auto + chan event $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] list $c $l @@ -5923,7 +5922,7 @@ test io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} {file test io-48.6 {cr write, testing readability, ^Z termination, auto read mode} {fileevent} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr + chan configure $f -translation cr set c [format "abc\ndef\n%c" 26] puts -nonewline $f $c close $f @@ -5942,8 +5941,8 @@ test io-48.6 {cr write, testing readability, ^Z termination, auto read mode} {fi set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a - fileevent $f readable [namespace code [list consume $f]] + chan configure $f -translation auto -eofchar \x1a + chan event $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] list $c $l @@ -5951,7 +5950,7 @@ test io-48.6 {cr write, testing readability, ^Z termination, auto read mode} {fi test io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} {fileevent} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr + chan configure $f -translation cr set c [format "abc\ndef\n%cfoo\nbar\n" 26] puts -nonewline $f $c close $f @@ -5970,8 +5969,8 @@ test io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} {file set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto - fileevent $f readable [namespace code [list consume $f]] + chan configure $f -eofchar \x1a -translation auto + chan event $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] list $c $l @@ -5979,7 +5978,7 @@ test io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} {file test io-48.8 {crlf write, testing readability, ^Z termination, auto read mode} {fileevent} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf set c [format "abc\ndef\n%c" 26] puts -nonewline $f $c close $f @@ -5998,8 +5997,8 @@ test io-48.8 {crlf write, testing readability, ^Z termination, auto read mode} { set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a - fileevent $f readable [namespace code [list consume $f]] + chan configure $f -translation auto -eofchar \x1a + chan event $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] list $c $l @@ -6007,7 +6006,7 @@ test io-48.8 {crlf write, testing readability, ^Z termination, auto read mode} { test io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} {fileevent} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf set c [format "abc\ndef\n%cfoo\nbar\n" 26] puts -nonewline $f $c close $f @@ -6026,8 +6025,8 @@ test io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} {fi set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto - fileevent $f readable [namespace code [list consume $f]] + chan configure $f -eofchar \x1a -translation auto + chan event $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] list $c $l @@ -6035,7 +6034,7 @@ test io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} {fi test io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} {fileevent} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf set c [format "abc\ndef\n%cfoo\nbar\n" 26] puts -nonewline $f $c close $f @@ -6054,8 +6053,8 @@ test io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} {filee set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation lf - fileevent $f readable [namespace code [list consume $f]] + chan configure $f -eofchar \x1a -translation lf + chan event $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] list $c $l @@ -6063,7 +6062,7 @@ test io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} {filee test io-48.11 {lf write, testing readability, ^Z termination, lf read mode} {fileevent} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf set c [format "abc\ndef\n%c" 26] puts -nonewline $f $c close $f @@ -6082,8 +6081,8 @@ test io-48.11 {lf write, testing readability, ^Z termination, lf read mode} {fil set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar \x1a - fileevent $f readable [namespace code [list consume $f]] + chan configure $f -translation lf -eofchar \x1a + chan event $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] list $c $l @@ -6091,7 +6090,7 @@ test io-48.11 {lf write, testing readability, ^Z termination, lf read mode} {fil test io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} {fileevent} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr + chan configure $f -translation cr set c [format "abc\ndef\n%cfoo\nbar\n" 26] puts -nonewline $f $c close $f @@ -6110,8 +6109,8 @@ test io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} {filee set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation cr - fileevent $f readable [namespace code [list consume $f]] + chan configure $f -eofchar \x1a -translation cr + chan event $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] list $c $l @@ -6119,7 +6118,7 @@ test io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} {filee test io-48.13 {cr write, testing readability, ^Z termination, cr read mode} {fileevent} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr + chan configure $f -translation cr set c [format "abc\ndef\n%c" 26] puts -nonewline $f $c close $f @@ -6138,8 +6137,8 @@ test io-48.13 {cr write, testing readability, ^Z termination, cr read mode} {fil set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar \x1a - fileevent $f readable [namespace code [list consume $f]] + chan configure $f -translation cr -eofchar \x1a + chan event $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] list $c $l @@ -6147,7 +6146,7 @@ test io-48.13 {cr write, testing readability, ^Z termination, cr read mode} {fil test io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} {fileevent} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf set c [format "abc\ndef\n%cfoo\nbar\n" 26] puts -nonewline $f $c close $f @@ -6166,8 +6165,8 @@ test io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} {f set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation crlf - fileevent $f readable [namespace code [list consume $f]] + chan configure $f -eofchar \x1a -translation crlf + chan event $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] list $c $l @@ -6175,7 +6174,7 @@ test io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} {f test io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} {fileevent} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf set c [format "abc\ndef\n%c" 26] puts -nonewline $f $c close $f @@ -6194,8 +6193,8 @@ test io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} {filee set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1a - fileevent $f readable [namespace code [list consume $f]] + chan configure $f -translation crlf -eofchar \x1a + chan event $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] list $c $l @@ -6204,13 +6203,13 @@ test io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} {filee test io-49.1 {testing crlf reading, leftover cr disgorgment} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "a\rb\rc\r\n" close $f set f [open $path(test1) r] set l "" lappend l [file size $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf lappend l [read $f 1] lappend l [tell $f] lappend l [read $f 1] @@ -6233,13 +6232,13 @@ test io-49.1 {testing crlf reading, leftover cr disgorgment} { test io-49.2 {testing crlf reading, leftover cr disgorgment} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "a\rb\rc\r\n" close $f set f [open $path(test1) r] set l "" lappend l [file size $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf lappend l [read $f 2] lappend l [tell $f] lappend l [read $f 2] @@ -6256,13 +6255,13 @@ test io-49.2 {testing crlf reading, leftover cr disgorgment} { test io-49.3 {testing crlf reading, leftover cr disgorgment} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "a\rb\rc\r\n" close $f set f [open $path(test1) r] set l "" lappend l [file size $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf lappend l [read $f 3] lappend l [tell $f] lappend l [read $f 3] @@ -6277,13 +6276,13 @@ test io-49.3 {testing crlf reading, leftover cr disgorgment} { test io-49.4 {testing crlf reading, leftover cr disgorgment} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "a\rb\rc\r\n" close $f set f [open $path(test1) r] set l "" lappend l [file size $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf lappend l [read $f 3] lappend l [tell $f] lappend l [gets $f] @@ -6298,13 +6297,13 @@ test io-49.4 {testing crlf reading, leftover cr disgorgment} { test io-49.5 {testing crlf reading, leftover cr disgorgment} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "a\rb\rc\r\n" close $f set f [open $path(test1) r] set l "" lappend l [file size $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf lappend l [set x [gets $f]] lappend l [tell $f] lappend l [gets $f] @@ -6383,7 +6382,7 @@ test io-50.4 {testing handler deletion vs reentrant calls} {testchannelevent} { proc delrecursive {f} { variable z variable u - if {"$u" == "recursive"} { + if {$u eq "recursive"} { testchannelevent $f delete 0 lappend z "delrecursive deleting recursive" } else { @@ -6413,7 +6412,7 @@ test io-50.5 {testing handler deletion vs reentrant calls} {testchannelevent} { proc del {f} { variable u variable z - if {"$u" == "recursive"} { + if {$u eq "recursive"} { testchannelevent $f delete 1 testchannelevent $f delete 0 lappend z "del deleted notcalled" @@ -6443,7 +6442,7 @@ test io-50.6 {testing handler deletion vs reentrant calls} {testchannelevent} { proc first {f} { variable u variable z - if {"$u" == "toplevel"} { + if {$u eq "toplevel"} { lappend z "first called" set u first update @@ -6455,11 +6454,11 @@ test io-50.6 {testing handler deletion vs reentrant calls} {testchannelevent} { proc second {f} { variable u variable z - if {"$u" == "first"} { + if {$u eq "first"} { lappend z "second called, first time" set u second testchannelevent $f delete 0 - } elseif {"$u" == "second"} { + } elseif {$u eq "second"} { lappend z "second called, second time" testchannelevent $f delete 0 } else { @@ -6483,13 +6482,13 @@ test io-51.1 {Test old socket deletion on Macintosh} {socket} { proc accept {s a p} { variable x variable wait - fconfigure $s -blocking off + chan configure $s -blocking off puts $s "sock[incr x]" close $s set wait done } set ss [socket -server [namespace code accept] -myaddr 127.0.0.1 0] - set port [lindex [fconfigure $ss -sockname] 2] + set port [lindex [chan configure $ss -sockname] 2] variable wait "" set cs [socket 127.0.0.1 $port] @@ -6522,8 +6521,8 @@ test io-52.1 {TclCopyChannel} {fcopy} { file delete $path(test1) set f1 [open $thisScript] set f2 [open $path(test1) w] - fcopy $f1 $f2 -command { # } - catch { fcopy $f1 $f2 } msg + chan copy $f1 $f2 -command { # } + catch { chan copy $f1 $f2 } msg close $f1 close $f2 string compare $msg "channel \"$f1\" is busy" @@ -6533,8 +6532,8 @@ test io-52.2 {TclCopyChannel} {fcopy} { set f1 [open $thisScript] set f2 [open $path(test1) w] set f3 [open $thisScript] - fcopy $f1 $f2 -command { # } - catch { fcopy $f3 $f2 } msg + chan copy $f1 $f2 -command { # } + catch { chan copy $f3 $f2 } msg close $f1 close $f2 close $f3 @@ -6544,15 +6543,15 @@ test io-52.3 {TclCopyChannel} {fcopy} { file delete $path(test1) set f1 [open $thisScript] set f2 [open $path(test1) w] - fconfigure $f1 -translation lf -blocking 0 - fconfigure $f2 -translation cr -blocking 0 - set s0 [fcopy $f1 $f2] - set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + chan configure $f1 -translation lf -blocking 0 + chan configure $f2 -translation cr -blocking 0 + set s0 [chan copy $f1 $f2] + set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] close $f1 close $f2 set s1 [file size $thisScript] set s2 [file size $path(test1)] - if {("$s1" == "$s2") && ($s0 == $s1)} { + if {($s1 == $s2) && ($s0 == $s1)} { lappend result ok } set result @@ -6561,10 +6560,10 @@ test io-52.4 {TclCopyChannel} {fcopy} { file delete $path(test1) set f1 [open $thisScript] set f2 [open $path(test1) w] - fconfigure $f1 -translation lf -blocking 0 - fconfigure $f2 -translation cr -blocking 0 - fcopy $f1 $f2 -size 40 - set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + chan configure $f1 -translation lf -blocking 0 + chan configure $f2 -translation cr -blocking 0 + chan copy $f1 $f2 -size 40 + set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] close $f1 close $f2 lappend result [file size $path(test1)] @@ -6573,15 +6572,15 @@ test io-52.5 {TclCopyChannel, all} {fcopy} { file delete $path(test1) set f1 [open $thisScript] set f2 [open $path(test1) w] - fconfigure $f1 -translation lf -blocking 0 - fconfigure $f2 -translation lf -blocking 0 - fcopy $f1 $f2 -size -1 ;# -1 means 'copy all', same as if no -size specified. - set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + chan configure $f1 -translation lf -blocking 0 + chan configure $f2 -translation lf -blocking 0 + chan copy $f1 $f2 -size -1 ;# -1 means 'copy all', same as if no -size specified. + set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] close $f1 close $f2 set s1 [file size $thisScript] set s2 [file size $path(test1)] - if {"$s1" == "$s2"} { + if {$s1 == $s2} { lappend result ok } set result @@ -6590,15 +6589,15 @@ test io-52.5a {TclCopyChannel, all, other negative value} {fcopy} { file delete $path(test1) set f1 [open $thisScript] set f2 [open $path(test1) w] - fconfigure $f1 -translation lf -blocking 0 - fconfigure $f2 -translation lf -blocking 0 - fcopy $f1 $f2 -size -2 ;# < 0 behaves like -1, copy all - set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + chan configure $f1 -translation lf -blocking 0 + chan configure $f2 -translation lf -blocking 0 + chan copy $f1 $f2 -size -2 ;# < 0 behaves like -1, copy all + set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] close $f1 close $f2 set s1 [file size $thisScript] set s2 [file size $path(test1)] - if {"$s1" == "$s2"} { + if {$s1 == $s2} { lappend result ok } set result @@ -6607,15 +6606,15 @@ test io-52.5b {TclCopyChannel, all, wrap to negative value} {fcopy} { file delete $path(test1) set f1 [open $thisScript] set f2 [open $path(test1) w] - fconfigure $f1 -translation lf -blocking 0 - fconfigure $f2 -translation lf -blocking 0 - fcopy $f1 $f2 -size 3221176172 ;# Wrapped to < 0, behaves like -1, copy all - set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + chan configure $f1 -translation lf -blocking 0 + chan configure $f2 -translation lf -blocking 0 + chan copy $f1 $f2 -size 3221176172 ;# Wrapped to < 0, behaves like -1, copy all + set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] close $f1 close $f2 set s1 [file size $thisScript] set s2 [file size $path(test1)] - if {"$s1" == "$s2"} { + if {$s1 == $s2} { lappend result ok } set result @@ -6624,15 +6623,15 @@ test io-52.6 {TclCopyChannel} {fcopy} { file delete $path(test1) set f1 [open $thisScript] set f2 [open $path(test1) w] - fconfigure $f1 -translation lf -blocking 0 - fconfigure $f2 -translation lf -blocking 0 - set s0 [fcopy $f1 $f2 -size [expr [file size $thisScript] + 5]] - set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + chan configure $f1 -translation lf -blocking 0 + chan configure $f2 -translation lf -blocking 0 + set s0 [chan copy $f1 $f2 -size [expr [file size $thisScript] + 5]] + set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] close $f1 close $f2 set s1 [file size $thisScript] set s2 [file size $path(test1)] - if {("$s1" == "$s2") && ($s0 == $s1)} { + if {($s1 == $s2) && ($s0 == $s1)} { lappend result ok } set result @@ -6641,15 +6640,15 @@ test io-52.7 {TclCopyChannel} {fcopy} { file delete $path(test1) set f1 [open $thisScript] set f2 [open $path(test1) w] - fconfigure $f1 -translation lf -blocking 0 - fconfigure $f2 -translation lf -blocking 0 - fcopy $f1 $f2 - set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + chan configure $f1 -translation lf -blocking 0 + chan configure $f2 -translation lf -blocking 0 + chan copy $f1 $f2 + set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] set s1 [file size $thisScript] set s2 [file size $path(test1)] close $f1 close $f2 - if {"$s1" == "$s2"} { + if {$s1 == $s2} { lappend result ok } set result @@ -6658,24 +6657,24 @@ test io-52.8 {TclCopyChannel} {stdio openpipe fcopy} { file delete $path(test1) file delete $path(pipe) set f1 [open $path(pipe) w] - fconfigure $f1 -translation lf + chan configure $f1 -translation lf puts $f1 " puts ready gets stdin set f1 \[open [list $thisScript] r\] - fconfigure \$f1 -translation lf + chan configure \$f1 -translation lf puts \[read \$f1 100\] close \$f1 " close $f1 set f1 [open "|[list [interpreter] $path(pipe)]" r+] - fconfigure $f1 -translation lf + chan configure $f1 -translation lf gets $f1 puts $f1 ready flush $f1 set f2 [open $path(test1) w] - fconfigure $f2 -translation lf - set s0 [fcopy $f1 $f2 -size 40] + chan configure $f2 -translation lf + set s0 [chan copy $f1 $f2 -size 40] catch {close $f1} close $f2 list $s0 [file size $path(test1)] @@ -6686,33 +6685,33 @@ set path(utf8-fcopy.txt) [makeFile {} utf8-fcopy.txt] set path(utf8-rp.txt) [makeFile {} utf8-rp.txt] # Create kyrillic file, use lf translation to avoid os eol issues set out [open $path(kyrillic.txt) w] -fconfigure $out -encoding koi8-r -translation lf -puts $out "\u0410\u0410" -close $out +chan configure $out -encoding koi8-r -translation lf +chan puts $out "\u0410\u0410" +chan close $out test io-52.9 {TclCopyChannel & encodings} {fcopy} { - # Copy kyrillic to UTF-8, using fcopy. + # Copy kyrillic to UTF-8, using chan copy. set in [open $path(kyrillic.txt) r] set out [open $path(utf8-fcopy.txt) w] - fconfigure $in -encoding koi8-r -translation lf - fconfigure $out -encoding utf-8 -translation lf + chan configure $in -encoding koi8-r -translation lf + chan configure $out -encoding utf-8 -translation lf - fcopy $in $out - close $in - close $out + chan copy $in $out + chan close $in + chan close $out # Do the same again, but differently (read/puts). set in [open $path(kyrillic.txt) r] set out [open $path(utf8-rp.txt) w] - fconfigure $in -encoding koi8-r -translation lf - fconfigure $out -encoding utf-8 -translation lf + chan configure $in -encoding koi8-r -translation lf + chan configure $out -encoding utf-8 -translation lf - puts -nonewline $out [read $in] + chan puts -nonewline $out [read $in] - close $in + chan close $in close $out list [file size $path(kyrillic.txt)] \ @@ -6726,11 +6725,11 @@ test io-52.10 {TclCopyChannel & encodings} {fcopy} { set in [open $path(kyrillic.txt) r] set out [open $path(utf8-fcopy.txt) w] - fconfigure $in -encoding koi8-r -translation lf + chan configure $in -encoding koi8-r -translation lf # -translation binary is also -encoding binary - fconfigure $out -translation binary + chan configure $out -translation binary - fcopy $in $out + chan copy $in $out close $in close $out @@ -6744,10 +6743,10 @@ test io-52.11 {TclCopyChannel & encodings} {fcopy} { set out [open $path(kyrillic.txt) w] # -translation binary is also -encoding binary - fconfigure $in -translation binary - fconfigure $out -encoding koi8-r -translation lf + chan configure $in -translation binary + chan configure $out -encoding koi8-r -translation lf - fcopy $in $out + chan copy $in $out close $in close $out @@ -6758,10 +6757,10 @@ test io-53.1 {CopyData} {fcopy} { file delete $path(test1) set f1 [open $thisScript] set f2 [open $path(test1) w] - fconfigure $f1 -translation lf -blocking 0 - fconfigure $f2 -translation cr -blocking 0 - fcopy $f1 $f2 -size 0 - set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + chan configure $f1 -translation lf -blocking 0 + chan configure $f2 -translation cr -blocking 0 + chan copy $f1 $f2 -size 0 + set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] close $f1 close $f2 lappend result [file size $path(test1)] @@ -6770,17 +6769,17 @@ test io-53.2 {CopyData} {fcopy} { file delete $path(test1) set f1 [open $thisScript] set f2 [open $path(test1) w] - fconfigure $f1 -translation lf -blocking 0 - fconfigure $f2 -translation cr -blocking 0 - fcopy $f1 $f2 -command [namespace code {set s0}] - set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + chan configure $f1 -translation lf -blocking 0 + chan configure $f2 -translation cr -blocking 0 + chan copy $f1 $f2 -command [namespace code {set s0}] + set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] variable s0 vwait [namespace which -variable s0] close $f1 close $f2 set s1 [file size $thisScript] set s2 [file size $path(test1)] - if {("$s1" == "$s2") && ($s0 == $s1)} { + if {($s1 == $s2) && ($s0 == $s1)} { lappend result ok } set result @@ -6792,12 +6791,12 @@ test io-53.3 {CopyData: background read underflow} {stdio unix openpipe fcopy} { puts -nonewline $f1 { puts ready flush stdout ;# Don't assume line buffered! - fcopy stdin stdout -command { set x } + chan copy stdin stdout -command { set x } vwait x set f [} puts $f1 [list open $path(test1) w]] puts $f1 { - fconfigure $f -translation lf + chan configure $f -translation lf puts $f "done" close $f } @@ -6828,22 +6827,22 @@ test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileeven set f1 [open $path(pipe) w] puts $f1 { puts ready - fcopy stdin stdout -command { set x } + chan copy stdin stdout -command { set x } vwait x set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts $f "done" close $f } close $f1 set f1 [open "|[list [interpreter] $path(pipe)]" r+] set result [gets $f1] - fconfigure $f1 -blocking 0 + chan configure $f1 -blocking 0 puts $f1 $big flush $f1 after 500 set result "" - fileevent $f1 read [namespace code { + chan event $f1 read [namespace code { append result [read $f1 1024] if {[string length $result] >= [string length $big]} { set x done @@ -6851,10 +6850,10 @@ test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileeven }] vwait [namespace which -variable x] close $f1 - set big {} + set big "" set x } done -set result {} +set result "" proc FcopyTestAccept {sock args} { after 1000 "close $sock" } @@ -6866,14 +6865,14 @@ proc FcopyTestDone {bytes {error {}}} { set fcopyTestDone 0 } } -test io-53.5 {CopyData: error during fcopy} {socket fcopy} { +test io-53.5 {CopyData: error during chan copy} {socket fcopy} { variable fcopyTestDone set listen [socket -server [namespace code FcopyTestAccept] -myaddr 127.0.0.1 0] set in [open $thisScript] ;# 126 K - set out [socket 127.0.0.1 [lindex [fconfigure $listen -sockname] 2]] - catch {unset fcopyTestDone} + set out [socket 127.0.0.1 [lindex [chan configure $listen -sockname] 2]] + unset -nocomplain fcopyTestDone close $listen ;# This means the socket open never really succeeds - fcopy $in $out -command [namespace code FcopyTestDone] + chan copy $in $out -command [namespace code FcopyTestDone] variable fcopyTestDone if ![info exists fcopyTestDone] { vwait [namespace which -variable fcopyTestDone] ;# The error occurs here in the b.g. @@ -6882,17 +6881,17 @@ test io-53.5 {CopyData: error during fcopy} {socket fcopy} { close $out set fcopyTestDone ;# 1 for error condition } 1 -test io-53.6 {CopyData: error during fcopy} {stdio openpipe fcopy} { +test io-53.6 {CopyData: error during chan copy} {stdio openpipe fcopy} { variable fcopyTestDone file delete $path(pipe) file delete $path(test1) - catch {unset fcopyTestDone} + unset -nocomplain fcopyTestDone set f1 [open $path(pipe) w] puts $f1 "exit 1" close $f1 set in [open "|[list [interpreter] $path(pipe)]" r+] set out [open $path(test1) w] - fcopy $in $out -command [namespace code FcopyTestDone] + chan copy $in $out -command [namespace code FcopyTestDone] variable fcopyTestDone if ![info exists fcopyTestDone] { vwait [namespace which -variable fcopyTestDone] @@ -6910,15 +6909,15 @@ proc doFcopy {in out {bytes 0} {error {}}} { } elseif {[eof $in]} { set fcopyTestDone 0 } else { - # Delay next fcopy to wait for size>0 input bytes - after 100 [list fcopy $in $out -size 1000 \ + # Delay next chan copy to wait for size>0 input bytes + after 100 [list chan copy $in $out -size 1000 \ -command [namespace code [list doFcopy $in $out]]] } } -test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio openpipe fcopy} { +test io-53.7 {CopyData: Flooding chan copy from pipe} {stdio openpipe fcopy} { variable fcopyTestDone file delete $path(pipe) - catch {unset fcopyTestDone} + unset -nocomplain fcopyTestDone set fcopyTestCount 0 set f1 [open $path(pipe) w] puts $f1 { @@ -6931,7 +6930,7 @@ test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio openpipe fcopy} { set ::ready 1 } } - fconfigure stdout -buffering none + chan configure stdout -buffering none Write 345 ;# 3450 bytes ~3.45 sec vwait ready exit 0 @@ -6965,13 +6964,13 @@ test io-53.8 {CopyData: async callback and error handling, Bug 1932639} -setup { set foo [makeFile ashgdfashdgfasdhgfasdhgf foo] set bar [makeFile {} bar] # Channels to copy between - set f [open $foo r] ; fconfigure $f -translation binary - set g [open $bar w] ; fconfigure $g -translation binary -buffering none + set f [open $foo r] ; chan configure $f -translation binary + set g [open $bar w] ; chan configure $g -translation binary -buffering none } -constraints {stdio openpipe fcopy} -body { # Record input size, so that result is always defined lappend ::RES [file size $bar] # Run the copy. Should not invoke -command now. - fcopy $f $g -size 2 -command ::cmd + chan copy $f $g -size 2 -command ::cmd # Check that -command was not called synchronously set sbs [file size $bar] lappend ::RES [expr {($sbs > 0) ? "sync/FAIL" : "sync/OK"}] $sbs @@ -6988,10 +6987,9 @@ test io-53.8 {CopyData: async callback and error handling, Bug 1932639} -setup { } -cleanup { close $f close $g - catch {unset ::RES} - catch {unset ::forever} - rename ::cmd {} - rename ::bgerror {} + unset -nocomplain ::RES ::forever + rename ::cmd "" + rename ::bgerror "" removeFile foo removeFile bar } -result {0 sync/OK 0 {CMD 2} {bgerror/OK !STOP}} @@ -7006,14 +7004,14 @@ test io-53.8a {CopyData: async callback and error handling, Bug 1932639, at eof} set foo [makeFile ashgdfashdgfasdhgfasdhgf foo] set bar [makeFile {} bar] # Channels to copy between - set f [open $foo r] ; fconfigure $f -translation binary - set g [open $bar w] ; fconfigure $g -translation binary -buffering none + set f [open $foo r] ; chan configure $f -translation binary + set g [open $bar w] ; chan configure $g -translation binary -buffering none } -constraints {stdio openpipe fcopy} -body { # Initialize and force eof on the input. seek $f 0 end ; read $f 1 set ::RES [eof $f] # Run the copy. Should not invoke -command now. - fcopy $f $g -size 2 -command ::cmd + chan copy $f $g -size 2 -command ::cmd # Check that -command was not called synchronously lappend ::RES [expr {([llength $::RES] > 1) ? "sync/FAIL" : "sync/OK"}] # Now let the async part happen. Should capture the eof in cmd @@ -7029,8 +7027,7 @@ test io-53.8a {CopyData: async callback and error handling, Bug 1932639, at eof} } -cleanup { close $f close $g - catch {unset ::RES} - catch {unset ::forever} + unset -nocomplain ::RES ::forever rename ::cmd {} removeFile foo removeFile bar @@ -7046,12 +7043,12 @@ test io-53.8b {CopyData: async callback and -size 0} -setup { set foo [makeFile ashgdfashdgfasdhgfasdhgf foo] set bar [makeFile {} bar] # Channels to copy between - set f [open $foo r] ; fconfigure $f -translation binary - set g [open $bar w] ; fconfigure $g -translation binary -buffering none + set f [open $foo r] ; chan configure $f -translation binary + set g [open $bar w] ; chan configure $g -translation binary -buffering none } -constraints {stdio openpipe fcopy} -body { set ::RES {} # Run the copy. Should not invoke -command now. - fcopy $f $g -size 0 -command ::cmd + chan copy $f $g -size 0 -command ::cmd # Check that -command was not called synchronously lappend ::RES [expr {([llength $::RES] > 1) ? "sync/FAIL" : "sync/OK"}] # Now let the async part happen. Should capture the eof in cmd @@ -7067,8 +7064,7 @@ test io-53.8b {CopyData: async callback and -size 0} -setup { } -cleanup { close $f close $g - catch {unset ::RES} - catch {unset ::forever} + unset -nocomplain ::RES ::forever rename ::cmd {} removeFile foo removeFile bar @@ -7077,9 +7073,9 @@ test io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup { set out [makeFile {} out] set err [makeFile {} err] set pipe [open "|[list [info nameofexecutable] 2> $err]" r+] - fconfigure $pipe -translation binary -buffering line + chan configure $pipe -translation binary -buffering line puts $pipe { - fconfigure stdout -translation binary -buffering line + chan configure stdout -translation binary -buffering line puts stderr Waiting... after 1000 foreach x {a b c} { @@ -7096,7 +7092,7 @@ test io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup { } } puts stderr Now-sleeping-forever - fileevent stdin readable bye + chan event stdin readable bye vwait forever } proc ::done args { @@ -7106,9 +7102,9 @@ test io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup { set ::forever {} set out [open $out w] } -constraints {stdio openpipe fcopy} -body { - fcopy $pipe $out -size 6 -command ::done + chan copy $pipe $out -size 6 -command ::done set token [after 5000 { - set ::forever {fcopy hangs} + set ::forever {chan copy hangs} }] vwait ::forever catch {after cancel $token} @@ -7120,14 +7116,14 @@ test io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup { catch {close $out} catch {removeFile out} catch {removeFile err} - catch {unset ::forever} + unset -nocomplain ::forever } -result OK -test io-53.10 {Bug 1350564, multi-directional fcopy} -setup { +test io-53.10 {Bug 1350564, multi-directional chan copy} -setup { set err [makeFile {} err] set pipe [open "|[list [info nameofexecutable] 2> $err]" r+] - fconfigure $pipe -translation binary -buffering line + chan configure $pipe -translation binary -buffering line puts $pipe { - fconfigure stderr -buffering line + chan configure stderr -buffering line # Kill server when pipe closed by invoker. proc bye args { if {![eof stdin]} { gets stdin ; return } @@ -7142,13 +7138,13 @@ test io-53.10 {Bug 1350564, multi-directional fcopy} -setup { proc new {sok args} { puts stderr NEW/$sok global l srv - fconfigure $sok -translation binary -buffering none + chan configure $sok -translation binary -buffering none lappend l $sok - if {[llength $l]==2} { + if {[llength $l] == 2} { close $srv - foreach {a b} $l break - fcopy $a $b -command [list geof $a] - fcopy $b $a -command [list geof $b] + lassign $l a b + chan copy $a $b -command [list geof $a] + chan copy $b $a -command [list geof $b] puts stderr 2COPY } puts stderr ... @@ -7157,7 +7153,7 @@ test io-53.10 {Bug 1350564, multi-directional fcopy} -setup { set l {} set srv [socket -server new 9999] puts stderr WAITING - fileevent stdin readable bye + chan event stdin readable bye puts OK vwait forever } @@ -7171,10 +7167,10 @@ test io-53.10 {Bug 1350564, multi-directional fcopy} -setup { } set a [socket 127.0.0.1 9999] set b [socket 127.0.0.1 9999] - fconfigure $a -translation binary -buffering none - fconfigure $b -translation binary -buffering none - fileevent $a readable [list ::done $a] - fileevent $b readable [list ::done $b] + chan configure $a -translation binary -buffering none + chan configure $b -translation binary -buffering none + chan event $a readable [list ::done $a] + chan event $b readable [list ::done $b] } -constraints {stdio openpipe fcopy} -body { # Now pass data through the server in both directions. set ::forever {} @@ -7190,19 +7186,19 @@ test io-53.10 {Bug 1350564, multi-directional fcopy} -setup { rename ::done {} after 1000 ;# Give Windows time to kill the process removeFile err - catch {unset ::forever} + unset -nocomplain ::forever } -result {AB BA} test io-53.11 {Bug 2895565} -setup { set in [makeFile {} in] set f [open $in w] - fconfigure $f -encoding utf-8 -translation binary + chan configure $f -encoding utf-8 -translation binary puts -nonewline $f [string repeat "Ho hum\n" 11] close $f set inChan [open $in r] - fconfigure $inChan -translation binary + chan configure $inChan -translation binary set out [makeFile {} out] set outChan [open $out w] - fconfigure $outChan -encoding cp1252 -translation crlf + chan configure $outChan -encoding cp1252 -translation crlf proc CopyDone {bytes args} { variable done if {[llength $args]} { @@ -7214,7 +7210,7 @@ test io-53.11 {Bug 2895565} -setup { } -body { variable done after 2000 [list set [namespace which -variable done] timeout] - fcopy $inChan $outChan -size 40 -command [namespace which CopyDone] + chan copy $inChan $outChan -size 40 -command [namespace which CopyDone] vwait [namespace which -variable done] set done } -cleanup { @@ -7230,7 +7226,7 @@ test io-54.1 {Recursive channel events} {socket fileevent} { proc accept {s a p} { variable as - fconfigure $s -translation lf + chan configure $s -translation lf puts $s "line 1\nline2\nline3" flush $s set as $s @@ -7240,7 +7236,7 @@ test io-54.1 {Recursive channel events} {socket fileevent} { variable result lappend result $next if {$next == 1} { - fileevent $s readable [namespace code [list readit $s 2]] + chan event $s readable [namespace code [list readit $s 2]] vwait [namespace which -variable x] } incr x @@ -7252,7 +7248,7 @@ test io-54.1 {Recursive channel events} {socket fileevent} { set done 0 for {set i 0} {$i < 10} {incr i} { - if {![catch {set cs [socket 127.0.0.1 [lindex [fconfigure $ss -sockname] 2]]}]} { + if {![catch {set cs [socket 127.0.0.1 [lindex [chan configure $ss -sockname] 2]]}]} { set done 1 break } @@ -7266,10 +7262,10 @@ test io-54.1 {Recursive channel events} {socket fileevent} { variable x 0 variable as vwait [namespace which -variable as] - fconfigure $cs -translation lf + chan configure $cs -translation lf lappend result [gets $cs] - fconfigure $cs -blocking off - fileevent $cs readable [namespace code [list readit $cs 1]] + chan configure $cs -blocking off + chan event $cs readable [namespace code [list readit $cs 1]] set a [after 2000 [namespace code { set x failure }]] vwait [namespace which -variable x] after cancel $a @@ -7288,8 +7284,8 @@ test io-54.2 {Testing for busy-wait in recursive channel events} {socket fileeve set accept $s set counter 0 - fconfigure $s -blocking off -buffering line -translation lf - fileevent $s readable [namespace code "doit $s"] + chan configure $s -blocking off -buffering line -translation lf + chan event $s readable [namespace code "doit $s"] } proc doit {s} { variable counter @@ -7297,8 +7293,8 @@ test io-54.2 {Testing for busy-wait in recursive channel events} {socket fileeve incr counter set l [gets $s] - if {"$l" == ""} { - fileevent $s readable [namespace code "doit1 $s"] + if {$l eq ""} { + chan event $s readable [namespace code "doit1 $s"] set after [after 1000 [namespace code newline]] } } @@ -7309,14 +7305,14 @@ test io-54.2 {Testing for busy-wait in recursive channel events} {socket fileeve incr counter set l [gets $s] close $s - set accept {} + set accept "" } proc producer {} { variable s variable writer - set writer [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]] - fconfigure $writer -buffering line + set writer [socket 127.0.0.1 [lindex [chan configure $s -sockname] 2]] + chan configure $writer -buffering line puts -nonewline $writer hello flush $writer } @@ -7357,7 +7353,7 @@ test io-55.1 {ChannelEventScriptInvoker: deletion} -constraints { interp bgerror {} [namespace which myHandler] } -body { set f [open $path(fooBar) w] - fileevent $f writable [namespace code [list eventScript $f]] + chan event $f writable [namespace code [list eventScript $f]] variable x not_done vwait [namespace which -variable x] set x @@ -7392,11 +7388,11 @@ test io-57.1 {buffered data and file events, gets} {fileevent} { set s2 $sock } set server [socket -server [namespace code accept] -myaddr 127.0.0.1 0] - set s [socket 127.0.0.1 [lindex [fconfigure $server -sockname] 2]] + set s [socket 127.0.0.1 [lindex [chan configure $server -sockname] 2]] variable s2 vwait [namespace which -variable s2] update - fileevent $s2 readable [namespace code {lappend result readable}] + chan event $s2 readable [namespace code {lappend result readable}] puts $s "12\n34567890" flush $s variable result [gets $s2] @@ -7415,11 +7411,11 @@ test io-57.2 {buffered data and file events, read} {fileevent} { set s2 $sock } set server [socket -server [namespace code accept] -myaddr 127.0.0.1 0] - set s [socket 127.0.0.1 [lindex [fconfigure $server -sockname] 2]] + set s [socket 127.0.0.1 [lindex [chan configure $server -sockname] 2]] variable s2 vwait [namespace which -variable s2] update - fileevent $s2 readable [namespace code {lappend result readable}] + chan event $s2 readable [namespace code {lappend result readable}] puts -nonewline $s "1234567890" flush $s variable result [read $s2 1] @@ -7453,7 +7449,7 @@ test io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrPc openpipe } close $out set pipe [open "|[list [interpreter] $path(script)]" r] - fileevent $pipe readable [namespace code [list readit $pipe]] + chan event $pipe readable [namespace code [list readit $pipe]] variable x "" set result "" vwait [namespace which -variable x] @@ -7494,7 +7490,7 @@ test io-60.1 {writing illegal utf sequences} {openpipe fileevent} { } close $out set pipe [open "|[list [interpreter] $path(script)]" r] - fileevent $pipe readable [namespace code [list readit $pipe]] + chan event $pipe readable [namespace code [list readit $pipe]] variable x "" set result "" vwait [namespace which -variable x] @@ -7507,7 +7503,7 @@ test io-60.1 {writing illegal utf sequences} {openpipe fileevent} { test io-61.1 {Reset eof state after changing the eof char} -setup { set datafile [makeFile {} eofchar] set f [open $datafile w] - fconfigure $f -translation binary + chan configure $f -translation binary puts -nonewline $f [string repeat "Ho hum\n" 11] puts $f = set line [string repeat "Ge gla " 4] @@ -7515,10 +7511,10 @@ test io-61.1 {Reset eof state after changing the eof char} -setup { close $f } -body { set f [open $datafile r] - fconfigure $f -eofchar = + chan configure $f -eofchar = set res {} lappend res [read $f; tell $f] - fconfigure $f -eofchar {} + chan configure $f -eofchar {} lappend res [read $f 1] lappend res [read $f; tell $f] # Any seek zaps the internals into a good state. @@ -7556,12 +7552,11 @@ test io-70.0 {Cutting & Splicing channels} {testchannel} { set res } {0 1 0} - test io-70.1 {Transfer channel} {testchannel thread} { set f [makeFile {... dummy ...} cutsplice] set c [open $f r] - set res {} + set res [list] lappend res [catch {seek $c 0 start}] testchannel cut $c lappend res [catch {seek $c 0 start}] diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 03242be..50c8040 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -1,6 +1,6 @@ # -*- tcl -*- # Commands covered: open, close, gets, read, puts, seek, tell, eof, flush, -# fblocked, fconfigure, open, channel, fcopy +# chan blocked, chan configure, open, channel, chan copy # # 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 @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -48,21 +48,21 @@ set path(test1) [makeFile {} test1] test iocmd-1.6 {puts command} { set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} puts -nonewline $f foobar close $f file size $path(test1) } 6 test iocmd-1.7 {puts command} { set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} puts $f foobar close $f file size $path(test1) } 7 test iocmd-1.8 {puts command} { set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar {} -encoding iso8859-1 + chan configure $f -translation lf -eofchar {} -encoding iso8859-1 puts -nonewline $f [binary format a4a5 foo bar] close $f file size $path(test1) @@ -206,111 +206,111 @@ test iocmd-7.5 {close command} -setup { close $chan } -returnCodes error -result "Half-close of write-side not possible, side not opened or already closed" -test iocmd-8.1 {fconfigure command} { - list [catch {fconfigure} msg] $msg -} {1 {wrong # args: should be "fconfigure channelId ?-option 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 ?-option value ...?"}} -test iocmd-8.3 {fconfigure command} { - list [catch {fconfigure a b} msg] $msg +test iocmd-8.1 {chan configure command} { + list [catch {chan configure} msg] $msg +} {1 {wrong # args: should be "chan configure channelId ?-option value ...?"}} +test iocmd-8.2 {chan configure command} { + list [catch {chan configure a b c d e f} msg] $msg +} {1 {wrong # args: should be "chan configure channelId ?-option value ...?"}} +test iocmd-8.3 {chan configure command} { + list [catch {chan configure a b} msg] $msg } {1 {can not find channel named "a"}} -test iocmd-8.4 {fconfigure command} { +test iocmd-8.4 {chan configure command} { file delete $path(test1) set f1 [open $path(test1) w] - set x [list [catch {fconfigure $f1 froboz} msg] $msg] + set x [list [catch {chan configure $f1 froboz} msg] $msg] close $f1 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 +test iocmd-8.5 {chan configure command} { + list [catch {chan configure 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 +test iocmd-8.6 {chan configure command} { + list [catch {chan configure 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} { +test iocmd-8.7 {chan configure command} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} -encoding unicode - set x [fconfigure $f1] + chan configure $f1 -translation lf -eofchar {} -encoding unicode + set x [chan configure $f1] close $f1 set x } {-blocking 1 -buffering full -buffersize 4096 -encoding unicode -eofchar {} -translation lf} -test iocmd-8.8 {fconfigure command} { +test iocmd-8.8 {chan configure command} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -buffering line -buffersize 3030 \ + chan configure $f1 -translation lf -buffering line -buffersize 3030 \ -eofchar {} -encoding unicode set x "" - lappend x [fconfigure $f1 -buffering] - lappend x [fconfigure $f1] + lappend x [chan configure $f1 -buffering] + lappend x [chan configure $f1] close $f1 set x } {line {-blocking 1 -buffering line -buffersize 3030 -encoding unicode -eofchar {} -translation lf}} -test iocmd-8.9 {fconfigure command} { +test iocmd-8.9 {chan configure command} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation binary -buffering none -buffersize 4040 \ + chan configure $f1 -translation binary -buffering none -buffersize 4040 \ -eofchar {} -encoding binary - set x [fconfigure $f1] + set x [chan configure $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 +test iocmd-8.10 {chan configure command} { + list [catch {chan configure a b} msg] $msg } {1 {can not find channel named "a"}} set path(fconfigure.dummy) [makeFile {} fconfigure.dummy] -test iocmd-8.11 {fconfigure command} { +test iocmd-8.11 {chan configure command} { set chan [open $path(fconfigure.dummy) r] - set res [list [catch {fconfigure $chan -froboz blarfo} msg] $msg] + set res [list [catch {chan configure $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} { +test iocmd-8.12 {chan configure command} { set chan [open $path(fconfigure.dummy) r] - set res [list [catch {fconfigure $chan -b blarfo} msg] $msg] + set res [list [catch {chan configure $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} { +test iocmd-8.13 {chan configure command} { set chan [open $path(fconfigure.dummy) r] - set res [list [catch {fconfigure $chan -buffer blarfo} msg] $msg] + set res [list [catch {chan configure $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 +removeFile chan configure.dummy +test iocmd-8.14 {chan configure command} { + chan configure stdin -buffers } 4096 -test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOrPc} -setup { +test iocmd-8.15.1 {chan configure 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] + set port [lindex [chan configure $srv -sockname] 2] proc iocmdSRV {sock ip port} {close $sock} set cli [socket 127.0.0.1 $port] } -body { - fconfigure $cli -blah + chan configure $cli -blah } -cleanup { close $cli close $srv unset cli srv port rename iocmdSRV {} } -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 { +test iocmd-8.16 {chan configure command / tcp channel} -constraints socket -setup { set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0] - set port [lindex [fconfigure $srv -sockname] 2] + set port [lindex [chan configure $srv -sockname] 2] proc iocmdSRV {sock ip port} {close $sock} set cli [socket 127.0.0.1 $port] } -body { - expr {[lindex [fconfigure $cli -peername] 2] == $port} + expr {[lindex [chan configure $cli -peername] 2] == $port} } -cleanup { close $cli close $srv unset cli srv port rename iocmdSRV {} } -result 1 -test iocmd-8.17 {fconfigure command / tcp channel} -constraints nonPortable -setup { +test iocmd-8.17 {chan configure command / tcp channel} -constraints nonPortable -setup { set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0] - set port [lindex [fconfigure $srv -sockname] 2] + set port [lindex [chan configure $srv -sockname] 2] proc iocmdSRV {sock ip port} {close $sock} set cli [socket 127.0.0.1 $port] } -body { @@ -320,30 +320,30 @@ test iocmd-8.17 {fconfigure command / tcp channel} -constraints nonPortable -set puts $cli "blah" flush $cli; # that flush could/should fail too update - regsub -all {can([^:])+: } [catch {fconfigure $cli -peername} msg] {} + regsub -all {can([^:])+: } [catch {chan configure $cli -peername} msg] {} } -cleanup { close $cli close $srv unset cli srv port rename iocmdSRV {} } -result 1 -test iocmd-8.18 {fconfigure command / unix tty channel} -constraints {nonPortable unix} -setup { +test iocmd-8.18 {chan configure command / unix tty channel} -constraints {nonPortable unix} -setup { set tty "" } -body { # might fail if /dev/ttya is unavailable set tty [open /dev/ttya] - fconfigure $tty -blah blih + chan configure $tty -blah blih } -cleanup { if {$tty ne ""} { close $tty } } -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 { +test iocmd-8.19 {chan configure command / win tty channel} -constraints {nonPortable win} -setup { set tty "" } -body { # might fail early if com1 is unavailable set tty [open com1] - fconfigure $tty -blah blih + chan configure $tty -blah blih } -cleanup { if {$tty ne ""} { close $tty @@ -365,29 +365,29 @@ test iocmd-9.3 {eof command} { # The tests for Tcl_ExecObjCmd are in exec.test -test iocmd-10.1 {fblocked command} { - list [catch {fblocked} msg] $msg -} {1 {wrong # args: should be "fblocked channelId"}} -test iocmd-10.2 {fblocked command} { - list [catch {fblocked a b c d e f g} msg] $msg -} {1 {wrong # args: should be "fblocked channelId"}} -test iocmd-10.3 {fblocked command} { - list [catch {fblocked file1000} msg] $msg +test iocmd-10.1 {chan blocked command} { + list [catch {chan blocked} msg] $msg +} {1 {wrong # args: should be "chan blocked channelId"}} +test iocmd-10.2 {chan blocked command} { + list [catch {chan blocked a b c d e f g} msg] $msg +} {1 {wrong # args: should be "chan blocked channelId"}} +test iocmd-10.3 {chan blocked command} { + list [catch {chan blocked file1000} msg] $msg } {1 {can not find channel named "file1000"}} -test iocmd-10.4 {fblocked command} { - list [catch {fblocked stdout} msg] $msg +test iocmd-10.4 {chan blocked command} { + list [catch {chan blocked stdout} msg] $msg } {1 {channel "stdout" wasn't opened for reading}} -test iocmd-10.5 {fblocked command} { - fblocked stdin +test iocmd-10.5 {chan blocked command} { + chan blocked stdin } 0 -set path(test4) [makeFile {} test4] -set path(test5) [makeFile {} test5] +set path(test4) [makeFile "" test4] +set path(test5) [makeFile "" test5] -file delete $path(test5) +file delete -- $path(test5) test iocmd-11.1 {I/O to command pipelines} {unixOrPc unixExecs} { set f [open $path(test4) w] - close $f + chan 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} {unixOrPc unixExecs} { @@ -426,17 +426,17 @@ test iocmd-12.3 {POSIX open access modes: WRONLY} -match regexp -body { test iocmd-12.4 {POSIX open access modes: WRONLY} {unix} { file delete $path(test3) set f [open $path(test3) w] - fconfigure $f -eofchar {} + chan configure $f -eofchar {} puts $f xyzzy close $f set f [open $path(test3) WRONLY] - fconfigure $f -eofchar {} + chan configure $f -eofchar {} puts -nonewline $f "ab" seek $f 0 current set x [list [catch {gets $f} msg] $msg] close $f set f [open $path(test3) r] - fconfigure $f -eofchar {} + chan configure $f -eofchar {} lappend x [gets $f] close $f set y [list 1 [format "channel \"%s\" wasn't opened for reading" $f] abzzy] @@ -470,7 +470,7 @@ test iocmd-12.10 {POSIX open access modes: BINARY} { puts -nonewline $f c ;# contents are now 5 bytes: a\nb\nc close $f set f [open $path(test1) r] - fconfigure $f -translation binary + chan configure $f -translation binary set result [string length [read $f]] close $f set result @@ -480,7 +480,7 @@ test iocmd-12.11 {POSIX open access modes: BINARY} { puts $f \u0248 ;# gets truncated to \u0048 close $f set f [open $path(test1) r] - fconfigure $f -translation binary + chan configure $f -translation binary set result [read -nonewline $f] close $f set result @@ -566,7 +566,6 @@ test ioCmd-13.11 {open ... a+ must not use O_APPEND: Bug 1773127} -setup { removeFile $f } -result 341234x6 - test iocmd-14.1 {file id parsing errors} { list [catch {eof gorp} msg] $msg $::errorCode } {1 {can not find channel named "gorp"} {TCL LOOKUP CHANNEL gorp}} @@ -603,21 +602,21 @@ test iocmd-14.10 {file id parsing errors} { list [catch {eof $f} msg] $msg } $expect -test iocmd-15.1 {Tcl_FcopyObjCmd} {fcopy} { - list [catch {fcopy} msg] $msg -} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}} -test iocmd-15.2 {Tcl_FcopyObjCmd} {fcopy} { - list [catch {fcopy 1} msg] $msg -} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}} -test iocmd-15.3 {Tcl_FcopyObjCmd} {fcopy} { - list [catch {fcopy 1 2 3 4 5 6 7} msg] $msg -} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}} -test iocmd-15.4 {Tcl_FcopyObjCmd} {fcopy} { - list [catch {fcopy 1 2 3} msg] $msg -} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}} -test iocmd-15.5 {Tcl_FcopyObjCmd} {fcopy} { - list [catch {fcopy 1 2 3 4 5} msg] $msg -} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}} +test iocmd-15.1 {Tcl_FcopyObjCmd} {chan copy} { + list [catch {chan copy} msg] $msg +} {1 {wrong # args: should be "chan copy input output ?-size size? ?-command callback?"}} +test iocmd-15.2 {Tcl_FcopyObjCmd} {chan copy} { + list [catch {chan copy 1} msg] $msg +} {1 {wrong # args: should be "chan copy input output ?-size size? ?-command callback?"}} +test iocmd-15.3 {Tcl_FcopyObjCmd} {chan copy} { + list [catch {chan copy 1 2 3 4 5 6 7} msg] $msg +} {1 {wrong # args: should be "chan copy input output ?-size size? ?-command callback?"}} +test iocmd-15.4 {Tcl_FcopyObjCmd} {chan copy} { + list [catch {chan copy 1 2 3} msg] $msg +} {1 {wrong # args: should be "chan copy input output ?-size size? ?-command callback?"}} +test iocmd-15.5 {Tcl_FcopyObjCmd} {chan copy} { + list [catch {chan copy 1 2 3 4 5} msg] $msg +} {1 {wrong # args: should be "chan copy input output ?-size size? ?-command callback?"}} set path(test2) [makeFile {} test2] set f [open $path(test1) w] @@ -625,26 +624,26 @@ close $f set rfile [open $path(test1) r] set wfile [open $path(test2) w] -test iocmd-15.6 {Tcl_FcopyObjCmd} {fcopy} { - list [catch {fcopy foo $wfile} msg] $msg +test iocmd-15.6 {Tcl_FcopyObjCmd} {chan copy} { + list [catch {chan copy foo $wfile} msg] $msg } {1 {can not find channel named "foo"}} -test iocmd-15.7 {Tcl_FcopyObjCmd} {fcopy} { - list [catch {fcopy $rfile foo} msg] $msg +test iocmd-15.7 {Tcl_FcopyObjCmd} {chan copy} { + list [catch {chan copy $rfile foo} msg] $msg } {1 {can not find channel named "foo"}} -test iocmd-15.8 {Tcl_FcopyObjCmd} {fcopy} { - list [catch {fcopy $wfile $wfile} msg] $msg +test iocmd-15.8 {Tcl_FcopyObjCmd} {chan copy} { + list [catch {chan copy $wfile $wfile} msg] $msg } "1 {channel \"$wfile\" wasn't opened for reading}" -test iocmd-15.9 {Tcl_FcopyObjCmd} {fcopy} { - list [catch {fcopy $rfile $rfile} msg] $msg +test iocmd-15.9 {Tcl_FcopyObjCmd} {chan copy} { + list [catch {chan copy $rfile $rfile} msg] $msg } "1 {channel \"$rfile\" wasn't opened for writing}" -test iocmd-15.10 {Tcl_FcopyObjCmd} {fcopy} { - list [catch {fcopy $rfile $wfile foo bar} msg] $msg +test iocmd-15.10 {Tcl_FcopyObjCmd} {chan copy} { + list [catch {chan copy $rfile $wfile foo bar} msg] $msg } {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 +test iocmd-15.11 {Tcl_FcopyObjCmd} {chan copy} { + list [catch {chan copy $rfile $wfile -size foo} msg] $msg } {1 {expected integer but got "foo"}} -test iocmd-15.12 {Tcl_FcopyObjCmd} {fcopy} { - list [catch {fcopy $rfile $wfile -command bar -size foo} msg] $msg +test iocmd-15.12 {Tcl_FcopyObjCmd} {chan copy} { + list [catch {chan copy $rfile $wfile -command bar -size foo} msg] $msg } {1 {expected integer but got "foo"}} close $rfile @@ -1233,7 +1232,7 @@ test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} set c [chan create {r w} foo] - note [fconfigure $c] + note [chan configure $c] close $c rename foo {} set res @@ -1242,7 +1241,7 @@ test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} proc foo {args} {oninit cget cgetall; onfinal; track; return ""} set c [chan create {r w} foo] - note [fconfigure $c] + note [chan configure $c] close $c rename foo {} set res @@ -1254,7 +1253,7 @@ test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { return "-bar foo -snarf x" } set c [chan create {r w} foo] - note [fconfigure $c] + note [chan configure $c] close $c rename foo {} set res @@ -1266,7 +1265,7 @@ test iocmd-25.4 {chan configure, cgetall, bad result, list of uneven length} -ma return "-bar" } set c [chan create {r w} foo] - note [catch {fconfigure $c} msg]; note $msg + note [catch {chan configure $c} msg]; note $msg close $c rename foo {} set res @@ -1278,7 +1277,7 @@ test iocmd-25.5 {chan configure, cgetall, bad result, not a list} -match glob -b return "\{" } set c [chan create {r w} foo] - note [catch {fconfigure $c} msg]; note $msg + note [catch {chan configure $c} msg]; note $msg close $c rename foo {} set res @@ -1290,7 +1289,7 @@ test iocmd-25.6 {chan configure, cgetall, error return} -match glob -body { return -code error BOOM! } set c [chan create {r w} foo] - note [catch {fconfigure $c} msg]; note $msg + note [catch {chan configure $c} msg]; note $msg close $c rename foo {} set res @@ -1302,7 +1301,7 @@ test iocmd-25.7 {chan configure, cgetall, break return is error} -match glob -bo return -code break BOOM! } set c [chan create {r w} foo] - note [catch {fconfigure $c} msg]; note $msg + note [catch {chan configure $c} msg]; note $msg close $c rename foo {} set res @@ -1314,7 +1313,7 @@ test iocmd-25.8 {chan configure, cgetall, continue return is error} -match glob return -code continue BOOM! } set c [chan create {r w} foo] - note [catch {fconfigure $c} msg]; note $msg + note [catch {chan configure $c} msg]; note $msg close $c rename foo {} set res @@ -1326,7 +1325,7 @@ test iocmd-25.9 {chan configure, cgetall, custom return is error} -match glob -b return -code 777 BOOM! } set c [chan create {r w} foo] - note [catch {fconfigure $c} msg]; note $msg + note [catch {chan configure $c} msg]; note $msg close $c rename foo {} set res @@ -1338,7 +1337,7 @@ test iocmd-25.10 {chan configure, cgetall, level is ignored} -match glob -body { return -level 55 -code 777 BANG } set c [chan create {r w} foo] - note [catch {fconfigure $c} msg opt]; note $msg; noteOpts $opt + note [catch {chan configure $c} msg opt]; note $msg; noteOpts $opt close $c rename foo {} set res @@ -1353,7 +1352,7 @@ test iocmd-26.1 {chan configure, set standard option} -match glob -body { oninit configure; onfinal; track; note MUST_NOT_HAPPEN; return } set c [chan create {r w} foo] - note [fconfigure $c -translation lf] + note [chan configure $c -translation lf] close $c rename foo {} set res @@ -1365,7 +1364,7 @@ test iocmd-26.2 {chan configure, set option, error return} -match glob -body { return -code error BOOM! } set c [chan create {r w} foo] - note [catch {fconfigure $c -rc-foo bar} msg]; note $msg + note [catch {chan configure $c -rc-foo bar} msg]; note $msg close $c rename foo {} set res @@ -1374,7 +1373,7 @@ test iocmd-26.3 {chan configure, set option, ok return} -match glob -body { set res {} proc foo {args} {oninit configure; onfinal; track; return} set c [chan create {r w} foo] - note [fconfigure $c -rc-foo bar] + note [chan configure $c -rc-foo bar] close $c rename foo {} set res @@ -1386,7 +1385,7 @@ test iocmd-26.4 {chan configure, set option, break return is error} -match glob return -code break BOOM! } set c [chan create {r w} foo] - note [catch {fconfigure $c -rc-foo bar} msg]; note $msg + note [catch {chan configure $c -rc-foo bar} msg]; note $msg close $c rename foo {} set res @@ -1398,7 +1397,7 @@ test iocmd-26.5 {chan configure, set option, continue return is error} -match gl return -code continue BOOM! } set c [chan create {r w} foo] - note [catch {fconfigure $c -rc-foo bar} msg]; note $msg + note [catch {chan configure $c -rc-foo bar} msg]; note $msg close $c rename foo {} set res @@ -1410,7 +1409,7 @@ test iocmd-26.6 {chan configure, set option, custom return is error} -match glob return -code 444 BOOM! } set c [chan create {r w} foo] - note [catch {fconfigure $c -rc-foo bar} msg]; note $msg + note [catch {chan configure $c -rc-foo bar} msg]; note $msg close $c rename foo {} set res @@ -1422,7 +1421,7 @@ test iocmd-26.7 {chan configure, set option, level is ignored} -match glob -body return -level 55 -code 444 BANG } set c [chan create {r w} foo] - note [catch {fconfigure $c -rc-foo bar} msg opt]; note $msg; noteOpts $opt + note [catch {chan configure $c -rc-foo bar} msg opt]; note $msg; noteOpts $opt close $c rename foo {} set res @@ -1435,7 +1434,7 @@ test iocmd-27.1 {chan configure, get option, ok return} -match glob -body { set res {} proc foo {args} {oninit cget cgetall; onfinal; track; return foo} set c [chan create {r w} foo] - note [fconfigure $c -rc-foo] + note [chan configure $c -rc-foo] close $c rename foo {} set res @@ -1447,7 +1446,7 @@ test iocmd-27.2 {chan configure, get option, error return} -match glob -body { return -code error BOOM! } set c [chan create {r w} foo] - note [catch {fconfigure $c -rc-foo} msg]; note $msg + note [catch {chan configure $c -rc-foo} msg]; note $msg close $c rename foo {} set res @@ -1459,7 +1458,7 @@ test iocmd-27.3 {chan configure, get option, break return is error} -match glob return -code error BOOM! } set c [chan create {r w} foo] - note [catch {fconfigure $c -rc-foo} msg]; note $msg + note [catch {chan configure $c -rc-foo} msg]; note $msg close $c rename foo {} set res @@ -1471,7 +1470,7 @@ test iocmd-27.4 {chan configure, get option, continue return is error} -match gl return -code continue BOOM! } set c [chan create {r w} foo] - note [catch {fconfigure $c -rc-foo} msg]; note $msg + note [catch {chan configure $c -rc-foo} msg]; note $msg close $c rename foo {} set res @@ -1483,7 +1482,7 @@ test iocmd-27.5 {chan configure, get option, custom return is error} -match glob return -code 333 BOOM! } set c [chan create {r w} foo] - note [catch {fconfigure $c -rc-foo} msg]; note $msg + note [catch {chan configure $c -rc-foo} msg]; note $msg close $c rename foo {} set res @@ -1495,7 +1494,7 @@ test iocmd-27.6 {chan configure, get option, level is ignored} -match glob -body return -level 77 -code 333 BANG } set c [chan create {r w} foo] - note [catch {fconfigure $c -rc-foo} msg opt]; note $msg; noteOpts $opt + note [catch {chan configure $c -rc-foo} msg opt]; note $msg; noteOpts $opt close $c rename foo {} set res @@ -1689,7 +1688,7 @@ test iocmd-29.1 {chan blocking, no handler support} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} set c [chan create {r w} foo] - note [fconfigure $c -blocking] + note [chan configure $c -blocking] close $c rename foo {} set res @@ -1698,8 +1697,8 @@ test iocmd-29.2 {chan blocking, no handler support} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} set c [chan create {r w} foo] - note [fconfigure $c -blocking 0] - note [fconfigure $c -blocking] + note [chan configure $c -blocking 0] + note [chan configure $c -blocking] close $c rename foo {} set res @@ -1708,7 +1707,7 @@ test iocmd-29.3 {chan blocking, retrieval, handler support} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; note MUST_NOT_HAPPEN; return} set c [chan create {r w} foo] - note [fconfigure $c -blocking] + note [chan configure $c -blocking] close $c rename foo {} set res @@ -1717,8 +1716,8 @@ test iocmd-29.4 {chan blocking, resetting, handler support} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return} set c [chan create {r w} foo] - note [fconfigure $c -blocking 0] - note [fconfigure $c -blocking] + note [chan configure $c -blocking 0] + note [chan configure $c -blocking] close $c rename foo {} set res @@ -1727,8 +1726,8 @@ test iocmd-29.5 {chan blocking, setting, handler support} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return} set c [chan create {r w} foo] - note [fconfigure $c -blocking 1] - note [fconfigure $c -blocking] + note [chan configure $c -blocking 1] + note [chan configure $c -blocking] close $c rename foo {} set res @@ -1737,7 +1736,7 @@ test iocmd-29.6 {chan blocking, error return} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; error BOOM!} set c [chan create {r w} foo] - note [catch {fconfigure $c -blocking 0} msg]; note $msg + note [catch {chan configure $c -blocking 0} msg]; note $msg # Catch the close. It changes blocking mode internally, and runs into the error result. catch {close $c} rename foo {} @@ -1747,7 +1746,7 @@ test iocmd-29.7 {chan blocking, break return is error} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return -code break BOOM!} set c [chan create {r w} foo] - note [catch {fconfigure $c -blocking 0} msg]; note $msg + note [catch {chan configure $c -blocking 0} msg]; note $msg catch {close $c} rename foo {} set res @@ -1756,7 +1755,7 @@ test iocmd-29.8 {chan blocking, continue return is error} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return -code continue BOOM!} set c [chan create {r w} foo] - note [catch {fconfigure $c -blocking 0} msg]; note $msg + note [catch {chan configure $c -blocking 0} msg]; note $msg catch {close $c} rename foo {} set res @@ -1765,7 +1764,7 @@ test iocmd-29.9 {chan blocking, custom return is error} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return -code 44 BOOM!} set c [chan create {r w} foo] - note [catch {fconfigure $c -blocking 0} msg]; note $msg + note [catch {chan configure $c -blocking 0} msg]; note $msg catch {close $c} rename foo {} set res @@ -1775,7 +1774,7 @@ test iocmd-29.10 {chan blocking, level is ignored} -match glob -setup { } -body { proc foo {args} {oninit blocking; onfinal; track; return -level 99 -code 44 BANG} set c [chan create {r w} foo] - note [catch {fconfigure $c -blocking 0} msg opt]; note $msg; noteOpts $opt + note [catch {chan configure $c -blocking 0} msg opt]; note $msg; noteOpts $opt catch {close $c} return $res } -cleanup { @@ -1785,7 +1784,7 @@ test iocmd-29.11 {chan blocking, regular return ok, value ignored} -match glob - set res {} proc foo {args} {oninit blocking; onfinal; track; return BOGUS} set c [chan create {r w} foo] - note [catch {fconfigure $c -blocking 0} msg]; note $msg + note [catch {chan configure $c -blocking 0} msg]; note $msg catch {close $c} rename foo {} set res @@ -1798,7 +1797,7 @@ test iocmd-30.1 {chan watch, read interest, some return} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return IGNORED} set c [chan create {r w} foo] - note [fileevent $c readable {set tick $tick}] + note [chan event $c readable {set tick $tick}] close $c ;# 2nd watch, interest zero. rename foo {} set res @@ -1807,8 +1806,8 @@ test iocmd-30.2 {chan watch, write interest, error return} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return -code error BOOM!_IGNORED} set c [chan create {r w} foo] - note [fileevent $c writable {set tick $tick}] - note [fileevent $c writable {}] + note [chan event $c writable {set tick $tick}] + note [chan event $c writable {}] close $c rename foo {} set res @@ -1817,10 +1816,10 @@ test iocmd-30.3 {chan watch, accumulated interests} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return} set c [chan create {r w} foo] - note [fileevent $c writable {set tick $tick}] - note [fileevent $c readable {set tick $tick}] - note [fileevent $c writable {}] - note [fileevent $c readable {}] + note [chan event $c writable {set tick $tick}] + note [chan event $c readable {set tick $tick}] + note [chan event $c writable {}] + note [chan event $c readable {}] close $c rename foo {} set res @@ -1829,9 +1828,9 @@ test iocmd-30.4 {chan watch, unchanged interest not forwarded} -match glob -body set res {} proc foo {args} {oninit; onfinal; track; return} set c [chan create {r w} foo] - note [fileevent $c writable {set tick $tick}] - note [fileevent $c readable {set tick $tick}] ;# Script is changing, - note [fileevent $c readable {set tock $tock}] ;# interest does not. + note [chan event $c writable {set tick $tick}] + note [chan event $c readable {set tick $tick}] ;# Script is changing, + note [chan event $c readable {set tock $tock}] ;# interest does not. close $c ;# 3rd and 4th watch, removing the event handlers. rename foo {} set res @@ -1887,7 +1886,7 @@ 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] - note [fileevent $c readable {note TOCK}] + note [chan event $c readable {note TOCK}] set stop [after 10000 {note TIMEOUT}] after 1000 {note [chan postevent $c r]} vwait ::res @@ -1900,7 +1899,7 @@ 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 {note TOCK}] + note [chan event $c writable {note TOCK}] set stop [after 10000 {note TIMEOUT}] after 1000 {note [chan postevent $c w]} vwait ::res @@ -1913,7 +1912,7 @@ test iocmd-31.8 {chan postevent after close throws error} -match glob -setup { proc foo {args} {oninit; onfinal; track; return} proc dummy args { return } set c [chan create {r w} foo] - fileevent $c readable dummy + chan event $c readable dummy } -body { close $c chan postevent $c read @@ -1941,7 +1940,7 @@ test iocmd-32.0 {origin interpreter of moved channel gone} -match glob -body { set chan [interp eval $ida { proc foo {args} {oninit seek; onfinal; track; return} set chan [chan create {r w} foo] - fconfigure $chan -buffering none + chan configure $chan -buffering none set chan }] @@ -1982,7 +1981,7 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m interp delete {} return} set chan [chan create {r w} foo] - fconfigure $chan -buffering none + chan configure $chan -buffering none set chan }] @@ -2707,8 +2706,8 @@ test iocmd.tf-24.17.bug3522560 {postevent for transfered channel} \ LOG "<- [info level 0]" } LOG THREAD-FILEEVENT - fconfigure $thech -translation binary -blocking 0 - fileevent $thech readable [list PROCESS $thech] + chan configure $thech -translation binary -blocking 0 + chan event $thech readable [list PROCESS $thech] LOG THREAD-NOEVENT-LOOP set done 0 while {!$done} { @@ -2741,7 +2740,7 @@ test iocmd.tf-25.1 {chan configure, cgetall, standard options} -match glob -body proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} set c [chan create {r w} foo] notes [inthread $c { - note [fconfigure $c] + note [chan configure $c] close $c notes } c] @@ -2754,7 +2753,7 @@ test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body { proc foo {args} {oninit cget cgetall; onfinal; track; return ""} set c [chan create {r w} foo] notes [inthread $c { - note [fconfigure $c] + note [chan configure $c] close $c notes } c] @@ -2770,7 +2769,7 @@ test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body { } set c [chan create {r w} foo] notes [inthread $c { - note [fconfigure $c] + note [chan configure $c] close $c notes } c] @@ -2786,7 +2785,7 @@ test iocmd.tf-25.4 {chan configure, cgetall, bad result, list of uneven length} } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c} msg] + note [catch {chan configure $c} msg] note $msg close $c notes @@ -2802,7 +2801,7 @@ test iocmd.tf-25.5 {chan configure, cgetall, bad result, not a list} -match glob } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c} msg] + note [catch {chan configure $c} msg] note $msg close $c notes @@ -2818,7 +2817,7 @@ test iocmd.tf-25.6 {chan configure, cgetall, error return} -match glob -body { } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c} msg] + note [catch {chan configure $c} msg] note $msg close $c notes @@ -2834,7 +2833,7 @@ test iocmd.tf-25.7 {chan configure, cgetall, break return is error} -match glob } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c} msg] + note [catch {chan configure $c} msg] note $msg close $c notes @@ -2851,7 +2850,7 @@ test iocmd.tf-25.8 {chan configure, cgetall, continue return is error} -match gl } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c} msg] + note [catch {chan configure $c} msg] note $msg close $c notes @@ -2868,7 +2867,7 @@ test iocmd.tf-25.9 {chan configure, cgetall, custom return is error} -match glob } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c} msg] + note [catch {chan configure $c} msg] note $msg close $c notes @@ -2885,7 +2884,7 @@ test iocmd.tf-25.10 {chan configure, cgetall, level is ignored} -match glob -bod } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c} msg opt] + note [catch {chan configure $c} msg opt] note $msg noteOpts $opt close $c @@ -2906,7 +2905,7 @@ test iocmd.tf-26.1 {chan configure, set standard option} -match glob -body { } set c [chan create {r w} foo] notes [inthread $c { - note [fconfigure $c -translation lf] + note [chan configure $c -translation lf] close $c notes } c] @@ -2921,7 +2920,7 @@ test iocmd.tf-26.2 {chan configure, set option, error return} -match glob -body } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -rc-foo bar} msg] + note [catch {chan configure $c -rc-foo bar} msg] note $msg close $c notes @@ -2934,7 +2933,7 @@ test iocmd.tf-26.3 {chan configure, set option, ok return} -match glob -body { proc foo {args} {oninit configure; onfinal; track; return} set c [chan create {r w} foo] notes [inthread $c { - note [fconfigure $c -rc-foo bar] + note [chan configure $c -rc-foo bar] close $c notes } c] @@ -2949,7 +2948,7 @@ test iocmd.tf-26.4 {chan configure, set option, break return is error} -match gl } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -rc-foo bar} msg] + note [catch {chan configure $c -rc-foo bar} msg] note $msg close $c notes @@ -2966,7 +2965,7 @@ test iocmd.tf-26.5 {chan configure, set option, continue return is error} -match } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -rc-foo bar} msg] + note [catch {chan configure $c -rc-foo bar} msg] note $msg close $c notes @@ -2983,7 +2982,7 @@ test iocmd.tf-26.6 {chan configure, set option, custom return is error} -match g } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -rc-foo bar} msg] + note [catch {chan configure $c -rc-foo bar} msg] note $msg close $c notes @@ -3000,7 +2999,7 @@ test iocmd.tf-26.7 {chan configure, set option, level is ignored} -match glob -b } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -rc-foo bar} msg opt] + note [catch {chan configure $c -rc-foo bar} msg opt] note $msg noteOpts $opt close $c @@ -3019,7 +3018,7 @@ test iocmd.tf-27.1 {chan configure, get option, ok return} -match glob -body { proc foo {args} {oninit cget cgetall; onfinal; track; return foo} set c [chan create {r w} foo] notes [inthread $c { - note [fconfigure $c -rc-foo] + note [chan configure $c -rc-foo] close $c notes } c] @@ -3034,7 +3033,7 @@ test iocmd.tf-27.2 {chan configure, get option, error return} -match glob -body } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -rc-foo} msg] + note [catch {chan configure $c -rc-foo} msg] note $msg close $c notes @@ -3050,7 +3049,7 @@ test iocmd.tf-27.3 {chan configure, get option, break return is error} -match gl } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -rc-foo} msg] + note [catch {chan configure $c -rc-foo} msg] note $msg close $c notes @@ -3067,7 +3066,7 @@ test iocmd.tf-27.4 {chan configure, get option, continue return is error} -match } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -rc-foo} msg] + note [catch {chan configure $c -rc-foo} msg] note $msg close $c notes @@ -3084,7 +3083,7 @@ test iocmd.tf-27.5 {chan configure, get option, custom return is error} -match g } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -rc-foo} msg] + note [catch {chan configure $c -rc-foo} msg] note $msg close $c notes @@ -3101,7 +3100,7 @@ test iocmd.tf-27.6 {chan configure, get option, level is ignored} -match glob -b } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -rc-foo} msg opt] + note [catch {chan configure $c -rc-foo} msg opt] note $msg noteOpts $opt close $c @@ -3394,7 +3393,7 @@ test iocmd.tf-29.1 {chan blocking, no handler support} -match glob -body { proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} set c [chan create {r w} foo] notes [inthread $c { - note [fconfigure $c -blocking] + note [chan configure $c -blocking] close $c notes } c] @@ -3407,8 +3406,8 @@ test iocmd.tf-29.2 {chan blocking, no handler support} -match glob -body { proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} set c [chan create {r w} foo] notes [inthread $c { - note [fconfigure $c -blocking 0] - note [fconfigure $c -blocking] + note [chan configure $c -blocking 0] + note [chan configure $c -blocking] close $c notes } c] @@ -3421,7 +3420,7 @@ test iocmd.tf-29.3 {chan blocking, retrieval, handler support} -match glob -body proc foo {args} {oninit blocking; onfinal; track; note MUST_NOT_HAPPEN; return} set c [chan create {r w} foo] notes [inthread $c { - note [fconfigure $c -blocking] + note [chan configure $c -blocking] close $c notes } c] @@ -3434,8 +3433,8 @@ test iocmd.tf-29.4 {chan blocking, resetting, handler support} -match glob -body proc foo {args} {oninit blocking; onfinal; track; return} set c [chan create {r w} foo] notes [inthread $c { - note [fconfigure $c -blocking 0] - note [fconfigure $c -blocking] + note [chan configure $c -blocking 0] + note [chan configure $c -blocking] close $c notes } c] @@ -3448,8 +3447,8 @@ test iocmd.tf-29.5 {chan blocking, setting, handler support} -match glob -body { proc foo {args} {oninit blocking; onfinal; track; return} set c [chan create {r w} foo] notes [inthread $c { - note [fconfigure $c -blocking 1] - note [fconfigure $c -blocking] + note [chan configure $c -blocking 1] + note [chan configure $c -blocking] close $c notes } c] @@ -3462,7 +3461,7 @@ test iocmd.tf-29.6 {chan blocking, error return} -match glob -body { proc foo {args} {oninit blocking; onfinal; track; error BOOM!} set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -blocking 0} msg] + note [catch {chan configure $c -blocking 0} msg] note $msg # Catch the close. It changes blocking mode internally, and runs into the error result. catch {close $c} @@ -3477,7 +3476,7 @@ test iocmd.tf-29.7 {chan blocking, break return is error} -match glob -body { proc foo {args} {oninit blocking; onfinal; track; return -code break BOOM!} set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -blocking 0} msg] + note [catch {chan configure $c -blocking 0} msg] note $msg catch {close $c} notes @@ -3491,7 +3490,7 @@ test iocmd.tf-29.8 {chan blocking, continue return is error} -match glob -body { proc foo {args} {oninit blocking; onfinal; track; return -code continue BOOM!} set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -blocking 0} msg] + note [catch {chan configure $c -blocking 0} msg] note $msg catch {close $c} notes @@ -3505,7 +3504,7 @@ test iocmd.tf-29.9 {chan blocking, custom return is error} -match glob -body { proc foo {args} {oninit blocking; onfinal; track; return -code 44 BOOM!} set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -blocking 0} msg] + note [catch {chan configure $c -blocking 0} msg] note $msg catch {close $c} notes @@ -3519,7 +3518,7 @@ test iocmd.tf-29.10 {chan blocking, level is ignored} -match glob -body { proc foo {args} {oninit blocking; onfinal; track; return -level 99 -code 44 BANG} set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -blocking 0} msg opt] + note [catch {chan configure $c -blocking 0} msg opt] note $msg noteOpts $opt catch {close $c} @@ -3534,7 +3533,7 @@ test iocmd.tf-29.11 {chan blocking, regular return ok, value ignored} -match glo proc foo {args} {oninit blocking; onfinal; track; return BOGUS} set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -blocking 0} msg] + note [catch {chan configure $c -blocking 0} msg] note $msg catch {close $c} notes @@ -3552,7 +3551,7 @@ test iocmd.tf-30.1 {chan watch, read interest, some return} -match glob -body { proc foo {args} {oninit; onfinal; track; return IGNORED} set c [chan create {r w} foo] notes [inthread $c { - note [fileevent $c readable {set tick $tick}] + note [chan event $c readable {set tick $tick}] close $c ;# 2nd watch, interest zero. notes } c] @@ -3564,8 +3563,8 @@ test iocmd.tf-30.2 {chan watch, write interest, error return} -match glob -body proc foo {args} {oninit; onfinal; track; return -code error BOOM!_IGNORED} set c [chan create {r w} foo] notes [inthread $c { - note [fileevent $c writable {set tick $tick}] - note [fileevent $c writable {}] + note [chan event $c writable {set tick $tick}] + note [chan event $c writable {}] close $c notes } c] @@ -3577,10 +3576,10 @@ test iocmd.tf-30.3 {chan watch, accumulated interests} -match glob -body { proc foo {args} {oninit; onfinal; track; return} set c [chan create {r w} foo] notes [inthread $c { - note [fileevent $c writable {set tick $tick}] - note [fileevent $c readable {set tick $tick}] - note [fileevent $c writable {}] - note [fileevent $c readable {}] + note [chan event $c writable {set tick $tick}] + note [chan event $c readable {set tick $tick}] + note [chan event $c writable {}] + note [chan event $c readable {}] close $c notes } c] @@ -3593,9 +3592,9 @@ test iocmd.tf-30.4 {chan watch, unchanged interest not forwarded} -match glob -b proc foo {args} {oninit; onfinal; track; return} set c [chan create {r w} foo] notes [inthread $c { - note [fileevent $c writable {set tick $tick}] - note [fileevent $c readable {set tick $tick}] ;# Script is changing, - note [fileevent $c readable {set tock $tock}] ;# interest does not. + note [chan event $c writable {set tick $tick}] + note [chan event $c readable {set tick $tick}] ;# Script is changing, + note [chan event $c readable {set tock $tock}] ;# interest does not. close $c ;# 3rd and 4th watch, removing the event handlers. notes } c] @@ -3643,7 +3642,7 @@ test iocmd.tf-32.0 {origin thread of moved channel gone} -match glob -body { set chan [thread::send $tida { proc foo {args} {oninit seek; onfinal; track; return} set chan [chan create {r w} foo] - fconfigure $chan -buffering none + chan configure $chan -buffering none set chan }] @@ -3697,7 +3696,7 @@ test iocmd.tf-32.1 {origin thread of moved channel destroyed during access} -mat thread::exit } set chan [chan create {r w} foo] - fconfigure $chan -buffering none + chan configure $chan -buffering none set chan }] diff --git a/tests/ioTrans.test b/tests/ioTrans.test index 5a8874c..28e0bfc 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -36,7 +36,7 @@ testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] # can access this variable. set helperscript { - if {[lsearch [namespace children] ::tcltest] == -1} { + if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -967,7 +967,7 @@ test iortrans-11.0 {origin interpreter of moved transform gone} -setup { return } set chan [chan push $tempchan foo] - fconfigure $chan -buffering none + chan configure $chan -buffering none set chan }] # Move channel to 2nd interpreter, transform goes with it. @@ -1008,7 +1008,7 @@ test iortrans-11.1 {origin interpreter of moved transform destroyed during acces interp delete {} return} set chan [chan push [tempchan] foo] - fconfigure $chan -buffering none + chan configure $chan -buffering none set chan }] # Move channel to 2nd thread, transform goes with it. @@ -1801,7 +1801,7 @@ test iortrans.tf-11.0 {origin thread of moved transform gone} -setup { return } set chan [chan push [tempchan] foo] - fconfigure $chan -buffering none + chan configure $chan -buffering none set chan }] @@ -1846,7 +1846,7 @@ test iortrans.tf-11.1 {origin thread of moved transform destroyed during access} thread::exit } set chan [chan push [tempchan] foo] - fconfigure $chan -buffering none + chan configure $chan -buffering none set chan }] diff --git a/tests/iogt.test b/tests/iogt.test index d4c31d2..5a9a186 100644 --- a/tests/iogt.test +++ b/tests/iogt.test @@ -21,16 +21,16 @@ catch [list package require -exact Tcltest [info patchlevel]] namespace eval ::tcl::test::iogt { namespace import ::tcltest::* -testConstraint testchannel [llength [info commands testchannel]] +tcltest::testConstraint testchannel [llength [info commands testchannel]] -set path(dummy) [makeFile {abcdefghijklmnopqrstuvwxyz0123456789,./?><;'\|":[]\}\{`~!@#$%^&*()_+-= +set path(dummy) [tcltest::makeFile {abcdefghijklmnopqrstuvwxyz0123456789,./?><;'\|":[]\}\{`~!@#$%^&*()_+-= } dummy] # " capture coloring of quotes -set path(dummyout) [makeFile {} dummyout] +set path(dummyout) [tcltest::makeFile {} dummyout] -set path(__echo_srv__.tcl) [makeFile { +set path(__echo_srv__.tcl) [tcltest::makeFile { #!/usr/local/bin/tclsh # -*- tcl -*- # echo server @@ -60,8 +60,8 @@ proc newconn {sock rhost rport} { set conn(data) "" set conn(delay) $fdelay - fileevent $sock readable [list echoGet $c $sock] - fconfigure $sock -translation binary -buffering none -blocking 0 + chan event $sock readable [list echoGet $c $sock] + chan configure $sock -translation binary -buffering none -blocking 0 } proc echoGet {c sock} { @@ -76,7 +76,7 @@ proc echoGet {c sock} { #puts stdout "G $c $sock $conn(data) <<$conn(data)>>" ; flush stdout - if {$conn(after) == {}} { + if {$conn(after) eq ""} { set conn(after) [after $conn(delay) [list echoPut $c $sock]] } } @@ -118,7 +118,7 @@ proc echoPut {c sock} { set conn(after) [after $conn(delay) [list echoPut $c $sock]] } -#fileevent stdin readable {exit ;#cut} +#chan event stdin readable {exit ;#cut} # main socket -server newconn -myaddr 127.0.0.1 $port @@ -143,8 +143,8 @@ proc fevent {fdelay idelay blocks script data} { #puts stdout "> $port"; flush stdout set sk [socket localhost $port] - fconfigure $sk -blocking 0 -buffering full \ - -buffersize [expr {10+[llength $data]}] + chan configure $sk -blocking 0 -buffering full \ + -buffersize [expr {10 + [llength $data]}] puts -nonewline $sk $data # The channel is prepared to go off. @@ -152,7 +152,7 @@ proc fevent {fdelay idelay blocks script data} { #puts stdout ">>>>>"; flush stdout set res [uplevel 1 $script] - catch {close $sk} + catch {chan close $sk} return $res } @@ -170,11 +170,12 @@ proc id {op data} { query/maxRead { return -1 } + default {} } } proc id_optrail {var op data} { - variable $var + variable [set var] upvar 0 $var trail lappend trail $op @@ -197,7 +198,7 @@ proc id_optrail {var op data} { } proc id_fulltrail {var op data} { - namespace upvar [namespace current] $var trail + namespace upvar [namespace current] [set var] trail #puts stdout ">> $var $op $data" ; flush stdout @@ -211,6 +212,7 @@ proc id_fulltrail {var op data} { query/maxRead { set res -1 } + default {} } #catch {puts stdout "\t>* $res" ; flush stdout} @@ -221,7 +223,7 @@ proc id_fulltrail {var op data} { } proc counter {var op data} { - namespace upvar [namespace current] $var n + namespace upvar [namespace current] [set var] n switch -- $op { create/write - create/read - delete/write - delete/read - clear_read { @@ -245,11 +247,12 @@ proc counter {var op data} { query/maxRead { return $n } + default {} } } proc counter_audit {var vtrail op data} { - namespace upvar [namespace current] $var n $vtrail trail + namespace upvar [namespace current] [set var] n [set vtrail] trail switch -- $op { create/write - create/read - delete/write - delete/read - clear_read { @@ -273,6 +276,7 @@ proc counter_audit {var vtrail op data} { query/maxRead { set res $n } + default {} } lappend trail [list counter:$op $data $res] @@ -280,19 +284,19 @@ proc counter_audit {var vtrail op data} { } proc rblocks {var vtrail n op data} { - namespace upvar [namespace current] $var n $vtrail trail + namespace upvar [namespace current] [set var] n [set vtrail] trail - set res {} + set res "" switch -- $op { create/write - create/read - delete/write - delete/read - clear_read { - set buf {} + set buf "" } flush/write { } flush/read { set res $buf - set buf {} + set buf "" } write { set data @@ -308,6 +312,7 @@ proc rblocks {var vtrail n op data} { query/maxRead { set res -1 } + default {} } lappend trail [list rblock | $op $data $res | $buf] @@ -327,12 +332,12 @@ proc audit_flow {var -attach channel} { testchannel transform $channel -command [namespace code [list id_fulltrail $var]] } proc stopafter {var n -attach channel} { - namespace upvar [namespace current] $var vn + namespace upvar [namespace current] [set var] n set vn $n testchannel transform $channel -command [namespace code [list counter $var]] } proc stopafter_audit {var trail n -attach channel} { - namespace upvar [namespace current] $var vn + namespace upvar [namespace current] [set var] n set vn $n testchannel transform $channel -command [namespace code [list counter_audit $var $trail]] } @@ -344,7 +349,7 @@ proc rblocks_t {var trail n -attach channel} { # serialize an array, with keys in sorted order. proc array_sget {v} { - upvar $v a + upvar 1 $v a set res [list] foreach n [lsort [array names a]] { lappend res $n $a($n) @@ -372,11 +377,11 @@ test iogt-1.2 {stack/close} testchannel { } {} test iogt-1.3 {stack/unstack, configuration, options} testchannel { set fh [open $path(dummy) r] - set ca [asort [fconfigure $fh]] + set ca [asort [chan configure $fh]] identity -attach $fh - set cb [asort [fconfigure $fh]] + set cb [asort [chan configure $fh]] testchannel unstack $fh - set cc [asort [fconfigure $fh]] + set cc [asort [chan configure $fh]] close $fh # With this system none of the buffering, translation and encoding option # may change their values with channels stacked upon each other or not. @@ -386,13 +391,13 @@ test iogt-1.3 {stack/unstack, configuration, options} testchannel { test iogt-1.4 {stack/unstack, configuration} -setup { set fh [open $path(dummy) r] } -constraints testchannel -body { - set ca [asort [fconfigure $fh]] + set ca [asort [chan configure $fh]] identity -attach $fh - fconfigure $fh -buffering line -translation cr -encoding shiftjis + chan configure $fh -buffering line -translation cr -encoding shiftjis testchannel unstack $fh - set cc [asort [fconfigure $fh]] - list [string equal $ca $cc] [fconfigure $fh -buffering] \ - [fconfigure $fh -translation] [fconfigure $fh -encoding] + set cc [asort [chan configure $fh]] + list [string equal $ca $cc] [chan configure $fh -buffering] \ + [chan configure $fh -translation] [chan configure $fh -encoding] } -cleanup { close $fh } -result {0 line cr shiftjis} @@ -403,7 +408,7 @@ test iogt-2.0 {basic I/O going through transform} -setup { } -constraints testchannel -body { identity -attach $fin identity -attach $fout - fcopy $fin $fout + chan copy $fin $fout close $fin close $fout set fin [open $path(dummy) r] @@ -420,9 +425,9 @@ test iogt-2.1 {basic I/O, operation trail} {testchannel unix} { set ain [list]; set aout [list] audit_ops ain -attach $fin audit_ops aout -attach $fout - fconfigure $fin -buffersize 10 - fconfigure $fout -buffersize 10 - fcopy $fin $fout + chan configure $fin -buffersize 10 + chan configure $fout -buffersize 10 + chan copy $fin $fout close $fin close $fout set res "[join $ain \n]\n--------\n[join $aout \n]" @@ -464,9 +469,9 @@ test iogt-2.2 {basic I/O, data trail} {testchannel unix} { set ain [list]; set aout [list] audit_flow ain -attach $fin audit_flow aout -attach $fout - fconfigure $fin -buffersize 10 - fconfigure $fout -buffersize 10 - fcopy $fin $fout + chan configure $fin -buffersize 10 + chan configure $fout -buffersize 10 + chan copy $fin $fout close $fin close $fout set res "[join $ain \n]\n--------\n[join $aout \n]" @@ -512,9 +517,9 @@ test iogt-2.3 {basic I/O, mixed trail} {testchannel unix} { set trail [list] audit_flow trail -attach $fin audit_flow trail -attach $fout - fconfigure $fin -buffersize 20 - fconfigure $fout -buffersize 10 - fcopy $fin $fout + chan configure $fin -buffersize 20 + chan configure $fout -buffersize 10 + chan copy $fin $fout close $fin close $fout join $trail \n @@ -552,23 +557,23 @@ test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} -setup { } } -constraints {testchannel hangs} -body { # This test to check the validity of aquired Tcl_Channel references is not - # possible because even a backgrounded fcopy will immediately start to + # possible because even a backgrounded chan copy will immediately start to # copy data, without waiting for the event loop. This is done only in case # of an underflow on the read size!. So stacking transforms after the - # fcopy will miss information, or are not used at all. + # chan copy will miss information, or are not used at all. # # I was able to circumvent this by using the echo.tcl server with a big - # delay, causing the fcopy to underflow immediately. + # delay, causing the chan copy to underflow immediately. set fin [open $path(dummy) r] fevent 1000 500 {20 20 20 10 1 1} { close $fin set fout [open dummyout w] - flush $sock; # now, or fcopy will error us out + flush $sock; # now, or chan copy will error us out # But the 1 second delay should be enough to initialize everything # else here. - fcopy $sock $fout -command [namespace code DoneCopy] - # Transform after fcopy got its handles! They should be still valid - # for fcopy. + chan copy $sock $fout -command [namespace code DoneCopy] + # Transform after chan copy got its handles! They should be still valid + # for chan copy. set trail [list] audit_ops trail -attach $fout vwait [namespace which -variable copy] @@ -585,7 +590,7 @@ test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} -setup { rename DoneCopy {} } -result {1 {create/write create/read write flush/write flush/read delete/write delete/read}} -test iogt-4.0 {fileevent readable, after transform} -setup { +test iogt-4.0 {chan event readable, after transform} -setup { set fin [open $path(dummy) r] set data [read $fin] close $fin @@ -598,7 +603,7 @@ test iogt-4.0 {fileevent readable, after transform} -setup { fevent 1000 500 {20 20 20 10 1} { audit_flow trail -attach $sock rblocks_t rbuf trail 23 -attach $sock - fileevent $sock readable [namespace code { + chan event $sock readable [namespace code { if {[eof $sock]} { Done lappend trail "xxxxxxxxxxxxx" @@ -611,7 +616,7 @@ test iogt-4.0 {fileevent readable, after transform} -setup { #read $sock } }] - flush $sock; # Now, or fcopy will error us out + flush $sock; # Now, or chan copy will error us out # But the 1 second delay should be enough to initialize everything # else here. vwait [namespace which -variable stop] @@ -710,13 +715,13 @@ test iogt-5.0 {EOF simulation} -setup { audit_flow trail -attach $fin stopafter_audit d trail 20 -attach $fin audit_flow trail -attach $fout - fconfigure $fin -buffersize 20 - fconfigure $fout -buffersize 10 - fcopy $fin $fout + chan configure $fin -buffersize 20 + chan configure $fout -buffersize 10 + chan copy $fin $fout testchannel unstack $fin # now copy the rest in the channel lappend trail {**after unstack**} - fcopy $fin $fout + chan copy $fin $fout close $fin close $fout join $trail \n @@ -763,6 +768,7 @@ proc constX {op data} { query/maxRead { return -1 } + default {} } } proc constx {-attach channel} { diff --git a/tests/join.test b/tests/join.test index 4abe233..f6c6dbe 100644 --- a/tests/join.test +++ b/tests/join.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } diff --git a/tests/lindex.test b/tests/lindex.test index b86e2e0..2c52026 100644 --- a/tests/lindex.test +++ b/tests/lindex.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.2 namespace import -force ::tcltest::* } @@ -447,7 +447,7 @@ test lindex-17.1 {Bug 1718580} {*}{ -returnCodes 1 } -catch { unset minus } +unset -nocomplain minus # cleanup ::tcltest::cleanupTests diff --git a/tests/link.test b/tests/link.test index 00e490c..ec310de 100644 --- a/tests/link.test +++ b/tests/link.test @@ -21,9 +21,7 @@ catch [list package require -exact Tcltest [info patchlevel]] testConstraint testlink [llength [info commands testlink]] -foreach i {int real bool string} { - unset -nocomplain $i -} +unset -nocomplain int real bool string test link-1.1 {reading C variables from Tcl} -constraints {testlink} -setup { testlink delete @@ -296,9 +294,7 @@ test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} { catch {testlink set 0 0 0 - 0 0 0 0 0 0 0 0 0 0} catch {testlink delete} -foreach i {int real bool string wide} { - unset -nocomplain $i -} +unset -nocomplain int real bool string wide # cleanup ::tcltest::cleanupTests diff --git a/tests/linsert.test b/tests/linsert.test index 4939e5c..c10e213 100644 --- a/tests/linsert.test +++ b/tests/linsert.test @@ -11,12 +11,12 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } -catch {unset lis} +unset -nocomplain lis catch {rename p ""} test linsert-1.1 {linsert command} { @@ -107,13 +107,13 @@ test linsert-3.1 {linsert won't modify shared argument objects} { p } "a b c" test linsert-3.2 {linsert won't modify shared argument objects} { - catch {unset lis} + unset -nocomplain lis set lis [format "a \"%s\" c" "b"] linsert $lis 0 [string length $lis] } "7 a b c" # cleanup -catch {unset lis} +unset -nocomplain lis catch {rename p ""} ::tcltest::cleanupTests return diff --git a/tests/list.test b/tests/list.test index dff5d50..3ec1967 100644 --- a/tests/list.test +++ b/tests/list.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -91,33 +91,33 @@ lcheck list-2.12 a\\} {a \}b} {a \{c} lcheck list-2.13 xyz \\ 1\\\n2 lcheck list-2.14 "{ab}\\" "{ab}xy" abc -concat {} +concat "" # Check that tclListObj.c's SetListFromAny handles possible overlarge # string rep lengths in the source object. -proc slowsort list { - set result {} - set last [expr [llength $list] - 1] +proc slowsort {list} { + set result "" + set last [expr {[llength $list] - 1}] while {$last > 0} { - set minIndex [expr [llength $list] - 1] + set minIndex [expr {[llength $list] - 1}] set min [lindex $list $last] - set i [expr $minIndex-1] + set i [expr {$minIndex - 1}] while {$i >= 0} { if {[string compare [lindex $list $i] $min] < 0} { set minIndex $i set min [lindex $list $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } set result [concat $result [list $min]] if {$minIndex == 0} { set list [lrange $list 1 end] } else { - set list [concat [lrange $list 0 [expr $minIndex-1]] \ - [lrange $list [expr $minIndex+1] end]] + set list [concat [lrange $list 0 [expr {$minIndex - 1}]] \ + [lrange $list [expr {$minIndex + 1}] end]] } - set last [expr $last-1] + set last [expr {$last - 1}] } return [concat $result $list] } diff --git a/tests/listObj.test b/tests/listObj.test index 937fb1d..081e88a 100644 --- a/tests/listObj.test +++ b/tests/listObj.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -21,14 +21,14 @@ catch [list package require -exact Tcltest [info patchlevel]] testConstraint testobj [llength [info commands testobj]] -catch {unset x} +unset -nocomplain x test listobj-1.1 {Tcl_GetListObjType} emptyTest { # Test removed; tested an internal detail # that's no longer correct, and duplicated test obj-1.1 } {} test listobj-2.1 {Tcl_SetListObj, use in lappend} { - catch {unset x} + unset -nocomplain x list [lappend x 1 abc def] [lappend x 1 ghi jkl] $x } {{1 abc def} {1 abc def 1 ghi jkl} {1 abc def 1 ghi jkl}} test listobj-2.2 {Tcl_SetListObj, use in ObjInterpProc} { @@ -42,7 +42,7 @@ test listobj-2.3 {Tcl_SetListObj, zero element count} { } {} test listobj-3.1 {Tcl_ListObjAppend, list conversion} { - catch {unset x} + unset -nocomplain x list [lappend x 1 2 abc "long string"] $x } {{1 2 abc {long string}} {1 2 abc {long string}}} test listobj-3.2 {Tcl_ListObjAppend, list conversion} { @@ -64,7 +64,7 @@ test listobj-3.5 {Tcl_ListObjAppend, force internal rep array to grow} { } {{1 1} {1 1 2 2} {1 1 2 2 3 3} {1 1 2 2 3 3 4 4} {1 1 2 2 3 3 4 4 5 5} {1 1 2 2 3 3 4 4 5 5 6 6} {1 1 2 2 3 3 4 4 5 5 6 6 7 7} {1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8} {1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8}} test listobj-4.1 {Tcl_ListObjAppendElement, list conversion} { - catch {unset x} + unset -nocomplain x list [lappend x 1] $x } {1 1} test listobj-4.2 {Tcl_ListObjAppendElement, list conversion} { diff --git a/tests/llength.test b/tests/llength.test index 169c7ca..469cd5f 100644 --- a/tests/llength.test +++ b/tests/llength.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } diff --git a/tests/lmap.test b/tests/lmap.test index 7baa77b..dd8ddf1 100644 --- a/tests/lmap.test +++ b/tests/lmap.test @@ -142,7 +142,7 @@ unset -nocomplain a # "lmap" with "continue" and "break" (non-compiled) test lmap-3.1 {continue tests} { lmap i {a b c d} { - if {[string compare $i "b"] == 0} continue + if {$i eq "b"} continue set i } } {a c d} @@ -150,7 +150,7 @@ test lmap-3.2 {continue tests} { set x 0 list [lmap i {a b c d} { incr x - if {[string compare $i "b"] != 0} continue + if {$i ne "b"} continue set i }] $x } {b 4} @@ -158,7 +158,7 @@ test lmap-3.3 {break tests} { set x 0 list [lmap i {a b c d} { incr x - if {[string compare $i "c"] == 0} break + if {$i eq "c"} break set i }] $x } {{a b} 3} @@ -308,7 +308,7 @@ test lmap-5.10 {lmap only supports local scalar variables} { test lmap-6.1 {continue tests} { apply {{} { lmap i {a b c d} { - if {[string compare $i "b"] == 0} continue + if {$i eq "b"} continue set i } }} @@ -317,7 +317,7 @@ test lmap-6.2 {continue tests} { apply {{} { list [lmap i {a b c d} { incr x - if {[string compare $i "b"] != 0} continue + if {$i ne "b"} continue set i }] $x }} @@ -326,7 +326,7 @@ test lmap-6.3 {break tests} { apply {{} { list [lmap i {a b c d} { incr x - if {[string compare $i "c"] == 0} break + if {$i eq "c"} break set i }] $x }} diff --git a/tests/load.test b/tests/load.test index cded85d..c74b7c2 100644 --- a/tests/load.test +++ b/tests/load.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } diff --git a/tests/lrange.test b/tests/lrange.test index 17a757e..24d91db 100644 --- a/tests/lrange.test +++ b/tests/lrange.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } diff --git a/tests/lrepeat.test b/tests/lrepeat.test index 788bb9b..2e027dd 100644 --- a/tests/lrepeat.test +++ b/tests/lrepeat.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } diff --git a/tests/lreplace.test b/tests/lreplace.test index 5f675bc..ffcd837 100644 --- a/tests/lreplace.test +++ b/tests/lreplace.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -92,14 +92,13 @@ test lreplace-1.25 {lreplace command} { concat \"[lreplace {\}\ hello} end end]\" } {"\}\ "} test lreplace-1.26 {lreplace command} { - catch {unset foo} + unset -nocomplain foo set foo {a b} list [set foo [lreplace $foo end end]] \ [set foo [lreplace $foo end end]] \ [set foo [lreplace $foo end end]] } {a {} {}} - test lreplace-2.1 {lreplace errors} { list [catch lreplace msg] $msg } {1 {wrong # args: should be "lreplace list first last ?element ...?"}} @@ -131,6 +130,6 @@ test lreplace-3.1 {lreplace won't modify shared argument objects} { } "a b c" # cleanup -catch {unset foo} +unset -nocomplain foo ::tcltest::cleanupTests return diff --git a/tests/lsearch.test b/tests/lsearch.test index f36e987..e9d1cd4 100644 --- a/tests/lsearch.test +++ b/tests/lsearch.test @@ -112,11 +112,11 @@ test lsearch-4.2 {binary data} { } 1 # Make a sorted list -set l {} -set l2 {} +set l [list] +set l2 [list] for {set i 0} {$i < 100} {incr i} { lappend l $i - lappend l2 [expr {double($i)/2}] + lappend l2 [expr {($i * 1.0) / 2}] } set increasingIntegers [lsort -integer $l] set decreasingIntegers [lsort -decreasing -integer $l] @@ -127,7 +127,7 @@ set decreasingStrings [lsort -decreasing {48 6a 18b 22a 21aa 35 36}] set increasingDictionary [lsort -dictionary {48 6a 18b 22a 21aa 35 36}] set decreasingDictionary [lsort -dictionary -decreasing $increasingDictionary] -set l {} +set l [list] for {set i 0} {$i < 10} {incr i} { lappend l $i $i $i $i $i } @@ -135,14 +135,14 @@ set repeatingIncreasingIntegers [lsort -integer $l] set repeatingDecreasingIntegers [lsort -integer -decreasing $l] test lsearch-5.1 {binary search} { - set res {} + set res [list] for {set i 0} {$i < 100} {incr i} { lappend res [lsearch -integer -sorted $increasingIntegers $i] } set res } $increasingIntegers test lsearch-5.2 {binary search} { - set res {} + set res [list] for {set i 0} {$i < 100} {incr i} { lappend res [lsearch -integer -decreasing -sorted \ $decreasingIntegers $i] @@ -150,14 +150,14 @@ test lsearch-5.2 {binary search} { set res } $decreasingIntegers test lsearch-5.3 {binary search finds leftmost occurances} { - set res {} + set res [list] for {set i 0} {$i < 10} {incr i} { lappend res [lsearch -integer -sorted $repeatingIncreasingIntegers $i] } set res } [list 0 5 10 15 20 25 30 35 40 45] test lsearch-5.4 {binary search -decreasing finds leftmost occurances} { - set res {} + set res [list] for {set i 9} {$i >= 0} {incr i -1} { lappend res [lsearch -sorted -integer -decreasing \ $repeatingDecreasingIntegers $i] @@ -166,14 +166,14 @@ test lsearch-5.4 {binary search -decreasing finds leftmost occurances} { } [list 0 5 10 15 20 25 30 35 40 45] test lsearch-6.1 {integer search} { - set res {} + set res [list] for {set i 0} {$i < 100} {incr i} { lappend res [lsearch -exact -integer $increasingIntegers $i] } set res } [lrange $increasingIntegers 0 99] test lsearch-6.2 {decreasing integer search} { - set res {} + set res [list] for {set i 0} {$i < 100} {incr i} { lappend res [lsearch -exact -integer -decreasing \ $decreasingIntegers $i] @@ -181,14 +181,14 @@ test lsearch-6.2 {decreasing integer search} { set res } [lrange $decreasingIntegers 0 99] test lsearch-6.3 {sorted integer search} { - set res {} + set res [list] for {set i 0} {$i < 100} {incr i} { lappend res [lsearch -sorted -integer $increasingIntegers $i] } set res } [lrange $increasingIntegers 0 99] test lsearch-6.4 {sorted decreasing integer search} { - set res {} + set res [list] for {set i 0} {$i < 100} {incr i} { lappend res [lsearch -integer -sorted -decreasing \ $decreasingIntegers $i] @@ -197,7 +197,7 @@ test lsearch-6.4 {sorted decreasing integer search} { } [lrange $decreasingIntegers 0 99] test lsearch-7.1 {double search} { - set res {} + set res [list] for {set i 0} {$i < 100} {incr i} { lappend res [lsearch -exact -real $increasingDoubles \ [expr {double($i)/2}]] @@ -205,7 +205,7 @@ test lsearch-7.1 {double search} { set res } [lrange $increasingIntegers 0 99] test lsearch-7.2 {decreasing double search} { - set res {} + set res [list] for {set i 0} {$i < 100} {incr i} { lappend res [lsearch -exact -real -decreasing \ $decreasingDoubles [expr {double($i)/2}]] @@ -213,7 +213,7 @@ test lsearch-7.2 {decreasing double search} { set res } [lrange $decreasingIntegers 0 99] test lsearch-7.3 {sorted double search} { - set res {} + set res [list] for {set i 0} {$i < 100} {incr i} { lappend res [lsearch -sorted -real \ $increasingDoubles [expr {double($i)/2}]] @@ -221,7 +221,7 @@ test lsearch-7.3 {sorted double search} { set res } [lrange $increasingIntegers 0 99] test lsearch-7.4 {sorted decreasing double search} { - set res {} + set res [list] for {set i 0} {$i < 100} {incr i} { lappend res [lsearch -sorted -real -decreasing \ $decreasingDoubles [expr {double($i)/2}]] @@ -230,28 +230,28 @@ test lsearch-7.4 {sorted decreasing double search} { } [lrange $decreasingIntegers 0 99] test lsearch-8.1 {dictionary search} { - set res {} + set res [list] foreach val {6a 18b 21aa 22a 35 36 48} { lappend res [lsearch -exact -dictionary $increasingDictionary $val] } set res } [list 0 1 2 3 4 5 6] test lsearch-8.2 {decreasing dictionary search} { - set res {} + set res [list] foreach val {6a 18b 21aa 22a 35 36 48} { lappend res [lsearch -exact -dictionary $decreasingDictionary $val] } set res } [list 6 5 4 3 2 1 0] test lsearch-8.3 {sorted dictionary search} { - set res {} + set res [list] foreach val {6a 18b 21aa 22a 35 36 48} { lappend res [lsearch -sorted -dictionary $increasingDictionary $val] } set res } [list 0 1 2 3 4 5 6] test lsearch-8.4 {decreasing sorted dictionary search} { - set res {} + set res [list] foreach val {6a 18b 21aa 22a 35 36 48} { lappend res [lsearch -decreasing -sorted -dictionary \ $decreasingDictionary $val] @@ -260,28 +260,28 @@ test lsearch-8.4 {decreasing sorted dictionary search} { } [list 6 5 4 3 2 1 0] test lsearch-9.1 {ascii search} { - set res {} + set res [list] foreach val {18b 21aa 22a 35 36 48 6a} { lappend res [lsearch -exact -ascii $increasingStrings $val] } set res } [list 0 1 2 3 4 5 6] test lsearch-9.2 {decreasing ascii search} { - set res {} + set res [list] foreach val {18b 21aa 22a 35 36 48 6a} { lappend res [lsearch -exact -ascii $decreasingStrings $val] } set res } [list 6 5 4 3 2 1 0] test lsearch-9.3 {sorted ascii search} { - set res {} + set res [list] foreach val {18b 21aa 22a 35 36 48 6a} { lappend res [lsearch -sorted -ascii $increasingStrings $val] } set res } [list 0 1 2 3 4 5 6] test lsearch-9.4 {decreasing sorted ascii search} { - set res {} + set res [list] foreach val {18b 21aa 22a 35 36 48 6a} { lappend res [lsearch -decreasing -sorted -ascii \ $decreasingStrings $val] @@ -305,7 +305,7 @@ test lsearch-10.5 {offset searching} -returnCodes error -body { lsearch -start 1 2 } -result {missing starting index} test lsearch-10.6 {binary search with offset} { - set res {} + set res [list] for {set i 0} {$i < 100} {incr i} { lappend res [lsearch -integer -start 2 -sorted $increasingIntegers $i] } @@ -471,7 +471,7 @@ test lsearch-21.2 {lsearch shimmering crash} { } 0 test lsearch-22.1 {lsearch -bisect} -setup { - set res {} + set res [list] } -body { foreach i {0 1 5 6 7 8 15 16} { lappend res [lsearch -bisect -integer {1 4 5 7 9 15} $i] @@ -479,7 +479,7 @@ test lsearch-22.1 {lsearch -bisect} -setup { return $res } -result {-1 0 2 2 3 3 5 5} test lsearch-22.2 {lsearch -bisect, last of equals} -setup { - set res {} + set res [list] } -body { foreach i {0 1 2 3} { lappend res [lsearch -bisect -integer {0 0 1 1 1 2 2 2 3 3 3} $i] @@ -487,7 +487,7 @@ test lsearch-22.2 {lsearch -bisect, last of equals} -setup { return $res } -result {1 4 7 10} test lsearch-22.3 {lsearch -bisect decreasing order} -setup { - set res {} + set res [list] } -body { foreach i {0 1 5 6 7 8 15 16} { lappend res [lsearch -bisect -integer -decreasing {15 9 7 5 4 1} $i] @@ -495,7 +495,7 @@ test lsearch-22.3 {lsearch -bisect decreasing order} -setup { return $res } -result {5 5 3 2 2 1 0 -1} test lsearch-22.4 {lsearch -bisect, last of equals, decreasing} -setup { - set res {} + set res [list] } -body { foreach i {0 1 2 3} { lappend res [lsearch -bisect -integer -decreasing \ @@ -511,15 +511,7 @@ test lsearch-22.6 {lsearch -sorted, all equal} { } {0} # cleanup -catch {unset res} -catch {unset increasingIntegers} -catch {unset decreasingIntegers} -catch {unset increasingDoubles} -catch {unset decreasingDoubles} -catch {unset increasingStrings} -catch {unset decreasingStrings} -catch {unset increasingDictionary} -catch {unset decreasingDictionary} +unset -nocomplain res increasingIntegers decreasingIntegers increasingDoubles decreasingDoubles increasingStrings decreasingStrings increasingDictionary decreasingDictionary ::tcltest::cleanupTests return diff --git a/tests/lset.test b/tests/lset.test index 1c1300b..8624ab5 100644 --- a/tests/lset.test +++ b/tests/lset.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -470,11 +470,9 @@ test lset-16.8 {lset - append to inner list} testevalex { testevalex {lset x end end end+1 4} } {test {1 2 {3 4}}} -catch {unset noRead} -catch {unset noWrite} -catch {rename failTrace {}} -catch {unset ::x} -catch {unset ::y} +unset -nocomplain noRead noWrite +catch {rename failTrace ""} +unset -nocomplain ::x ::y # cleanup ::tcltest::cleanupTests diff --git a/tests/lsetComp.test b/tests/lsetComp.test index 6846cbf..6bc1721 100755 --- a/tests/lsetComp.test +++ b/tests/lsetComp.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -423,8 +423,7 @@ test lsetComp-3.9 {lset, compiled, flat args, error - is string preserved} { } "{ { 1 2 } { 3 4 } } { 3 4 }" catch { rename evalInProc {} } -catch { unset ::x } -catch { unset ::y } +unset -nocomplain ::x ::y # cleanup ::tcltest::cleanupTests diff --git a/tests/macOSXFCmd.test b/tests/macOSXFCmd.test index 071f11b..4c06b59 100644 --- a/tests/macOSXFCmd.test +++ b/tests/macOSXFCmd.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -21,9 +21,9 @@ cd [temporaryDirectory] # check whether macosx file attributes are supported testConstraint macosxFileAttr 0 -if {[testConstraint unix] && $tcl_platform(os) eq "Darwin"} { +if {[testConstraint unix] && ($tcl_platform(os) eq "Darwin")} { catch {file delete -force -- foo.test} - close [open foo.test w] + chan close [open foo.test w] catch { file attributes foo.test -creator testConstraint macosxFileAttr 1 @@ -104,7 +104,7 @@ test macOSXFCmd-2.7 {MacOSXSetFileAttribute - rsrclength} {macosxFileAttr notRoo close [open foo.test w] catch { set f [open foo.test/..namedfork/rsrc w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} puts -nonewline $f "foo" close $f } @@ -121,7 +121,7 @@ test macOSXFCmd-3.1 {MacOSXCopyFileAttributes} {macosxFileAttr notRoot} { catch { file attributes foo.test -creator FOOC -type FOOT -hidden 1 set f [open foo.test/..namedfork/rsrc w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} puts -nonewline $f "foo" close $f file copy foo.test bar.test diff --git a/tests/macOSXLoad.test b/tests/macOSXLoad.test index 12c77e0..ad699b2 100644 --- a/tests/macOSXLoad.test +++ b/tests/macOSXLoad.test @@ -10,15 +10,16 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } set oldTSF $::tcltest::testSingleFile set ::tcltest::testSingleFile false -if {[testConstraint unix] && $tcl_platform(os) eq "Darwin" && - ![string match *pkga* [info loaded]]} { +if {[testConstraint unix] && + ($tcl_platform(os) eq "Darwin") && + (![string match "*pkga*" [info loaded]])} { # On Darwin, test .bundle (un)loading in addition to .dylib set ext .bundle source [file join [file dirname [info script]] load.test] diff --git a/tests/mathop.test b/tests/mathop.test index f122b7b..a29eb1c 100644 --- a/tests/mathop.test +++ b/tests/mathop.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.1 namespace import -force ::tcltest::* } @@ -27,11 +27,12 @@ namespace eval ::testmathop2 { # Shared / unshared arguments # Original / imported proc TestOp {op args} { - set results {} + global errorCode + set results [list] # Non byte compiled version, shared args if {[catch {::tcl::mathop::$op {*}$args} res]} { - append res " $::errorCode" + append res " $errorCode" } lappend results $res @@ -41,20 +42,20 @@ proc TestOp {op args} { append cmd " \[format %s [list $arg]\]" } if {[catch $cmd res]} { - append res " $::errorCode" + append res " $errorCode" } lappend results $res # Non byte compiled imported if {[catch {::testmathop2::$op {*}$args} res]} { - append res " $::errorCode" + append res " $errorCode" } lappend results [string map {testmathop2 tcl::mathop} $res] # BC version - set argList1 {} - set argList2 {} - set argList3 {} + set argList1 [list] + set argList2 [list] + set argList3 [list] for {set t 0} {$t < [llength $args]} {incr t} { lappend argList1 a$t lappend argList2 \$a$t @@ -69,18 +70,18 @@ proc TestOp {op args} { set ::tcl_traceCompile 0 ;# Set to 2 to help with debug if {[catch {_TestOp {*}$args} res]} { - append res " $::errorCode" + append res " $errorCode" } set ::tcl_traceCompile 0 lappend results $res if {[catch {_TestOp2 {*}$args} res]} { - append res " $::errorCode" + append res " $errorCode" } lappend results $res if {[catch {_TestOp3 {*}$args} res]} { - append res " $::errorCode" + append res " $errorCode" } lappend results [string map {testmathop2 tcl::mathop} $res] @@ -719,14 +720,14 @@ namespace eval ::testmathop { } test mathop-20.1 { zero args, return unit } { - set res {} + set res [list] foreach op {+ * & ^ | ** < <= > >= == eq} { lappend res [TestOp $op] } set res } {0 1 -1 0 0 1 1 1 1 1 1 1} test mathop-20.2 { zero args, not allowed } { - set exp {} + set exp [list] foreach op {~ ! << >> % != ne in ni - /} { set res [TestOp $op] if {[string match "wrong # args: should be * TCL WRONGARGS" $res]} { @@ -738,17 +739,17 @@ test mathop-20.2 { zero args, not allowed } { set exp } {0 0 0 0 0 0 0 0 0 0 0} test mathop-20.3 { one arg } { - set res {} + set res [list] foreach val {7 8.3} { foreach op {+ ** - * / < <= > >= == eq !} { lappend res [TestOp $op $val] } } set res -} [list 7 7 -7 7 [expr {1.0/7.0}] 1 1 1 1 1 1 0 \ - 8.3 8.3 -8.3 8.3 [expr {1.0/8.3}] 1 1 1 1 1 1 0] +} [list 7 7 -7 7 [expr {1.0 / 7.0}] 1 1 1 1 1 1 0 \ + 8.3 8.3 -8.3 8.3 [expr {1.0 / 8.3}] 1 1 1 1 1 1 0] test mathop-20.4 { one arg, integer only ops } { - set res {} + set res [list] foreach val {23} { foreach op {& | ^ ~} { lappend res [TestOp $op $val] @@ -757,7 +758,7 @@ test mathop-20.4 { one arg, integer only ops } { set res } [list 23 23 23 -24] test mathop-20.5 { one arg, not allowed } { - set exp {} + set exp [list] foreach op {% != ne in ni << >>} { set res [TestOp $op 1] if {[string match "wrong # args: should be * TCL WRONGARGS" $res]} { @@ -769,8 +770,8 @@ test mathop-20.5 { one arg, not allowed } { set exp } {0 0 0 0 0 0 0} test mathop-20.6 { one arg, error } { - set res {} - set exp {} + set res [list] + set exp [list] foreach vals {x {1 x} {1 1 x} {1 x 1}} { # skipping - for now, knownbug... foreach op {+ * / & | ^ **} { @@ -787,7 +788,7 @@ test mathop-20.6 { one arg, error } { expr {$res eq $exp ? 0 : $res} } 0 test mathop-20.7 { multi arg } { - set res {} + set res [list] foreach vals {{1 2} {3 4 5} {4 3 2 1}} { foreach op {+ - * /} { lappend res [TestOp $op {*}$vals] @@ -796,7 +797,7 @@ test mathop-20.7 { multi arg } { set res } [list 3 -1 2 0 12 -6 60 0 10 -2 24 0] test mathop-20.8 { multi arg, double } { - set res {} + set res [list] foreach vals {{1.0 2} {3.0 4 5} {4 3.0 2 1} {1.0 -1.0 1e-18} {1.0 1.0 1e-18}} { foreach op {+ - * /} { @@ -804,10 +805,10 @@ test mathop-20.8 { multi arg, double } { } } set res -} [list 3.0 -1.0 2.0 0.5 12.0 -6.0 60.0 0.15 10.0 -2.0 24.0 [expr {2.0/3}] 1e-18 2.0 -1e-18 [expr {-1.0/1e-18}] 2.0 -1e-18 1e-18 [expr {1.0/1e-18}]] +} [list 3.0 -1.0 2.0 0.5 12.0 -6.0 60.0 0.15 10.0 -2.0 24.0 [expr {2.0 / 3}] 1e-18 2.0 -1e-18 [expr {-1.0 / 1e-18}] 2.0 -1e-18 1e-18 [expr {1.0 / 1e-18}]] test mathop-21.1 { unary ops, bitnot } { - set res {} + set res [list] lappend res [TestOp ~ 7] lappend res [TestOp ~ -5] lappend res [TestOp ~ 354657483923456] @@ -815,7 +816,7 @@ test mathop-21.1 { unary ops, bitnot } { set res } [list -8 4 -354657483923457 -123456789123456789123456790] test mathop-21.2 { unary ops, logical not } { - set res {} + set res [list] lappend res [TestOp ! 0] lappend res [TestOp ! 1] lappend res [TestOp ! true] @@ -825,7 +826,7 @@ test mathop-21.2 { unary ops, logical not } { set res } [list 1 0 0 1 0 0] test mathop-21.3 { unary ops, negation } { - set res {} + set res [list] lappend res [TestOp - 7.2] lappend res [TestOp - -5] lappend res [TestOp - -2147483648] ;# -2**31 @@ -836,7 +837,7 @@ test mathop-21.3 { unary ops, negation } { } [list -7.2 5 2147483648 9223372036854775808 -354657483923456 \ -123456789123456789123456789] test mathop-21.4 { unary ops, inversion } { - set res {} + set res [list] lappend res [TestOp / 1] lappend res [TestOp / 5] lappend res [TestOp / 5.6] @@ -847,8 +848,8 @@ test mathop-21.4 { unary ops, inversion } { } [list 1.0 0.2 0.17857142857142858 -0.125 \ 2.8196218755553604e-15 8.10000006561e-27] test mathop-21.5 { unary ops, bad values } { - set res {} - set exp {} + set res [list] + set exp [list] lappend res [TestOp / x] lappend exp "can't use non-numeric string as operand of \"/\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp - x] @@ -862,7 +863,7 @@ test mathop-21.5 { unary ops, bad values } { expr {$res eq $exp ? 0 : $res} } 0 test mathop-21.6 { unary ops, too many } { - set exp {} + set exp [list] foreach op {~ !} { set res [TestOp $op 7 8] if {[string match "wrong # args: should be * TCL WRONGARGS" $res]} { @@ -875,7 +876,7 @@ test mathop-21.6 { unary ops, too many } { } {0 0} test mathop-22.1 { bitwise ops } { - set res {} + set res [list] foreach vals {5 {1 6} {1 2 3} {1 2 3 4}} { foreach op {& | ^} { lappend res [TestOp $op {*}$vals] @@ -891,14 +892,14 @@ test mathop-22.2 { bitwise ops on bignums } { set bn [expr {~$b}] set cn [expr {~$c}] - set res {} + set res [list] foreach vals [list [list $a $b] [list $a $c] [list $b $c] \ [list $a $bn] [list $bn $c] [list $bn $cn]] { foreach op {& | ^} { lappend res [TestOp $op {*}$vals] } } - set exp {} + set exp [list] foreach d {5 7 2 1 D C 1 F E 0 -D -D 8 -9 -1 -0 -E E} { if {[string match "-*" $d]} { set d [format %X [expr 15-0x[string range $d 1 end]]] @@ -918,7 +919,7 @@ test mathop-22.3 { bitwise ops } { set small1 87345 set small2 16753 - set res {} + set res [list] foreach op {& | ^} { lappend res [TestOp $op $big1 $big2] lappend res [TestOp $op $big1 $wide2] @@ -961,8 +962,8 @@ test mathop-22.3 { bitwise ops } { 70720 \ ] test mathop-22.4 { unary ops, bad values } { - set res {} - set exp {} + set res [list] + set exp [list] foreach op {& | ^} { lappend res [TestOp $op x 5] lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}" @@ -973,7 +974,7 @@ test mathop-22.4 { unary ops, bad values } { } 0 test mathop-23.1 { comparison ops, numerical } { - set res {} + set res [list] set todo {5 {1 6} {1 2 2 3} {4 3 2 1} {5.0 5.0} {6 3 3 1} {5.0 5}} lappend todo [list 2342476234762482734623842342 234827463876473 3434] lappend todo [list 2653 453735910264536 453735910264537 2384762472634982746239847637] @@ -1006,7 +1007,7 @@ test mathop-23.1 { comparison ops, numerical } { 0 1 0 1 1 1 \ ] test mathop-23.2 { comparison ops, string } { - set res {} + set res [list] set todo {a {a b} {5 b b c} {d c b a} {xy xy} {gy ef ef ab}} set a x lappend todo [list $a $a] @@ -1025,7 +1026,7 @@ test mathop-23.2 { comparison ops, string } { 0 1 0 1 1 1 \ ] test mathop-23.3 { comparison ops, nonequal} { - set res {} + set res [list] foreach vals {{a b} {17.0 0x11} {foo foo} {10 10}} { foreach op {!= ne} { lappend res [TestOp $op {*}$vals] @@ -1035,7 +1036,7 @@ test mathop-23.3 { comparison ops, nonequal} { } [list 1 1 0 1 0 0 0 0 ] test mathop-24.1 { binary ops } { - set res {} + set res [list] foreach vals {{3 5} {17 7} {199 5} {293234675763434238476239486 17} \ {5 1} {0 7}} { foreach op {% << >> in ni} { @@ -1048,7 +1049,7 @@ test mathop-24.1 { binary ops } { 0 10 2 0 1 0 0 0 0 1] test mathop-24.2 { binary ops, modulo } { # Test different combinations to get all code paths - set res {} + set res [list] set bigbig 14372423674564535234543545248972634923869 set big 12135435435354435435342423948763867876 @@ -1076,8 +1077,8 @@ test mathop-24.2 { binary ops, modulo } { 0 \ ] test mathop-24.3 { binary ops, bad values } { - set res {} - set exp {} + set res [list] + set exp [list] foreach op {% << >>} { lappend res [TestOp $op x 1] lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}" @@ -1105,7 +1106,7 @@ test mathop-24.3 { binary ops, bad values } { expr {$res eq $exp ? 0 : $res} } 0 test mathop-24.4 { binary ops, negative shift } { - set res {} + set res [list] set big -12135435435354435435342423948763867876 set wide -12345678912345 @@ -1122,8 +1123,8 @@ test mathop-24.4 { binary ops, negative shift } { expr {$res eq $exp ? 0 : $res} } 0 test mathop-24.5 { binary ops, large shift } { - set res {} - set exp {} + set res [list] + set exp [list] set big 12135435435354435435342423948763867876 set wide 12345678912345 @@ -1160,7 +1161,7 @@ test mathop-24.5 { binary ops, large shift } { } 0 test mathop-24.6 { binary ops, shift } { # Test different combinations to get all code paths - set res {} + set res [list] set bigbig 14372423674564535234543545248972634923869 set big 12135435435354435435342423948763867876 @@ -1176,7 +1177,7 @@ test mathop-24.6 { binary ops, shift } { 385802466010 \ ] test mathop-24.7 { binary ops, list search } { - set res {} + set res [list] foreach op {in ni} { lappend res [TestOp $op 5 {7 5 8}] @@ -1186,7 +1187,7 @@ test mathop-24.7 { binary ops, list search } { set res } [list 1 1 0 0 0 1] test mathop-24.8 { binary ops, too many } { - set exp {} + set exp [list] foreach op {<< >> % != ne in ni ~ !} { set res [TestOp $op 7 8 9] if {[string match "wrong # args: should be * TCL WRONGARGS" $res]} { @@ -1221,8 +1222,8 @@ test mathop-25.20 { exp operator } {TestOp ** -1 4} 1 test mathop-25.21 { exp operator } {TestOp ** 2 63} 9223372036854775808 test mathop-25.22 { exp operator } {TestOp ** 83756485763458746358734658473567847567473 2} 7015148907444467657897585474493757781161998914521537835809623408157343003287605729 test mathop-25.23 { exp operator errors } { - set res {} - set exp {} + set res [list] + set exp [list] set huge [string repeat 145782 1000] set big 12135435435354435435342423948763867876 @@ -1255,7 +1256,7 @@ test mathop-26.1 { misc ops, size combinations } { set small1 87345 set small2 16753 - set res {} + set res [list] foreach op {+ * - /} { lappend res [TestOp $op $big1 $big2] lappend res [TestOp $op $big1 $wide2] @@ -1307,7 +1308,7 @@ test mathop-26.1 { misc ops, size combinations } { 5 \ ] test mathop-26.2 { misc ops, corner cases } { - set res {} + set res [list] lappend res [TestOp - 0 -2147483648] ;# -2**31 lappend res [TestOp - 0 -9223372036854775808] ;# -2**63 lappend res [TestOp / -9223372036854775808 -1] @@ -1316,7 +1317,7 @@ test mathop-26.2 { misc ops, corner cases } { set res } [list 2147483648 9223372036854775808 9223372036854775808 4294967296 18446744073709551616] -if 0 { +if {0} { # Compare ops to expr bytecodes namespace import ::tcl::mathop::* proc _X {a b c} { diff --git a/tests/misc.test b/tests/misc.test index 6ddc718..ca299e1 100644 --- a/tests/misc.test +++ b/tests/misc.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -69,7 +69,7 @@ missing close-brace for variable name invoked from within "tstProc"}] -for {set i 1} {$i<300} {incr i} { +for {set i 1} {$i < 300} {incr i} { test misc-2.$i {hash table with sys-alloc} testhashsystemhash \ "testhashsystemhash $i" OK } diff --git a/tests/namespace-old.test b/tests/namespace-old.test index 1d8ba31..2e262e9 100644 --- a/tests/namespace-old.test +++ b/tests/namespace-old.test @@ -606,11 +606,11 @@ test namespace-old-9.5 {empty import list in "namespace import" command} { test namespace-old-9.7 {empty forget list for "namespace forget" command} { namespace forget } {} -catch {rename cmd1 {}} -catch {rename cmd2 {}} -catch {rename ncmd {}} -catch {rename ncmd1 {}} -catch {rename ncmd2 {}} +catch {rename cmd1 ""} +catch {rename cmd2 ""} +catch {rename ncmd ""} +catch {rename ncmd1 ""} +catch {rename ncmd2 ""} test namespace-old-9.8 {only exported commands are imported} { namespace import test_ns_import::cmd* set x [lsort [info commands cmd*]] @@ -725,20 +725,13 @@ test namespace-old-10.8 {scoped commands execute in namespace context} { foreach cmd [info commands test_ns_*] { rename $cmd "" } -catch {rename cmd {}} -catch {rename cmd1 {}} -catch {rename cmd2 {}} -catch {rename ncmd {}} -catch {rename ncmd1 {}} -catch {rename ncmd2 {}} -catch {unset cref} -catch {unset trigger} -catch {unset trigger2} -catch {unset sval} -catch {unset msg} -catch {unset x} -catch {unset test_ns_var_global} -catch {unset cmd} +catch {rename cmd ""} +catch {rename cmd1 ""} +catch {rename cmd2 ""} +catch {rename ncmd ""} +catch {rename ncmd1 ""} +catch {rename ncmd2 ""} +unset -nocomplain cref trigger trigger2 sval msg x test_ns_var_global cmd eval namespace delete [namespace children :: test_ns_*] # cleanup diff --git a/tests/namespace.test b/tests/namespace.test index 1d46bf0..d51a179 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -37,7 +37,7 @@ test namespace-1.1 {TclInitNamespaces, GetNamespaceFromObj, NamespaceChildrenCmd namespace children :: test_ns_* } {} -catch {unset l} +unset -nocomplain l test namespace-2.1 {Tcl_GetCurrentNamespace} { list [namespace current] [namespace eval {} {namespace current}] \ [namespace eval {} {namespace current}] @@ -192,8 +192,7 @@ test namespace-7.7 {Bug 1655305} -setup { slave invokehidden infocommands } -cleanup { interp delete slave -} -result {} - +} -result "" test namespace-8.1 {TclTeardownNamespace, delete global namespace} { catch {interp delete test_interp} @@ -623,7 +622,7 @@ test namespace-14.9 {TclGetNamespaceForQualName, extra ::s are significant for v lappend l [set test_ns_1::test_ns_2::] } {1 {can't read "test_ns_1::test_ns_2::": no such variable} 2525} test namespace-14.10 {TclGetNamespaceForQualName, extra ::s are significant for vars} { - catch {unset test_ns_1::test_ns_2::} + unset -nocomplain test_ns_1::test_ns_2:: set l {} lappend l [catch {set test_ns_1::test_ns_2::} msg] $msg set test_ns_1::test_ns_2:: 314159 @@ -747,7 +746,7 @@ test namespace-16.11 {Tcl_FindCommand, relative name not found} { } } {1 {invalid command name "cmd3"}} -catch {unset x} +unset -nocomplain x test namespace-17.1 {Tcl_FindNamespaceVar, absolute name found} { catch {namespace delete {*}[namespace children :: test_ns_*]} set x 314159 @@ -813,18 +812,15 @@ test namespace-17.10 {Tcl_FindNamespaceVar, interference with cached varNames} { set ::test_ns_1::a 0 } test_ns - rename test_ns {} + rename test_ns "" namespace eval test_ns_1 unset a set a 0 namespace eval test_ns_1 set a 1 namespace delete test_ns_1 return $a } 1 -catch {unset a} -catch {unset x} - -catch {unset l} -catch {rename foo {}} +unset -nocomplain a x l +catch {rename foo ""} test namespace-18.1 {TclResetShadowedCmdRefs, one-level check for command shadowing} { catch {namespace delete {*}[namespace children :: test_ns_*]} proc foo {} {return "global foo"} @@ -861,8 +857,8 @@ test namespace-18.2 {TclResetShadowedCmdRefs, multilevel check for command shado } lappend l [test_ns_1::trigger] } {{foo in ::test_ns_2} {foo in ::test_ns_1::test_ns_2}} -catch {unset l} -catch {rename foo {}} +unset -nocomplain l +catch {rename foo ""} test namespace-19.1 {GetNamespaceFromObj, global name found} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -1017,7 +1013,7 @@ test namespace-25.1 {NamespaceEvalCmd, bad args} { test namespace-25.2 {NamespaceEvalCmd, bad args} -body { namespace test_ns_1 } -returnCodes error -match glob -result {unknown or ambiguous subcommand "test_ns_1": must be *} -catch {unset v} +unset -nocomplain v test namespace-25.3 {NamespaceEvalCmd, new namespace} { set v 123 namespace eval test_ns_1 { @@ -1058,7 +1054,7 @@ test namespace-25.8 {NamespaceEvalCmd, error in eval'd script} { (in namespace eval "::test_ns_1" script line 1) invoked from within "namespace eval test_ns_1 error foo bar baz"}} -catch {unset v} +unset -nocomplain v test namespace-25.9 {NamespaceEvalCmd, 545325} { namespace eval test_ns_1 info level 0 } {namespace eval test_ns_1 info level 0} @@ -1193,7 +1189,6 @@ test namespace-29.6 {NamespaceInscopeCmd, 1400572} { namespace inscope test_ns_1 {info level 0} } {namespace inscope test_ns_1 {info level 0}} - test namespace-30.1 {NamespaceOriginCmd, bad args} { catch {namespace delete {*}[namespace children :: test_ns_*]} list [catch {namespace origin} msg] $msg @@ -1374,16 +1369,14 @@ test namespace-35.2 {FreeNsNameInternalRep, resulting ref count == 0} { [catch {test_ns_1::q} msg] $msg } {::test_ns_1 {} 1 {invalid command name "test_ns_1::q"}} -catch {unset x} -catch {unset y} +unset -nocomplain x y test namespace-36.1 {DupNsNameInternalRep} { catch {namespace delete {*}[namespace children :: test_ns_*]} namespace eval test_ns_1 {} set x "::test_ns_1" list [namespace parent $x] [set y $x] [namespace parent $y] } {:: ::test_ns_1 ::} -catch {unset x} -catch {unset y} +unset -nocomplain x y test namespace-37.1 {SetNsNameFromAny, ns name found} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -2934,10 +2927,8 @@ test namespace-54.1 {leak on namespace deletion} -constraints {memory} \ } -result 0 # cleanup -catch {rename cmd1 {}} -catch {unset l} -catch {unset msg} -catch {unset trigger} +catch {rename cmd1 ""} +unset -nocomplain l msg trigger namespace delete {*}[namespace children :: test_ns_*] ::tcltest::cleanupTests return diff --git a/tests/notify.test b/tests/notify.test index d2b9123..7252b98 100755 --- a/tests/notify.test +++ b/tests/notify.test @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -185,11 +185,10 @@ test notify-2.5 {remove last element} \ } \ -result {one} - test notify-2.6 {remove and replace last element} \ -constraints {testevent} \ -body { - set delivered {} + set delivered "" after 10 set done 1 testevent queue one tail {lappend delivered one; expr 1} testevent queue two tail {lappend delivered two; expr 1} diff --git a/tests/nre.test b/tests/nre.test index b5eb032..85ac8d8 100644 --- a/tests/nre.test +++ b/tests/nre.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -37,7 +37,7 @@ if {[testConstraint testnrelevels]} { set depth [testnrelevels] set res {} foreach t $depth l $last { - lappend res [expr {$t-$l}] + lappend res [expr {$t - $l}] } set last $depth return $res @@ -55,7 +55,7 @@ if {[testConstraint testnrelevels]} { return [list [lrange $x 0 3] $abs] } } - proc makebody txt { + proc makebody {txt} { variable body0 return "$body0; $txt" } @@ -286,10 +286,9 @@ test nre-7.8 {bug #2910748: switch out of stale BC is not nre-aware} -setup { # yield" error list [bar] [bar] [bar] } -cleanup { - rename bar {} - rename foo {} + rename bar "" + rename foo "" } -result {1 2 3} - test nre-8.1 {nre and {*}} -body { # force an expansion that grows the evaluation stack, check that nre # adapts the TEBCdataPtr. This crashes on failure. @@ -300,8 +299,8 @@ test nre-8.1 {nre and {*}} -body { proc outer {} inner lrange [outer] 0 2 } -cleanup { - rename inner {} - rename outer {} + rename inner "" + rename outer "" } -result {1 1 1} test nre-8.2 {nre and {*}, [Bug 2415422]} -body { # force an expansion that grows the evaluation stack, check that nre @@ -315,8 +314,8 @@ test nre-8.2 {nre and {*}, [Bug 2415422]} -body { } crash } -cleanup { - rename nop {} - rename crash {} + rename nop "" + rename crash "" } # diff --git a/tests/obj.test b/tests/obj.test index 71a39b4..59bbb24 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -20,8 +20,8 @@ if {[lsearch [namespace children] ::tcltest] == -1} { catch [list package require -exact Tcltest [info patchlevel]] testConstraint testobj [llength [info commands testobj]] -testConstraint longIs32bit [expr {int(0x80000000) < 0}] -testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}] +testConstraint longIs32bit [expr { ( int (0x80000000) ) < 0}] +testConstraint wideBiggerThanInt [expr { ( wide (0x80000000) ) != ( int (0x80000000) )}] test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj { set r 1 @@ -551,7 +551,6 @@ test obj-30.1 {Ref counting and object deletion, simple types} testobj { lappend result [testobj refcount 2] } {{} 1024 1024 int 4 4 0 int 3 2} - test obj-31.1 {regenerate string rep of "end"} testobj { testobj freeallvars teststringobj set 1 end diff --git a/tests/oo.test b/tests/oo.test index 5d34077..9678425 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -104,10 +104,10 @@ test oo-0.9 {various types of presence of the TclOO package} { } [list TclOO $::oo::version $::oo::version] test oo-1.1 {basic test of OO functionality: no classes} { - set result {} + set result [list] lappend result [oo::object create foo] lappend result [oo::objdefine foo { - method bar args { + method bar {args} { global result lappend result {*}$args return [llength $args] @@ -3330,7 +3330,7 @@ test oo-34.1 {TIP 380: slots - presence} -setup { test oo-34.2 {TIP 380: slots - presence} { lsort [info class instances oo::Slot] } {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} -proc getMethods obj { +proc getMethods {obj} { list [lsort [info object methods $obj -all]] \ [lsort [info object methods $obj -private]] } diff --git a/tests/opt.test b/tests/opt.test index 2732d40..8ee8643 100644 --- a/tests/opt.test +++ b/tests/opt.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -28,7 +28,7 @@ set n $::tcl::OptDescN test opt-1.1 {OptKeyRegister / check that auto allocation is skipping existing keys} { list [::tcl::OptKeyRegister {} $n] [::tcl::OptKeyRegister {} [expr $n+1]] [::tcl::OptKeyRegister {}] -} "$n [expr $n+1] [expr $n+2]" +} "$n [expr {$n + 1}] [expr {$n + 2}]" test opt-2.1 {OptKeyDelete} { list [::tcl::OptKeyRegister {} testkey] \ @@ -131,21 +131,21 @@ test opt-8.10 {List utilities} { set l } {{b c 7 e} f} test opt-8.11 {List utilities} { - catch {unset x} + unset -nocomplain x set l {a {b c 7 e} f} list [::tcl::Lassign $l u v w x] \ $u $v $w [info exists x] } {3 a {b c 7 e} f 0} test opt-9.1 {Misc utilities} { - catch {unset v} + unset -nocomplain v ::tcl::SetMax v 3 ::tcl::SetMax v 7 ::tcl::SetMax v 6 set v } 7 test opt-9.2 {Misc utilities} { - catch {unset v} + unset -nocomplain v ::tcl::SetMin v 3 ::tcl::SetMin v -7 ::tcl::SetMin v 1 diff --git a/tests/package.test b/tests/package.test index da778f1..7f5af26 100644 --- a/tests/package.test +++ b/tests/package.test @@ -1260,12 +1260,12 @@ test package-15.4 {set stable, rejected} { prefer latest stable } {stable latest latest} -rename prefer {} +rename prefer "" set auto_path $oldPath package unknown $oldPkgUnknown -cleanupTests +cleanupTests } # cleanup diff --git a/tests/pid.test b/tests/pid.test index d21dbaa..7e1578f 100644 --- a/tests/pid.test +++ b/tests/pid.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } diff --git a/tests/proc-old.test b/tests/proc-old.test index e45cf5c..4246f91 100644 --- a/tests/proc-old.test +++ b/tests/proc-old.test @@ -14,7 +14,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -22,10 +22,13 @@ if {[lsearch [namespace children] ::tcltest] == -1} { catch {rename t1 ""} catch {rename foo ""} -proc tproc {} {return a; return b} +proc tproc {} { + return a + return b +} test proc-old-1.1 {simple procedure call and return} {tproc} a -proc tproc x { - set x [expr $x+1] +proc tproc {x} { + set x [expr {$x + 1}] return $x } test proc-old-1.2 {simple procedure call and return} {tproc 2} 3 @@ -36,8 +39,14 @@ test proc-old-1.4 {simple procedure call and return} { proc tproc {} {return} tproc } {} -proc tproc1 {a} {incr a; return $a} -proc tproc2 {a b} {incr a; return $a} +proc tproc1 {a} { + incr a + return $a +} +proc tproc2 {a b} { + incr a + return $a +} test proc-old-1.5 {simple procedure call and return (2 procs with same body but different parameters)} { list [tproc1 123] [tproc2 456 789] } {124 457} @@ -80,7 +89,7 @@ test proc-old-2.4 {local and global variables} { set y 189 list [tproc 6] $y } {195 189} -catch {unset _undefined_} +unset -nocomplain _undefined_ test proc-old-2.5 {local and global variables} { proc tproc x { global _undefined_ @@ -97,37 +106,37 @@ test proc-old-2.6 {local and global variables} { proc do {cmd} {eval $cmd} test proc-old-3.1 {local and global arrays} { - catch {unset a} + unset -nocomplain a set a(0) 22 list [catch {do {global a; set a(0)}} msg] $msg } {0 22} test proc-old-3.2 {local and global arrays} { - catch {unset a} + unset -nocomplain a set a(x) 22 list [catch {do {global a; set a(x) newValue}} msg] $msg $a(x) } {0 newValue newValue} test proc-old-3.3 {local and global arrays} { - catch {unset a} + unset -nocomplain a set a(x) 22 set a(y) 33 list [catch {do {global a; unset a(y)}; array names a} msg] $msg } {0 x} test proc-old-3.4 {local and global arrays} { - catch {unset a} + unset -nocomplain a set a(x) 22 set a(y) 33 list [catch {do {global a; unset a; info exists a}} msg] $msg \ [info exists a] } {0 0 0} test proc-old-3.5 {local and global arrays} { - catch {unset a} + unset -nocomplain a set a(x) 22 set a(y) 33 list [catch {do {global a; unset a(y); array names a}} msg] $msg } {0 x} -catch {unset a} +unset -nocomplain a test proc-old-3.6 {local and global arrays} { - catch {unset a} + unset -nocomplain a set a(x) 22 set a(y) 33 do {global a; do {global a; unset a}; set a(z) 22} @@ -135,7 +144,7 @@ test proc-old-3.6 {local and global arrays} { } {0 z} test proc-old-3.7 {local and global arrays} { proc t1 {args} {global info; set info 1} - catch {unset a} + unset -nocomplain a set info {} do {global a; trace var a(1) w t1} set a(1) 44 @@ -143,7 +152,7 @@ test proc-old-3.7 {local and global arrays} { } 1 test proc-old-3.8 {local and global arrays} { proc t1 {args} {global info; set info 1} - catch {unset a} + unset -nocomplain a trace var a(1) w t1 set info {} do {global a; trace vdelete a(1) w t1} @@ -152,11 +161,11 @@ test proc-old-3.8 {local and global arrays} { } {} test proc-old-3.9 {local and global arrays} { proc t1 {args} {global info; set info 1} - catch {unset a} + unset -nocomplain a trace var a(1) w t1 do {global a; trace vinfo a(1)} } {{w t1}} -catch {unset a} +unset -nocomplain a test proc-old-30.1 {arguments and defaults} { proc tproc {x y z} { @@ -377,13 +386,13 @@ test proc-old-6.1 {procedure that redefines itself} { } 45 test proc-old-6.2 {procedure that deletes itself} { proc tproc {} { - rename tproc {} + rename tproc "" return 45 } tproc } 45 -proc tproc code { +proc tproc {code} { return -code $code abc } test proc-old-7.1 {return with special completion code} { @@ -483,7 +492,7 @@ test proc-old-7.15 {return with special completion code} { test proc-old-8.1 {unset and undefined local arrays} { proc t1 {} { foreach v {xxx, yyy} { - catch {unset $v} + unset -nocomplain $v } set yyy(foo) bar } diff --git a/tests/proc.test b/tests/proc.test index e06720e..4646058 100644 --- a/tests/proc.test +++ b/tests/proc.test @@ -24,7 +24,7 @@ testConstraint memory [llength [info commands memory]] catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} catch {rename {} ""} -catch {unset msg} +unset -nocomplain msg test proc-1.1 {Tcl_ProcObjCmd, put proc in namespace specified in name, if any} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -196,7 +196,7 @@ catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} catch {rename {} ""} catch {rename {a b c} {}} -catch {unset msg} +unset -nocomplain msg catch {rename p ""} catch {rename t ""} diff --git a/tests/pwd.test b/tests/pwd.test index 175c852..d48c2ad 100644 --- a/tests/pwd.test +++ b/tests/pwd.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } diff --git a/tests/reg.test b/tests/reg.test index a0ea850..aa91db5 100644 --- a/tests/reg.test +++ b/tests/reg.test @@ -9,7 +9,7 @@ # # Copyright (c) 1998, 1999 Henry Spencer. All rights reserved. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 } @@ -229,12 +229,12 @@ namespace eval RETest { } lappend names $name append refs " \$$name" - set $name "" + set [set name] "" } - if {[string match *o* $flags]} { ;# REG_NOSUB kludge + if {[string match "*o*" $flags]} { ;# REG_NOSUB kludge set nsub 0 ;# unsigned value cannot be -1 } - if {[string match *t* $flags]} { ;# REG_EXPECT + if {[string match "*t*" $flags]} { ;# REG_EXPECT incr nsub -1 ;# the extra does not count } set erun "list \[[concat $ecmd $names]\] $refs" @@ -340,13 +340,11 @@ namespace import RETest::* list [catch {regexp (*) ign} msg] $msg } {1 {couldn't compile regular expression pattern: quantifier operand invalid}} - doing 1 "basic sanity checks" expectMatch 1.1 & abc abc abc expectNomatch 1.2 & abc def expectMatch 1.3 & abc xyabxabce abc - doing 2 "invalid option combinations" expectError 2.1 qe a INVARG expectError 2.2 qa a INVARG @@ -354,7 +352,6 @@ expectError 2.3 qx a INVARG expectError 2.4 qn a INVARG expectError 2.5 ba a INVARG - doing 3 "basic syntax" expectIndices 3.1 &NS "" a {0 -1} expectMatch 3.2 NS a| a a @@ -363,7 +360,6 @@ expectMatch 3.4 - a|b b b expectMatch 3.5 NS a||b b b expectMatch 3.6 & ab ab ab - doing 4 "parentheses" expectMatch 4.1 - (a)e ae ae a expectMatch 4.2 o (a)e ae @@ -384,7 +380,6 @@ expectMatch 4.14 SP a(?:)b ab ab expectIndices 4.15 S a(|b)c ac {0 1} {1 0} expectMatch 4.16 S a(b|)c abc abc b - doing 5 "simple one-char matching" # general case of brackets done later expectMatch 5.1 & a.b axb axb @@ -396,7 +391,6 @@ expectNomatch 5.6 & {a[^bc]d} abd expectMatch 5.7 & {a[^bc]d} aed aed expectNomatch 5.8 &p "a\[^bc]d" "a\nd" - doing 6 "context-dependent syntax" # plus odds and ends expectError 6.1 - * BADRPT @@ -420,7 +414,6 @@ expectMatch 6.18 n "x\$\n" "x\n" "x\n" expectError 6.19 - + BADRPT expectError 6.20 - ? BADRPT - doing 7 "simple quantifiers" expectMatch 7.1 &N a* aa aa expectIndices 7.2 &N a* b {0 -1} @@ -438,7 +431,6 @@ expectError 7.13 - a?* BADRPT expectError 7.14 - a+* BADRPT expectError 7.15 - a*+ BADRPT - doing 8 "braces" expectMatch 8.1 NQ "a{0,1}" "" "" expectMatch 8.2 NQ "a{0,1}" ac a @@ -468,7 +460,6 @@ expectMatch 8.25 Q "a{2,3}b" aaaab aaab expectNomatch 8.26 Q "a{2,}b" ab expectMatch 8.27 Q "a{2,}b" aaaab aaaab - doing 9 "brackets" expectMatch 9.1 & {a[bc]} ac ac expectMatch 9.2 & {a[-]} a- a- @@ -516,7 +507,6 @@ expectMatch 9.43 & {a[[b]c} "a\[c" "a\[c" expectMatch 9.44 EMP* {a[\u00fe-\u0507][\u00ff-\u0300]b} \ "a\u0102\u02ffb" "a\u0102\u02ffb" - doing 10 "anchors and newlines" expectMatch 10.1 & ^a a a expectNomatch 10.2 &^ ^a a @@ -551,7 +541,6 @@ expectError 10.30 - {$*} BADRPT expectError 10.31 - {\A*} BADRPT expectError 10.32 - {\Z*} BADRPT - doing 11 "boundary constraints" expectMatch 11.1 &LP {[[:<:]]a} a a expectMatch 11.2 &LP {[[:<:]]a} -a a @@ -586,7 +575,6 @@ expectNomatch 11.30 LP {a\M} ab expectNomatch 11.31 ILP {\Ma} a expectNomatch 11.32 ILP {a\m} a - doing 12 "character classes" expectMatch 12.1 LP {a\db} a0b a0b expectNomatch 12.2 LP {a\db} axb @@ -607,7 +595,6 @@ expectMatch 12.16 LPE {a[\d]b} a1b a1b expectMatch 12.17 LPE "a\[\\s]b" "a b" "a b" expectMatch 12.18 LPE {a[\w]b} axb axb - doing 13 "escapes" expectError 13.1 & "a\\" EESCAPE expectMatch 13.2 - {a\<b} a<b a<b @@ -644,7 +631,6 @@ expectMatch 13.32 P {a\U000012345x} "a\u12345x" "a\u12345x" expectMatch 13.33 P "a\\U1000000x" "a\ufffd0x" "a\ufffd0x" expectMatch 13.34 P {a\U1000000x} "a\ufffd0x" "a\ufffd0x" - doing 14 "back references" # ugh expectMatch 14.1 RP {a(b*)c\1} abbcbb abbcbb bb @@ -671,7 +657,6 @@ expectMatch 14.21 RP {^([bc])\1*$} bbb bbb b expectMatch 14.22 RP {^([bc])\1*$} ccc ccc c knownBug expectNomatch 14.23 R {^([bc])\1*$} bcb - doing 15 "octal escapes vs back references" # initial zero is always octal expectMatch 15.1 MP "a\\010b" "a\bb" "a\bb" @@ -694,7 +679,6 @@ expectError 15.11 b {a\12b} ESUBREG expectMatch 15.12 eAS {a\12b} a12b a12b expectMatch 15.13 MP {a\701b} a\u00381b a\u00381b - doing 16 "expanded syntax" expectMatch 16.1 xP "a b c" "abc" "abc" expectMatch 16.2 xP "a b #oops\nc\td" "abcd" "abcd" @@ -706,15 +690,12 @@ expectMatch 16.7 xP "a b\[c#d]e" "abde" "abde" expectMatch 16.8 xSPB "ab{ d" "ab\{d" "ab\{d" expectMatch 16.9 xPQ "ab{ 1 , 2 }c" "abc" "abc" - doing 17 "misc syntax" expectMatch 17.1 P a(?#comment)b ab ab - doing 18 "unmatchable REs" expectNomatch 18.1 I a^b ab - doing 19 "case independence" expectMatch 19.1 &i ab Ab Ab expectMatch 19.2 &i {a[bc]} aC aC @@ -722,7 +703,6 @@ expectNomatch 19.3 &i {a[^bc]} aB expectMatch 19.4 &iM {a[b-d]} aC aC expectNomatch 19.5 &iM {a[^b-d]} aC - doing 20 "directors and embedded options" expectError 20.1 & ***? BADPAT expectMatch 20.2 q ***? ***? ***? @@ -760,7 +740,6 @@ expectMatch 20.33 xP "(?q)a b" "a b" "a b" expectMatch 20.34 P "(?qx)a b" "a b" "a b" expectMatch 20.35 P (?qi)ab Ab Ab - doing 21 "capturing" expectMatch 21.1 - a(b)c abc abc b expectMatch 21.2 P a(?:b)c xabc abc @@ -797,7 +776,6 @@ expectMatch 21.32 - a((b|c)d+)+ abacdbd acdbd bd b expectMatch 21.33 N (.*).* abc abc abc expectMatch 21.34 N (a*)* bc "" "" - doing 22 "multicharacter collating elements" # again ugh expectMatch 22.1 &+L {a[c]e} ace ace @@ -823,7 +801,6 @@ expectMatch 22.20 &+L {a[^b]} ace ac expectMatch 22.21 &+L {a[^b]} ach ach expectNomatch 22.22 &+L {a[^b]} abe - doing 23 "lookahead constraints" expectMatch 23.1 HP a(?=b)b* ab ab expectNomatch 23.2 HP a(?=b)b* a @@ -834,7 +811,6 @@ expectMatch 23.6 HP a(?!b)b* a a expectMatch 23.7 HP (?=b)b b b expectNomatch 23.8 HP (?=b)b a - doing 24 "non-greedy quantifiers" expectMatch 24.1 PT ab+? abb ab expectMatch 24.2 PT ab+?c abbc abbc @@ -849,7 +825,6 @@ expectMatch 24.10 PT 3z*? 123zzzz456 3 expectMatch 24.11 - z*4 123zzzz456 zzzz4 expectMatch 24.12 PT z*?4 123zzzz456 zzzz4 - doing 25 "mixed quantifiers" # this is very incomplete as yet # should include | @@ -857,7 +832,6 @@ expectMatch 25.1 PNT {^(.*?)(a*)$} "xyza" xyza xyz a expectMatch 25.2 PNT {^(.*?)(a*)$} "xyzaa" xyzaa xyz aa expectMatch 25.3 PNT {^(.*?)(a*)$} "xyz" xyz xyz "" - doing 26 "tricky cases" # attempts to trick the matcher into accepting a short match expectMatch 26.1 - (week|wee)(night|knights) \ @@ -865,7 +839,6 @@ expectMatch 26.1 - (week|wee)(night|knights) \ expectMatch 26.2 RP {a(bc*).*\1} abccbccb abccbccb b expectMatch 26.3 - {a(b.[bc]*)+} abcbd abcbd bd - doing 27 "implementation misc." # duplicate arcs are suppressed expectMatch 27.1 P a(?:b|b)c abc abc @@ -874,7 +847,6 @@ expectMatch 27.2 & {[ab][ab][ab]} aba aba expectMatch 27.3 & {[ab][ab][ab][ab][ab][ab][ab]} \ "abababa" abababa - doing 28 "boundary busters etc." # color-descriptor allocation changes at 10 expectMatch 28.1 & abcdefghijkl "abcdefghijkl" abcdefghijkl @@ -902,7 +874,6 @@ expectIndices 28.11 %LP {\w+(abcdefgh)?} xyzabcdefg {0 9} {-1 -1} expectIndices 28.12 %LP {\w+(abcdefghijklmnopqrst)?} \ "xyzabcdefghijklmnopqrs" {0 21} {-1 -1} - doing 29 "incomplete matches" expectPartial 29.1 t def abc {3 2} "" expectPartial 29.2 t bcd abc {1 2} "" @@ -923,7 +894,6 @@ expectIndices 29.15 tPT abc+? xyabcdd {2 4} {7 6} expectIndices 29.16 t abcd|bc xyabc {3 4} {2 4} expectPartial 29.17 tn .*k "xx\nyyy" {3 5} "" - doing 30 "misc. oddities and old bugs" expectError 30.1 & *** BADRPT expectMatch 30.2 N a?b* abb abb @@ -939,7 +909,6 @@ expectNomatch 30.8 s abc xabcd expectMatch 30.9 HLP {(?n)^(?![t#])\S+} \ "tk\n\n#\n#\nit0" it0 - # Now for tests *not* written by Henry Spencer namespace import -force ::tcltest::test diff --git a/tests/regexp.test b/tests/regexp.test index 7cafd1b..97628b1 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -895,7 +895,7 @@ test regexp-23.11 {regexp -all and -line} { } {{1 1} {2 2} {4 4}} test regexp-24.1 {regsub -all and -line} { - foreach {v1 v2 v3} {{} {} {}} {} + lassign "" v1 v2 v3 set string "" list \ [regsub -line -all {^} $string {<&>} v1] $v1 \ @@ -903,7 +903,7 @@ test regexp-24.1 {regsub -all and -line} { [regsub -line -all {$} $string {<&>} v3] $v3 } {1 <> 1 <> 1 <>} test regexp-24.2 {regsub -all and -line} { - foreach {v1 v2 v3} {{} {} {}} {} + lassign "" v1 v2 v3 set string "\n" list \ [regsub -line -all {^} $string {<&>} v1] $v1 \ @@ -911,7 +911,7 @@ test regexp-24.2 {regsub -all and -line} { [regsub -line -all {$} $string {<&>} v3] $v3 } [list 2 "<>\n<>" 2 "<>\n<>" 2 "<>\n<>"] test regexp-24.3 {regsub -all and -line} { - foreach {v1 v2 v3} {{} {} {}} {} + lassign "" v1 v2 v3 set string "\n\n" list \ [regsub -line -all {^} $string {<&>} v1] $v1 \ @@ -919,7 +919,7 @@ test regexp-24.3 {regsub -all and -line} { [regsub -line -all {$} $string {<&>} v3] $v3 } [list 3 "<>\n<>\n<>" 3 "<>\n<>\n<>" 3 "<>\n<>\n<>"] test regexp-24.4 {regsub -all and -line} { - foreach {v1 v2 v3} {{} {} {}} {} + lassign "" v1 v2 v3 set string "a" list \ [regsub -line -all {^} $string {<&>} v1] $v1 \ @@ -927,7 +927,7 @@ test regexp-24.4 {regsub -all and -line} { [regsub -line -all {$} $string {<&>} v3] $v3 } [list 1 "<>a" 1 "<a>" 1 "a<>"] test regexp-24.5 {regsub -all and -line} { - foreach {v1 v2 v3} {{} {} {}} {} + lassign "" v1 v2 v3 set string "a\n" list \ [regsub -line -all {^} $string {<&>} v1] $v1 \ @@ -935,7 +935,7 @@ test regexp-24.5 {regsub -all and -line} { [regsub -line -all {$} $string {<&>} v3] $v3 } [list 2 "<>a\n<>" 2 "<a>\n<>" 2 "a<>\n<>"] test regexp-24.6 {regsub -all and -line} { - foreach {v1 v2 v3} {{} {} {}} {} + lassign "" v1 v2 v3 set string "\na" list \ [regsub -line -all {^} $string {<&>} v1] $v1 \ @@ -943,7 +943,7 @@ test regexp-24.6 {regsub -all and -line} { [regsub -line -all {$} $string {<&>} v3] $v3 } [list 2 "<>\n<>a" 2 "<>\n<a>" 2 "<>\na<>"] test regexp-24.7 {regsub -all and -line} { - foreach {v1 v2 v3} {{} {} {}} {} + lassign "" v1 v2 v3 set string "ab\n" list \ [regsub -line -all {^} $string {<&>} v1] $v1 \ @@ -951,7 +951,7 @@ test regexp-24.7 {regsub -all and -line} { [regsub -line -all {$} $string {<&>} v3] $v3 } [list 2 "<>ab\n<>" 2 "<ab>\n<>" 2 "ab<>\n<>"] test regexp-24.8 {regsub -all and -line} { - foreach {v1 v2 v3} {{} {} {}} {} + lassign "" v1 v2 v3 set string "a\nb" list \ [regsub -line -all {^} $string {<&>} v1] $v1 \ @@ -959,7 +959,7 @@ test regexp-24.8 {regsub -all and -line} { [regsub -line -all {$} $string {<&>} v3] $v3 } [list 2 "<>a\n<>b" 2 "<a>\n<b>" 2 "a<>\nb<>"] test regexp-24.9 {regsub -all and -line} { - foreach {v1 v2 v3} {{} {} {}} {} + lassign "" v1 v2 v3 set string "a\nb\n" list \ [regsub -line -all {^} $string {<&>} v1] $v1 \ @@ -967,7 +967,7 @@ test regexp-24.9 {regsub -all and -line} { [regsub -line -all {$} $string {<&>} v3] $v3 } [list 3 "<>a\n<>b\n<>" 3 "<a>\n<b>\n<>" 3 "a<>\nb<>\n<>"] test regexp-24.10 {regsub -all and -line} { - foreach {v1 v2 v3} {{} {} {}} {} + lassign "" v1 v2 v3 set string "a\nb\nc" list \ [regsub -line -all {^} $string {<&>} v1] $v1 \ diff --git a/tests/regexpComp.test b/tests/regexpComp.test index 94fb90e..d73966a 100644 --- a/tests/regexpComp.test +++ b/tests/regexpComp.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } diff --git a/tests/registry.test b/tests/registry.test index 77588e3..cddc7c9 100644 --- a/tests/registry.test +++ b/tests/registry.test @@ -10,7 +10,7 @@ # Copyright (c) 1997 by Sun Microsystems, Inc. All rights reserved. # Copyright (c) 1998-1999 by Scriptics Corporation. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } diff --git a/tests/remote.tcl b/tests/remote.tcl index 097e41f..c377bf5 100644 --- a/tests/remote.tcl +++ b/tests/remote.tcl @@ -12,7 +12,7 @@ # Initialize message delimitor # Initialize command array -catch {unset command} +unset -nocomplain command set command(0) "" set callerSocket "" @@ -22,7 +22,7 @@ if {![info exists VERBOSE]} { } proc __doCommands__ {l s} { - global callerSocket VERBOSE + global callerSocket VERBOSE errorInfo if {$VERBOSE} { puts "--- Server executing the following for socket $s:" @@ -30,22 +30,22 @@ proc __doCommands__ {l s} { puts "---" } set callerSocket $s - set ::errorInfo "" + set errorInfo "" set code [catch {uplevel "#0" $l} msg] - return [list $code $::errorInfo $msg] + return [list $code $errorInfo $msg] } proc __readAndExecute__ {s} { global command VERBOSE set l [gets $s] - if {[string compare $l "--Marker--Marker--Marker--"] == 0} { + if {$l eq "--Marker--Marker--Marker--"} { puts $s [__doCommands__ $command($s) $s] puts $s "--Marker--Marker--Marker--" set command($s) "" return } - if {[string compare $l ""] == 0} { + if {$l eq ""} { if {[eof $s]} { if {$VERBOSE} { puts "Server closing $s, eof from client" @@ -72,13 +72,13 @@ proc __accept__ {s a p} { puts "Server accepts new connection from $a:$p on $s" } set command($s) "" - fconfigure $s -buffering line -translation crlf - fileevent $s readable [list __readAndExecute__ $s] + chan configure $s -buffering line -translation crlf + chan event $s readable [list __readAndExecute__ $s] } set serverIsSilent 0 for {set i 0} {$i < $argc} {incr i} { - if {[string compare -serverIsSilent [lindex $argv $i]] == 0} { + if {"-serverIsSilent" eq [lindex $argv $i]} { set serverIsSilent 1 break } @@ -90,9 +90,9 @@ if {![info exists serverPort]} { } if {![info exists serverPort]} { for {set i 0} {$i < $argc} {incr i} { - if {[string compare -port [lindex $argv $i]] == 0} { - if {$i < [expr $argc - 1]} { - set serverPort [lindex $argv [expr $i + 1]] + if {"-port" eq [lindex $argv $i]} { + if {$i < ($argc - 1)} { + set serverPort [lindex $argv [expr {$i + 1}]] } break } @@ -109,9 +109,9 @@ if {![info exists serverAddress]} { } if {![info exists serverAddress]} { for {set i 0} {$i < $argc} {incr i} { - if {[string compare -address [lindex $argv $i]] == 0} { - if {$i < [expr $argc - 1]} { - set serverAddress [lindex $argv [expr $i + 1]] + if {"-address" eq [lindex $argv $i]} { + if {$i < ($argc - 1)} { + set serverAddress [lindex $argv [expr {$i + 1}]] } break } @@ -146,8 +146,8 @@ if {$serverIsSilent == 0} { flush stdout } -proc getPort sock { - lindex [fconfigure $sock -sockname] 2 +proc getPort {sock} { + lindex [chan configure $sock -sockname] 2 } if {[catch {set serverSocket \ diff --git a/tests/rename.test b/tests/rename.test index 1fa0441..7246f26 100644 --- a/tests/rename.test +++ b/tests/rename.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } diff --git a/tests/safe.test b/tests/safe.test index 4a2792e..a330662 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -12,7 +12,7 @@ package require Tcl 8.5 -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } diff --git a/tests/scan.test b/tests/scan.test index 97ad5eb..b40a246 100644 --- a/tests/scan.test +++ b/tests/scan.test @@ -11,13 +11,13 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } testConstraint wideIs64bit \ - [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] + [expr {( ( wide (0x80000000) ) > 0) && ( ( wide (0x8000000000000000) ) < 0)}] test scan-1.1 {BuildCharSet, CharInSet} { list [scan foo {%[^o]} x] $x @@ -44,7 +44,7 @@ test scan-1.8 {BuildCharSet, CharInSet} { list [scan def-abc {%[^c-a]} x] $x } {1 def-} test scan-1.9 {BuildCharSet, CharInSet no match} { - catch {unset x} + unset -nocomplain x list [scan {= f} {= %[TF]} x] [info exists x] } {0 0} @@ -243,7 +243,7 @@ test scan-4.40.1 {Tcl_ScanObjCmd, base-16 integer scanning} { list [scan {0xF 0x00A0B 0X0XF} {%x %x %x} x y z] $x $y $z } {3 15 2571 0} test scan-4.40.2 {Tcl_ScanObjCmd, base-16 integer scanning} { - catch {unset x} + unset -nocomplain x list [scan {xF} {%x} x] [info exists x] } {0 0} test scan-4.40.3 {Tcl_ScanObjCmd, base-2 integer scanning} { @@ -321,9 +321,10 @@ test scan-4.59 {Tcl_ScanObjCmd, float scanning} { } {1 6} test scan-4.60 {Tcl_ScanObjCmd, set errors} { - set x {} - set y {} - catch {unset z}; array set z {} + set x "" + set y "" + unset -nocomplain z + array set z {} set result [list [catch {scan {abc def ghi} {%s%s%s} x z y} msg] \ $msg $x $y] unset z @@ -331,8 +332,10 @@ test scan-4.60 {Tcl_ScanObjCmd, set errors} { } {1 {can't set "z": variable is array} abc ghi} test scan-4.61 {Tcl_ScanObjCmd, set errors} { set x {} - catch {unset y}; array set y {} - catch {unset z}; array set z {} + unset -nocomplain y + array set y {} + unset -nocomplain z + array set z {} set result [list [catch {scan {abc def ghi} {%s%s%s} x z y} msg] \ $msg $x] unset y @@ -346,19 +349,19 @@ proc int_range {} { for { set MIN_INT 1 } { int($MIN_INT) > 0 } {} { set MIN_INT [expr { $MIN_INT << 1 }] } - set MIN_INT [expr {int($MIN_INT)}] + set MIN_INT [expr { int ($MIN_INT)}] set MAX_INT [expr { ~ $MIN_INT }] return [list $MIN_INT $MAX_INT] } test scan-4.62 {scanning of large and negative octal integers} { - foreach { MIN_INT MAX_INT } [int_range] {} + lassign [int_range] MIN_INT MAX_INT set scanstring [format {%o %o %o} -1 $MIN_INT $MAX_INT] list [scan $scanstring {%o %o %o} a b c] \ [expr { $a == -1 }] [expr { $b == $MIN_INT }] [expr { $c == $MAX_INT }] } {3 1 1 1} test scan-4.63 {scanning of large and negative hex integers} { - foreach { MIN_INT MAX_INT } [int_range] {} + lassign [int_range] MIN_INT MAX_INT set scanstring [format {%x %x %x} -1 $MIN_INT $MAX_INT] list [scan $scanstring {%x %x %x} a b c] \ [expr { $a == -1 }] [expr { $b == $MIN_INT }] [expr { $c == $MAX_INT }] @@ -542,31 +545,31 @@ test scan-8.11 {error conditions} { list [scan "1 2" "%d %d %d %d" a b c d] $a $b $c $d } {2 1 2 {} {}} test scan-8.12 {error conditions} { - catch {unset a} + unset -nocomplain a set a(0) 44 list [catch {scan 44 %d a} msg] $msg } {1 {can't set "a": variable is array}} test scan-8.13 {error conditions} { - catch {unset a} + unset -nocomplain a set a(0) 44 list [catch {scan 44 %c a} msg] $msg } {1 {can't set "a": variable is array}} test scan-8.14 {error conditions} { - catch {unset a} + unset -nocomplain a set a(0) 44 list [catch {scan 44 %s a} msg] $msg } {1 {can't set "a": variable is array}} test scan-8.15 {error conditions} { - catch {unset a} + unset -nocomplain a set a(0) 44 list [catch {scan 44 %f a} msg] $msg } {1 {can't set "a": variable is array}} test scan-8.16 {error conditions} { - catch {unset a} + unset -nocomplain a set a(0) 44 list [catch {scan 44 %f a} msg] $msg } {1 {can't set "a": variable is array}} -catch {unset a} +unset -nocomplain a test scan-8.17 {error conditions} { list [catch {scan 44 %2c a} msg] $msg } {1 {field width may not be specified in %c conversion}} @@ -608,7 +611,7 @@ test scan-10.4 {miscellaneous tests} { list [catch {scan ab%c14 ab%%c%d a} msg] $msg $a } {0 1 14} test scan-10.5 {miscellaneous tests} { - catch {unset arr} + unset -nocomplain arr set arr(2) {} list [catch {scan ab%c14 ab%%c%d arr(2)} msg] $msg $arr(2) } {0 1 14} diff --git a/tests/security.test b/tests/security.test index eeabc9c..e9e0f1d 100644 --- a/tests/security.test +++ b/tests/security.test @@ -30,7 +30,6 @@ proc CB {} { return $ret } - test security-1.1 {tcl_endOfPreviousWord} { catch {tcl_startOfPreviousWord x {[BUG]}} CB diff --git a/tests/set-old.test b/tests/set-old.test index 52dc0ff..7d8fc91 100644 --- a/tests/set-old.test +++ b/tests/set-old.test @@ -13,16 +13,16 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } -proc ignore args {} +proc ignore {args} {} # Simple variable operations. -catch {unset a} +unset -nocomplain a test set-old-1.1 {basic variable setting and unsetting} { set a 22 } 22 @@ -42,7 +42,7 @@ test set-old-1.4 {basic variable setting and unsetting} { # Basic array operations. -catch {unset a} +unset -nocomplain a set a(xyz) 2 set a(44) 3 set {a(a long name)} test @@ -75,11 +75,11 @@ test set-old-2.9 {basic array operations} { lsort [array names a] } {{a long name} xyz} test set-old-2.10 {basic array operations} { - catch {unset b} + unset -nocomplain b list [catch {set b(123)} msg] $msg } {1 {can't read "b(123)": no such variable}} test set-old-2.11 {basic array operations} { - catch {unset b} + unset -nocomplain b set b 44 list [catch {set b(123)} msg] $msg } {1 {can't read "b(123)": variable isn't array}} @@ -101,11 +101,11 @@ test set-old-3.2 {set command} { list [catch {set x y z} msg] $msg } {1 {wrong # args: should be "set varName ?newValue?"}} test set-old-3.3 {set command} { - catch {unset a} + unset -nocomplain a list [catch {set a} msg] $msg } {1 {can't read "a": no such variable}} test set-old-3.4 {set command} { - catch {unset a} + unset -nocomplain a set a(14) 83 list [catch {set a 22} msg] $msg } {1 {can't set "a": variable is array}} @@ -113,32 +113,32 @@ test set-old-3.4 {set command} { # Test the corner-cases of parsing array names, using set and unset. test set-old-4.1 {parsing array names} { - catch {unset a} + unset -nocomplain a set a(()) 44 list [catch {array names a} msg] $msg } {0 ()} test set-old-4.2 {parsing array names} { - catch {unset a a(abcd} + unset -nocomplain a a(abcd set a(abcd 33 info exists a(abcd } 1 test set-old-4.3 {parsing array names} { - catch {unset a a(abcd} + unset -nocomplain a a(abcd set a(abcd 33 list [catch {array names a} msg] $msg } {0 {}} test set-old-4.4 {parsing array names} { - catch {unset a abcd)} + unset -nocomplain a abcd) set abcd) 33 info exists abcd) } 1 test set-old-4.5 {parsing array names} { set a(bcd yyy - catch {unset a} + unset -nocomplain a list [catch {set a(bcd} msg] $msg } {0 yyy} test set-old-4.6 {parsing array names} { - catch {unset a} + unset -nocomplain a set a 44 list [catch {set a(bcd test} msg] $msg } {0 test} @@ -146,21 +146,21 @@ test set-old-4.6 {parsing array names} { # Errors in reading variables test set-old-5.1 {errors in reading variables} { - catch {unset a} + unset -nocomplain a list [catch {set a} msg] $msg } {1 {can't read "a": no such variable}} test set-old-5.2 {errors in reading variables} { - catch {unset a} + unset -nocomplain a set a 44 list [catch {set a(18)} msg] $msg } {1 {can't read "a(18)": variable isn't array}} test set-old-5.3 {errors in reading variables} { - catch {unset a} + unset -nocomplain a set a(6) 44 list [catch {set a(18)} msg] $msg } {1 {can't read "a(18)": no such element in array}} test set-old-5.4 {errors in reading variables} { - catch {unset a} + unset -nocomplain a set a(6) 44 list [catch {set a} msg] $msg } {1 {can't read "a": variable is array}} @@ -168,22 +168,22 @@ test set-old-5.4 {errors in reading variables} { # Errors and other special cases in writing variables test set-old-6.1 {creating array during write} { - catch {unset a} + unset -nocomplain a trace var a rwu ignore list [catch {set a(14) 186} msg] $msg [array names a] } {0 186 14} test set-old-6.2 {errors in writing variables} { - catch {unset a} + unset -nocomplain a set a xxx list [catch {set a(14) 186} msg] $msg } {1 {can't set "a(14)": variable isn't array}} test set-old-6.3 {errors in writing variables} { - catch {unset a} + unset -nocomplain a set a(100) yyy list [catch {set a 2} msg] $msg } {1 {can't set "a": variable is array}} test set-old-6.4 {expanding variable size} { - catch {unset a} + unset -nocomplain a list [set a short] [set a "longer name"] [set a "even longer name"] \ [set a "a much much truly longer name"] } {short {longer name} {even longer name} {a much much truly longer name}} @@ -191,7 +191,7 @@ test set-old-6.4 {expanding variable size} { # Unset command, Tcl_UnsetVar procedures test set-old-7.1 {unset command} { - catch {unset a}; catch {unset b}; catch {unset c}; catch {unset d} + unset -nocomplain a b c d set a 44 set b 55 set c 66 @@ -206,21 +206,21 @@ test set-old-7.2 {unset command} { # Used to return: #{1 {wrong # args: should be "unset ?-nocomplain? ?--? ?varName ...?"}} test set-old-7.3 {unset command} { - catch {unset a} + unset -nocomplain a list [catch {unset a} msg] $msg } {1 {can't unset "a": no such variable}} test set-old-7.4 {unset command} { - catch {unset a} + unset -nocomplain a set a 44 list [catch {unset a(14)} msg] $msg } {1 {can't unset "a(14)": variable isn't array}} test set-old-7.5 {unset command} { - catch {unset a} + unset -nocomplain a set a(0) xx list [catch {unset a(14)} msg] $msg } {1 {can't unset "a(14)": no such element in array}} test set-old-7.6 {unset command} { - catch {unset a}; catch {unset b}; catch {unset c} + unset -nocomplain a b c set a foo set c gorp list [catch {unset a a a(14)} msg] $msg [info exists c] @@ -255,19 +255,19 @@ test set-old-7.9 {unsetting globals from within procedures} { concat [p1] [list [catch {set y} msg] $msg] } {0 55 0 55} test set-old-7.10 {unset command} { - catch {unset a} + unset -nocomplain a set a(14) 22 unset a(14) list [catch {set a(14)} msg] $msg [catch {array names a} msg2] $msg2 } {1 {can't read "a(14)": no such element in array} 0 {}} test set-old-7.11 {unset command} { - catch {unset a} + unset -nocomplain a set a(14) 22 unset a list [catch {set a(14)} msg] $msg [catch {array names a} msg2] $msg2 } {1 {can't read "a(14)": no such variable} 0 {}} test set-old-7.12 {unset command, -nocomplain} { - catch {unset a} + unset -nocomplain a list [info exists a] [catch {unset -nocomplain a}] [info exists a] } {0 0 0} test set-old-7.13 {unset command, -nocomplain} { @@ -315,11 +315,11 @@ test set-old-8.2 {array command} { list [catch {array a} msg] $msg } {1 {wrong # args: should be "array anymore arrayName searchId"}} test set-old-8.3 {array command} { - catch {unset a} + unset -nocomplain a list [catch {array anymore a b} msg] $msg } {1 {"a" isn't an array}} test set-old-8.4 {array command} { - catch {unset a} + unset -nocomplain a set a 44 list [catch {array anymore a b} msg] $msg } {1 {"a" isn't an array}} @@ -332,12 +332,12 @@ test set-old-8.5 {array command} { foo } {1 {"x" isn't an array}} test set-old-8.6 {array command} { - catch {unset a} + unset -nocomplain a set a(22) 3 list [catch {array gorp a} msg] $msg } {1 {unknown or ambiguous subcommand "gorp": must be anymore, donesearch, exists, get, names, nextelement, set, size, startsearch, statistics, or unset}} test set-old-8.7 {array command, anymore option} { - catch {unset a} + unset -nocomplain a list [catch {array anymore a x} msg] $msg } {1 {"a" isn't an array}} test set-old-8.8 {array command, anymore option, array doesn't exist yet but has compiler-allocated procedure slot} { @@ -350,7 +350,7 @@ test set-old-8.8 {array command, anymore option, array doesn't exist yet but has list [catch {foo 1} msg] $msg } {1 {"a" isn't an array}} test set-old-8.9 {array command, donesearch option} { - catch {unset a} + unset -nocomplain a list [catch {array donesearch a x} msg] $msg } {1 {"a" isn't an array}} test set-old-8.10 {array command, donesearch option, array doesn't exist yet but has compiler-allocated procedure slot} { @@ -366,11 +366,11 @@ test set-old-8.11 {array command, exists option} { list [catch {array exists a b} msg] $msg } {1 {wrong # args: should be "array exists arrayName"}} test set-old-8.12 {array command, exists option} { - catch {unset a} + unset -nocomplain a array exists a } {0} test set-old-8.13 {array command, exists option} { - catch {unset a} + unset -nocomplain a set a(0) 1 array exists a } {1} @@ -390,23 +390,23 @@ test set-old-8.16 {array command, get option} { list [catch {array get a b c} msg] $msg } {1 {wrong # args: should be "array get arrayName ?pattern?"}} test set-old-8.17 {array command, get option} { - catch {unset a} + unset -nocomplain a array get a } {} test set-old-8.18 {array command, get option} { - catch {unset a} + unset -nocomplain a set a(22) 3 - set {a(long name)} {} + set {a(long name)} "" lsort [array get a] } {{} 22 3 {long name}} test set-old-8.19 {array command, get option (unset variable)} { - catch {unset a} + unset -nocomplain a set a(x) 3 trace var a(y) w ignore array get a } {x 3} test set-old-8.20 {array command, get option, with pattern} { - catch {unset a} + unset -nocomplain a set a(x1) 3 set a(x2) 4 set a(x3) 5 @@ -424,34 +424,34 @@ test set-old-8.21 {array command, get option, array doesn't exist yet but has co list [catch {foo 1} msg] $msg } {0 {}} test set-old-8.22 {array command, names option} { - catch {unset a} + unset -nocomplain a set a(22) 3 list [catch {array names a 4 5} msg] $msg } {1 {bad option "4": must be -exact, -glob, or -regexp}} test set-old-8.23 {array command, names option} { - catch {unset a} + unset -nocomplain a array names a } {} test set-old-8.24 {array command, names option} { - catch {unset a} + unset -nocomplain a set a(22) 3; set a(Textual_name) 44; set "a(name with spaces)" xxx list [catch {lsort [array names a]} msg] $msg } {0 {22 Textual_name {name with spaces}}} test set-old-8.25 {array command, names option} { - catch {unset a} + unset -nocomplain a set a(22) 3; set a(33) 44; trace var a(xxx) w ignore list [catch {lsort [array names a]} msg] $msg } {0 {22 33}} test set-old-8.26 {array command, names option} { - catch {unset a} + unset -nocomplain a set a(22) 3; set a(33) 44; trace var a(xxx) w ignore set a(xxx) value list [catch {lsort [array names a]} msg] $msg } {0 {22 33 xxx}} test set-old-8.27 {array command, names option} { - catch {unset a} + unset -nocomplain a set a(axy) 3 set a(bxy) 44 set a(no) yes @@ -471,7 +471,7 @@ test set-old-8.29 {array command, nextelement option} { list [catch {array nextelement a} msg] $msg } {1 {wrong # args: should be "array nextelement arrayName searchId"}} test set-old-8.30 {array command, nextelement option} { - catch {unset a} + unset -nocomplain a list [catch {array nextelement a b} msg] $msg } {1 {"a" isn't an array}} test set-old-8.31 {array command, nextelement option, array doesn't exist yet but has compiler-allocated procedure slot} { @@ -493,12 +493,12 @@ test set-old-8.34 {array command, set option} { list [catch {array set a "a \{ c"} msg] $msg } {1 {unmatched open brace in list}} test set-old-8.35 {array command, set option} { - catch {unset a} + unset -nocomplain a set a 44 list [catch {array set a {a b c d}} msg] $msg } {1 {can't set "a(a)": variable isn't array}} test set-old-8.36 {array command, set option} { - catch {unset a} + unset -nocomplain a set a(xx) yy array set a {b c d e} lsort [array get a] @@ -513,28 +513,28 @@ test set-old-8.37 {array command, set option, array doesn't exist yet but has co list [catch {foo 1} msg] $msg } {0 {}} test set-old-8.38 {array command, set option} { - catch {unset aVaRnAmE} + unset -nocomplain aVaRnAmE array set aVaRnAmE {} list [info exists aVaRnAmE] [catch {set aVaRnAmE} msg] $msg } {1 1 {can't read "aVaRnAmE": variable is array}} test set-old-8.38.1 {array command, set scalar} { - catch {unset aVaRnAmE} + unset -nocomplain aVaRnAmE set aVaRnAmE 1 list [catch {array set aVaRnAmE {}} msg] $msg } {1 {can't array set "aVaRnAmE": variable isn't array}} test set-old-8.38.2 {array command, set alias} { - catch {unset aVaRnAmE} + unset -nocomplain aVaRnAmE upvar 0 aVaRnAmE anAliAs array set anAliAs {} list [array exists aVaRnAmE] [catch {set anAliAs} msg] $msg } {1 1 {can't read "anAliAs": variable is array}} test set-old-8.38.3 {array command, set element alias} { - catch {unset aVaRnAmE} + unset -nocomplain aVaRnAmE list [catch {upvar 0 aVaRnAmE(elem) elemAliAs}] \ [catch {array set elemAliAs {}} msg] $msg } {0 1 {can't array set "elemAliAs": variable isn't array}} test set-old-8.38.4 {array command, empty set with populated array} { - catch {unset aVaRnAmE} + unset -nocomplain aVaRnAmE array set aVaRnAmE [list e1 v1 e2 v2] array set aVaRnAmE {} array set aVaRnAmE [list e3 v3] @@ -550,29 +550,29 @@ test set-old-8.38.7 {array command, set with non-existent namespace} { list [catch {array set bogusnamespace::var(0) {a b}} msg] $msg } {1 {can't set "bogusnamespace::var(0)": parent namespace doesn't exist}} test set-old-8.39 {array command, size option} { - catch {unset a} + unset -nocomplain a array size a } {0} test set-old-8.40 {array command, size option} { list [catch {array size a 4} msg] $msg } {1 {wrong # args: should be "array size arrayName"}} test set-old-8.41 {array command, size option} { - catch {unset a} + unset -nocomplain a array size a } {0} test set-old-8.42 {array command, size option} { - catch {unset a} + unset -nocomplain a set a(22) 3; set a(Textual_name) 44; set "a(name with spaces)" xxx list [catch {array size a} msg] $msg } {0 3} test set-old-8.43 {array command, size option} { - catch {unset a} + unset -nocomplain a set a(22) 3; set a(xx) 44; set a(y) xxx unset a(22) a(y) a(xx) list [catch {array size a} msg] $msg } {0 0} test set-old-8.44 {array command, size option} { - catch {unset a} + unset -nocomplain a set a(22) 3; trace var a(33) rwu ignore list [catch {array size a} msg] $msg @@ -590,7 +590,7 @@ test set-old-8.46 {array command, startsearch option} { list [catch {array startsearch a b} msg] $msg } {1 {wrong # args: should be "array startsearch arrayName"}} test set-old-8.47 {array command, startsearch option} { - catch {unset a} + unset -nocomplain a list [catch {array startsearch a} msg] $msg } {1 {"a" isn't an array}} test set-old-8.48 {array command, startsearch option, array doesn't exist yet but has compiler-allocated procedure slot} { @@ -604,7 +604,7 @@ test set-old-8.48 {array command, startsearch option, array doesn't exist yet bu list [catch {p 1} msg] $msg } {1 {"a" isn't an array}} test set-old-8.49 {array command, statistics option} { - catch {unset a} + unset -nocomplain a set a(abc) 1 set a(def) 2 set a(ghi) 3 @@ -629,64 +629,64 @@ number of buckets with 9 entries: 0 number of buckets with 10 or more entries: 0 average search distance for entry: 1.7" test set-old-8.50 {array command, array names -exact on glob pattern} { - catch {unset a} + unset -nocomplain a set a(1*2) 1 list [catch {array names a -exact 1*2} msg] $msg } {0 1*2} test set-old-8.51 {array command, array names -glob on glob pattern} { - catch {unset a} + unset -nocomplain a set a(1*2) 1 set a(12) 1 set a(11) 1 list [catch {lsort [array names a -glob 1*2]} msg] $msg } {0 {1*2 12}} test set-old-8.52 {array command, array names -regexp on regexp pattern} { - catch {unset a} + unset -nocomplain a set a(1*2) 1 set a(12) 1 set a(11) 1 list [catch {lsort [array names a -regexp ^1]} msg] $msg } {0 {1*2 11 12}} test set-old-8.53 {array command, array names -regexp} { - catch {unset a} + unset -nocomplain a set a(-glob) 1 set a(-regexp) 1 set a(-exact) 1 list [catch {array names a -regexp} msg] $msg } {0 -regexp} test set-old-8.54 {array command, array names -exact} { - catch {unset a} + unset -nocomplain a set a(-glob) 1 set a(-regexp) 1 set a(-exact) 1 list [catch {array names a -exact} msg] $msg } {0 -exact} test set-old-8.55 {array command, array names -glob} { - catch {unset a} + unset -nocomplain a set a(-glob) 1 set a(-regexp) 1 set a(-exact) 1 list [catch {array names a -glob} msg] $msg } {0 -glob} test set-old-8.56 {array command, array statistics on a non-array} { - catch {unset a} + unset -nocomplain a list [catch {array statistics a} msg] $msg } [list 1 "\"a\" isn't an array"] test set-old-8.57 {array command, array get with trivial pattern} { - catch {unset a} + unset -nocomplain a set a(x) 1 set a(y) 2 array get a x } {x 1} test set-old-9.1 {ids for array enumeration} { - catch {unset a} + unset -nocomplain a set a(a) 1 list [array star a] [array star a] [array done a s-1-a; array star a] \ [array done a s-2-a; array d a s-3-a; array start a] } {s-1-a s-2-a s-3-a s-1-a} test set-old-9.2 {array enumeration} { - catch {unset a} + unset -nocomplain a set a(a) 1 set a(b) 1 set a(c) 1 @@ -695,7 +695,7 @@ test set-old-9.2 {array enumeration} { [array next a $x] [array next a $x]] } {{} {} a b c} test set-old-9.3 {array enumeration} { - catch {unset a} + unset -nocomplain a set a(a) 1 set a(b) 1 set a(c) 1 @@ -709,7 +709,7 @@ test set-old-9.3 {array enumeration} { [array next a $x]] } {{} {} {} a a a b b b c c c} test set-old-9.4 {array enumeration: stopping searches} { - catch {unset a} + unset -nocomplain a set a(a) 1 set a(b) 1 set a(c) 1 @@ -721,14 +721,14 @@ test set-old-9.4 {array enumeration: stopping searches} { [array done a $x; array next a $y] [array next a $y]] } {a a b b c c} test set-old-9.5 {array enumeration: stopping searches} { - catch {unset a} + unset -nocomplain a set a(a) 1 set x [array startsearch a] array done a $x list [catch {array next a $x} msg] $msg } {1 {couldn't find search "s-1-a"}} test set-old-9.6 {array enumeration: searches automatically stopped} { - catch {unset a} + unset -nocomplain a set a(a) 1 set x [array startsearch a] set y [array startsearch a] @@ -737,7 +737,7 @@ test set-old-9.6 {array enumeration: searches automatically stopped} { [catch {array next a $y} msg2] $msg2 } {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}} test set-old-9.7 {array enumeration: searches automatically stopped} { - catch {unset a} + unset -nocomplain a set a(a) 1 set x [array startsearch a] set y [array startsearch a] @@ -746,26 +746,26 @@ test set-old-9.7 {array enumeration: searches automatically stopped} { [catch {array next a $y} msg2] $msg2 } {0 a 0 a} test set-old-9.8 {array enumeration: searches automatically stopped} { - catch {unset a} + unset -nocomplain a set a(a) 1 set a(c) 2 set x [array startsearch a] set y [array startsearch a] - catch {unset a(c)} + unset -nocomplain a(c) list [catch {array next a $x} msg] $msg \ [catch {array next a $y} msg2] $msg2 } {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}} test set-old-9.9 {array enumeration: searches automatically stopped} { - catch {unset a} + unset -nocomplain a set a(a) 1 set x [array startsearch a] set y [array startsearch a] - catch {unset a(c)} + unset -nocomplain a(c) list [catch {array next a $x} msg] $msg \ [catch {array next a $y} msg2] $msg2 } {0 a 0 a} test set-old-9.10 {array enumeration: searches automatically stopped} { - catch {unset a} + unset -nocomplain a set a(a) 1 set x [array startsearch a] set y [array startsearch a] @@ -774,7 +774,7 @@ test set-old-9.10 {array enumeration: searches automatically stopped} { [catch {array next a $y} msg2] $msg2 } {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}} test set-old-9.11 {array enumeration: searches automatically stopped} { - catch {unset a} + unset -nocomplain a set a(a) 1 set x [array startsearch a] set y [array startsearch a] @@ -783,7 +783,7 @@ test set-old-9.11 {array enumeration: searches automatically stopped} { [catch {array next a $y} msg2] $msg2 } {0 a 0 a} test set-old-9.12 {array enumeration with traced undefined elements} { - catch {unset a} + unset -nocomplain a set a(a) 1 trace var a(b) r {} set x [array startsearch a] @@ -797,53 +797,53 @@ test set-old-10.2 {array enumeration errors} { list [catch {array start a b} msg] $msg } {1 {wrong # args: should be "array startsearch arrayName"}} test set-old-10.3 {array enumeration errors} { - catch {unset a} + unset -nocomplain a list [catch {array start a} msg] $msg } {1 {"a" isn't an array}} test set-old-10.4 {array enumeration errors} { - catch {unset a} + unset -nocomplain a set a(a) 1 set x [array startsearch a] list [catch {array next a} msg] $msg } {1 {wrong # args: should be "array nextelement arrayName searchId"}} test set-old-10.5 {array enumeration errors} { - catch {unset a} + unset -nocomplain a set a(a) 1 set x [array startsearch a] list [catch {array next a b c} msg] $msg } {1 {wrong # args: should be "array nextelement arrayName searchId"}} test set-old-10.6 {array enumeration errors} { - catch {unset a} + unset -nocomplain a set a(a) 1 set x [array startsearch a] list [catch {array next a a-1-a} msg] $msg } {1 {illegal search identifier "a-1-a"}} test set-old-10.7 {array enumeration errors} { - catch {unset a} + unset -nocomplain a set a(a) 1 set x [array startsearch a] list [catch {array next a sx1-a} msg] $msg } {1 {illegal search identifier "sx1-a"}} test set-old-10.8 {array enumeration errors} { - catch {unset a} + unset -nocomplain a set a(a) 1 set x [array startsearch a] list [catch {array next a s--a} msg] $msg } {1 {illegal search identifier "s--a"}} test set-old-10.9 {array enumeration errors} { - catch {unset a} + unset -nocomplain a set a(a) 1 set x [array startsearch a] list [catch {array next a s-1-b} msg] $msg } {1 {search identifier "s-1-b" isn't for variable "a"}} test set-old-10.10 {array enumeration errors} { - catch {unset a} + unset -nocomplain a set a(a) 1 set x [array startsearch a] list [catch {array next a s-1ba} msg] $msg } {1 {illegal search identifier "s-1ba"}} test set-old-10.11 {array enumeration errors} { - catch {unset a} + unset -nocomplain a set a(a) 1 set x [array startsearch a] list [catch {array next a s-2-a} msg] $msg @@ -864,7 +864,7 @@ test set-old-10.16 {array enumeration errors} { list [catch {array any a b c} msg] $msg } {1 {wrong # args: should be "array anymore arrayName searchId"}} test set-old-10.17 {array enumeration errors} { - catch {unset a} + unset -nocomplain a set a(0) 44 list [catch {array any a bogus} msg] $msg } {1 {illegal search identifier "bogus"}} @@ -872,7 +872,7 @@ test set-old-10.17 {array enumeration errors} { # Array enumeration with "anymore" option test set-old-11.1 {array anymore option} { - catch {unset a} + unset -nocomplain a set a(a) 1 set a(b) 2 set a(c) 3 @@ -883,7 +883,7 @@ test set-old-11.1 {array anymore option} { [array anymore a s-1-a] [array next a s-1-a]] } {{} 0 1 1 1 a b c} test set-old-11.2 {array anymore option} { - catch {unset a} + unset -nocomplain a set a(a) 1 set a(b) 2 set a(c) 3 @@ -913,11 +913,8 @@ test set-old-12.2 {cleanup on procedure return} { # Must delete variables when done, since these arrays get used as # scalars by other tests. -catch {unset a} -catch {unset b} -catch {unset c} -catch {unset aVaRnAmE} -catch {rename foo {}} +unset -nocomplain a b c aVaRnAmE +catch {rename foo ""} # cleanup ::tcltest::cleanupTests diff --git a/tests/set.test b/tests/set.test index 1d88553..ee38f38c 100644 --- a/tests/set.test +++ b/tests/set.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -20,8 +20,7 @@ catch [list package require -exact Tcltest [info patchlevel]] testConstraint testset2 [llength [info commands testset2]] -catch {unset x} -catch {unset i} +unset -nocomplain x i test set-1.1 {TclCompileSetCmd: missing variable name} { list [catch {set} msg] $msg @@ -40,12 +39,12 @@ test set-1.4 {TclCompileSetCmd: simple variable name in quotes} { list [set "i"] $i } {17 17} test set-1.5 {TclCompileSetCmd: simple variable name in braces} { - catch {unset {a simple var}} + unset -nocomplain {a simple var} set {a simple var} 27 list [set {a simple var}] ${a simple var} } {27 27} test set-1.6 {TclCompileSetCmd: simple array variable name} { - catch {unset a} + unset -nocomplain a set a(foo) 37 list [set a(foo)] $a(foo) } {37 37} @@ -150,19 +149,19 @@ test set-1.14 {TclCompileSetCmd: simple local name, >255 locals} { 260locals } {1234} test set-1.15 {TclCompileSetCmd: variable is array} { - catch {unset a} + unset -nocomplain a set x 27 set x [set a(foo) 11] - catch {unset a} + unset -nocomplain a set x } 11 test set-1.16 {TclCompileSetCmd: variable is array, elem substitutions} { - catch {unset a} + unset -nocomplain a set i 5 set x 789 set a(foo5) 27 set x [set a(foo$i)] - catch {unset a} + unset -nocomplain a set x } 27 @@ -205,7 +204,7 @@ test set-1.24 {TclCompileSetCmd: too many arguments} { test set-1.25 {TclCompileSetCmd: var is array, braced (no subs)} { # This was a known error in 8.1a* - 8.2.1 - catch {unset array} + unset -nocomplain array set {array($foo)} 5 } 5 test set-1.26 {TclCompileSetCmd: various array constructs} { @@ -242,12 +241,12 @@ test set-2.1 {set command: runtime error, bad variable name} { while executing "set {"foo}"}} test set-2.2 {set command: runtime error, not array variable} { - catch {unset b} + unset -nocomplain b set b 44 list [catch {set b(123)} msg] $msg } {1 {can't read "b(123)": variable isn't array}} test set-2.3 {set command: runtime error, errors in reading variables} { - catch {unset a} + unset -nocomplain a set a(6) 44 list [catch {set a(18)} msg] $msg } {1 {can't read "a(18)": no such element in array}} @@ -269,10 +268,7 @@ test set-2.6 {set command: runtime error, basic array operations} { # Test the uncompiled version of set -catch {unset a} -catch {unset b} -catch {unset i} -catch {unset x} +unset -nocomplain a b i x test set-3.1 {uncompiled set command: missing variable name} { set z set @@ -296,13 +292,13 @@ test set-3.4 {uncompiled set command: simple variable name in quotes} { } {17 17} test set-3.5 {uncompiled set command: simple variable name in braces} { set z set - catch {unset {a simple var}} + unset -nocomplain {a simple var} $z {a simple var} 27 list [$z {a simple var}] ${a simple var} } {27 27} test set-3.6 {uncompiled set command: simple array variable name} { set z set - catch {unset a} + unset -nocomplain a $z a(foo) 37 list [$z a(foo)] $a(foo) } {37 37} @@ -417,20 +413,20 @@ test set-3.14 {uncompiled set command: simple local name, >255 locals} { } {1234} test set-3.15 {uncompiled set command: variable is array} { set z set - catch {unset a} + unset -nocomplain a $z x 27 $z x [$z a(foo) 11] - catch {unset a} + unset -nocomplain a $z x } 11 test set-3.16 {uncompiled set command: variable is array, elem substitutions} { set z set - catch {unset a} + unset -nocomplain a $z i 5 $z x 789 $z a(foo5) 27 $z x [$z a(foo$i)] - catch {unset a} + unset -nocomplain a $z x } 27 @@ -488,13 +484,13 @@ test set-4.1 {uncompiled set command: runtime error, bad variable name} { "$z {"foo}"}} test set-4.2 {uncompiled set command: runtime error, not array variable} { set z set - catch {unset b} + unset -nocomplain b $z b 44 list [catch {$z b(123)} msg] $msg } {1 {can't read "b(123)": variable isn't array}} test set-4.3 {uncompiled set command: runtime error, errors in reading variables} { set z set - catch {unset a} + unset -nocomplain a $z a(6) 44 list [catch {$z a(18)} msg] $msg } {1 {can't read "a(18)": no such element in array}} @@ -525,10 +521,6 @@ test set-5.1 {error on malformed array name} testset2 { } {{can't read "z(a)(b)": variable isn't array} {can't read "z(b)(a)": variable isn't array}} # cleanup -catch {unset a} -catch {unset b} -catch {unset i} -catch {unset x} -catch {unset z} +unset -nocomplain a b i x z ::tcltest::cleanupTests return diff --git a/tests/socket.test b/tests/socket.test index 5542c09..a3b9356 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -69,7 +69,7 @@ testConstraint exec [llength [info commands exec]] # Produce a random port number in the Dynamic/Private range # from 49152 through 65535. -proc randport {} { expr {int(rand()*16383+49152)} } +proc randport {} { expr { int ( ( ( rand () ) * 16383) + 49152)} } # Test the latency of tcp connections over the loopback interface. Some OSes # (e.g. NetBSD) seem to use the Nagle algorithm and delayed ACKs, so it takes @@ -77,16 +77,20 @@ proc randport {} { expr {int(rand()*16383+49152)} } # here, so that OSes that don't have this problem can run the tests at full # speed. set server [socket -server {apply {{s a p} {set ::s1 $s}}} 0] -set s2 [socket localhost [lindex [fconfigure $server -sockname] 2]] -vwait s1; close $server -fconfigure $s1 -buffering line -fconfigure $s2 -buffering line +set s2 [socket localhost [lindex [chan configure $server -sockname] 2]] +vwait s1 +close $server +chan configure $s1 -buffering line +chan configure $s2 -buffering line set t1 [clock milliseconds] -puts $s2 test1; gets $s1 -puts $s2 test2; gets $s1 -close $s1; close $s2 +puts $s2 test1 +gets $s1 +puts $s2 test2 +gets $s1 +close $s1 +close $s2 set t2 [clock milliseconds] -set latency [expr {($t2-$t1)*2}]; # doubled as a safety margin +set latency [expr {($t2 - $t1) * 2}]; # doubled as a safety margin unset t1 t2 s1 s2 server # If remoteServerIP or remoteServerPort are not set, check in the environment @@ -108,11 +112,11 @@ if {![info exists remoteServerPort]} { } } -if 0 { +if {0} { # activate this to time the tests proc test {args} { set name [lindex $args 0] - puts "[lindex [time {uplevel [linsert $args 0 tcltest::test]}] 0] @@@ $name" + puts "[lindex [time {uplevel 1 [linsert $args 0 tcltest::test]}] 0] @@@ $name" } } @@ -127,12 +131,11 @@ foreach {af localhost} { testConstraint supported_any [expr {[testConstraint supported_inet] || [testConstraint supported_inet6]}] set sock [socket -server foo -myaddr localhost 0] -set sockname [fconfigure $sock -sockname] +set sockname [chan configure $sock -sockname] close $sock testConstraint localhost_v4 [expr {"127.0.0.1" in $sockname}] testConstraint localhost_v6 [expr {"::1" in $sockname}] - foreach {af localhost} { any 127.0.0.1 inet 127.0.0.1 @@ -161,11 +164,11 @@ if {($doTestsWithRemoteServer == 1) && (![info exists remoteServerPort])} { set remoteProcChan "" set commandSocket "" if {$doTestsWithRemoteServer} { - catch {close $commandSocket} + catch {chan close $commandSocket} if {![catch { set commandSocket [socket $remoteServerIP $remoteServerPort] - }]} then { - fconfigure $commandSocket -translation crlf -buffering line + }]} { + chan configure $commandSocket -translation crlf -buffering line } elseif {![testConstraint exec]} { set noRemoteTestReason "can't exec" set doTestsWithRemoteServer 0 @@ -179,12 +182,12 @@ if {$doTestsWithRemoteServer} { set remoteProcChan [open "|[list \ [interpreter] $remoteFile -serverIsSilent \ -port $remoteServerPort -address $remoteServerIP]" w+] - } msg]} then { + } msg]} { gets $remoteProcChan if {[catch { set commandSocket [socket $remoteServerIP $remoteServerPort] - } msg] == 0} then { - fconfigure $commandSocket -translation crlf -buffering line + } msg] == 0} { + chan configure $commandSocket -translation crlf -buffering line } else { set noRemoteTestReason $msg set doTestsWithRemoteServer 0 @@ -224,9 +227,10 @@ if {[testConstraint doTestsWithRemoteServer]} { error "remote server disappeared: $msg" } + set result "" while {1} { - set line [gets $commandSocket] - if {[eof $commandSocket]} { + set line [chan gets $commandSocket] + if {[chan eof $commandSocket]} { error "remote server disappaered" } if {$line eq "--Marker--Marker--Marker--"} { @@ -238,8 +242,8 @@ if {[testConstraint doTestsWithRemoteServer]} { } } -proc getPort sock { - lindex [fconfigure $sock -sockname] 2 +proc getPort {sock} { + lindex [chan configure $sock -sockname] 2 } @@ -302,7 +306,7 @@ test socket_$af-2.1 {tcp connection} -constraints [list socket supported_$af std close $file } puts ready - puts [lindex [fconfigure $f -sockname] 2] + puts [lindex [chan configure $f -sockname] 2] vwait x after cancel $timer close $f @@ -335,7 +339,7 @@ test socket_$af-2.2 {tcp connection with client port specified} -setup { set x done } puts ready - puts [lindex [fconfigure $f -sockname] 2] + puts [lindex [chan configure $f -sockname] 2] vwait x after cancel $timer close $f @@ -368,7 +372,7 @@ test socket_$af-2.3 {tcp connection with client interface specified} -setup { close $file set x done } - puts [lindex [fconfigure $f -sockname] 2] + puts [lindex [chan configure $f -sockname] 2] puts ready vwait x after cancel $timer @@ -403,7 +407,7 @@ test socket_$af-2.4 {tcp connection with server interface specified} -setup { set x done } puts ready - puts [lindex [fconfigure $f -sockname] 2] + puts [lindex [chan configure $f -sockname] 2] vwait x after cancel $timer close $f @@ -436,7 +440,7 @@ test socket_$af-2.5 {tcp connection with redundant server port} -setup { set x done } puts ready - puts [lindex [fconfigure $f -sockname] 2] + puts [lindex [chan configure $f -sockname] 2] vwait x after cancel $timer close $f @@ -473,8 +477,8 @@ test socket_$af-2.7 {echo server, one line} -constraints [list socket supported_ set timer [after 10000 "set x timeout"] set f [socket -server accept 0] proc accept {s a p} { - fileevent $s readable [list echo $s] - fconfigure $s -translation lf -buffering line + chan event $s readable [list echo $s] + chan configure $s -translation lf -buffering line } proc echo {s} { set l [gets $s] @@ -487,7 +491,7 @@ test socket_$af-2.7 {echo server, one line} -constraints [list socket supported_ } } puts ready - puts [lindex [fconfigure $f -sockname] 2] + puts [lindex [chan configure $f -sockname] 2] vwait x after cancel $timer close $f @@ -499,7 +503,7 @@ test socket_$af-2.7 {echo server, one line} -constraints [list socket supported_ gets $f listen } -body { set s [socket $localhost $listen] - fconfigure $s -buffering line -translation lf + chan configure $s -buffering line -translation lf puts $s "hello abcdefghijklmnop" set x [gets $s] close $s @@ -512,8 +516,8 @@ test socket_$af-2.8 {echo server, loop 50 times, single connection} -setup { set path(script) [makeFile { set f [socket -server accept 0] proc accept {s a p} { - fileevent $s readable [list echo $s] - fconfigure $s -buffering line + chan event $s readable [list echo $s] + chan configure $s -buffering line } proc echo {s} { global i @@ -529,7 +533,7 @@ test socket_$af-2.8 {echo server, loop 50 times, single connection} -setup { } set i 0 puts ready - puts [lindex [fconfigure $f -sockname] 2] + puts [lindex [chan configure $f -sockname] 2] set timer [after 20000 "set x done"] vwait x after cancel $timer @@ -541,7 +545,7 @@ test socket_$af-2.8 {echo server, loop 50 times, single connection} -setup { gets $f listen } -constraints [list socket supported_$af stdio] -body { set s [socket $localhost $listen] - fconfigure $s -buffering line + chan configure $s -buffering line catch { for {set x 0} {$x < 50} {incr x} { puts $s "hello abcdefghijklmnop" @@ -561,7 +565,7 @@ test socket_$af-2.9 {socket conflict} -constraints [list socket supported_$af st file delete $path(script) set f [open $path(script) w] puts $f [list set ::tcl::unsupported::socketAF $::tcl::unsupported::socketAF] - puts $f "socket -server accept [lindex [fconfigure $s -sockname] 2]" + puts $f "socket -server accept [lindex [chan configure $s -sockname] 2]" close $f set f [open "|[list [interpreter] $path(script)]" r] gets $f @@ -578,8 +582,8 @@ test socket_$af-2.10 {close on accept, accepted socket lives} -setup { proc accept {s a p} { global ss close $ss - fileevent $s readable "readit $s" - fconfigure $s -trans lf + chan event $s readable "readit $s" + chan configure $s -trans lf } proc readit {s} { global done @@ -587,7 +591,7 @@ test socket_$af-2.10 {close on accept, accepted socket lives} -setup { close $s set done 1 } - set cs [socket $localhost [lindex [fconfigure $ss -sockname] 2]] + set cs [socket $localhost [lindex [chan configure $ss -sockname] 2]] puts $cs hello close $cs vwait done @@ -603,24 +607,24 @@ test socket_$af-2.11 {detecting new data} -constraints [list socket supported_$a set s [socket -server accept 0] set sock "" } -body { - set s2 [socket $localhost [lindex [fconfigure $s -sockname] 2]] + set s2 [socket $localhost [lindex [chan configure $s -sockname] 2]] vwait sock puts $s2 one flush $s2 after idle {set x 1} vwait x - fconfigure $sock -blocking 0 + chan configure $sock -blocking 0 set result a:[gets $sock] lappend result b:[gets $sock] - fconfigure $sock -blocking 1 + chan configure $sock -blocking 1 puts $s2 two flush $s2 after $latency {set x 1}; # NetBSD fails here if we do [after idle] vwait x - fconfigure $sock -blocking 0 + chan configure $sock -blocking 0 lappend result c:[gets $sock] } -cleanup { - fconfigure $sock -blocking 1 + chan configure $sock -blocking 1 close $s2 close $s close $sock @@ -633,7 +637,7 @@ test socket_$af-3.1 {socket conflict} -constraints [list socket supported_$af st puts $f { set f [socket -server accept -myaddr $localhost 0] puts ready - puts [lindex [fconfigure $f -sockname] 2] + puts [lindex [chan configure $f -sockname] 2] gets stdin close $f } @@ -658,8 +662,8 @@ test socket_$af-3.2 {server with several clients} -setup { set counter 0 set s [socket -server accept -myaddr $localhost 0] proc accept {s a p} { - fileevent $s readable [list echo $s] - fconfigure $s -buffering line + chan event $s readable [list echo $s] + chan configure $s -buffering line } proc echo {s} { global x @@ -672,7 +676,7 @@ test socket_$af-3.2 {server with several clients} -setup { } } puts ready - puts [lindex [fconfigure $s -sockname] 2] + puts [lindex [chan configure $s -sockname] 2] vwait x after cancel $t1 vwait x @@ -689,11 +693,11 @@ test socket_$af-3.2 {server with several clients} -setup { } -constraints [list socket supported_$af stdio] -body { # $x == "ready" here set s1 [socket $localhost $listen] - fconfigure $s1 -buffering line + chan configure $s1 -buffering line set s2 [socket $localhost $listen] - fconfigure $s2 -buffering line + chan configure $s2 -buffering line set s3 [socket $localhost $listen] - fconfigure $s3 -buffering line + chan configure $s3 -buffering line for {set i 0} {$i < 100} {incr i} { puts $s1 hello,s1 gets $s1 @@ -717,7 +721,7 @@ test socket_$af-4.1 {server with several clients} -setup { puts $f { set port [gets stdin] set s [socket $localhost $port] - fconfigure $s -buffering line + chan configure $s -buffering line for {set i 0} {$i < 100} {incr i} { puts $s hello gets $s @@ -728,15 +732,15 @@ test socket_$af-4.1 {server with several clients} -setup { } close $f set p1 [open "|[list [interpreter] $path(script)]" r+] - fconfigure $p1 -buffering line + chan configure $p1 -buffering line set p2 [open "|[list [interpreter] $path(script)]" r+] - fconfigure $p2 -buffering line + chan configure $p2 -buffering line set p3 [open "|[list [interpreter] $path(script)]" r+] - fconfigure $p3 -buffering line + chan configure $p3 -buffering line } -constraints [list socket supported_$af stdio] -body { proc accept {s a p} { - fconfigure $s -buffering line - fileevent $s readable [list echo $s] + chan configure $s -buffering line + chan event $s readable [list echo $s] } proc echo {s} { global x @@ -752,7 +756,7 @@ test socket_$af-4.1 {server with several clients} -setup { set t2 [after 31000 "set x timed_out"] set t3 [after 32000 "set x timed_out"] set s [socket -server accept -myaddr $localhost 0] - set listen [lindex [fconfigure $s -sockname] 2] + set listen [lindex [chan configure $s -sockname] 2] puts $p1 $listen puts $p2 $listen puts $p3 $listen @@ -820,7 +824,7 @@ test socket_$af-6.1 {accept callback error} -constraints [list socket supported_ set f [open "|[list [interpreter] $path(script)]" r+] proc accept {s a p} {expr 10 / 0} set s [socket -server accept -myaddr $localhost 0] - puts $f [lindex [fconfigure $s -sockname] 2] + puts $f [lindex [chan configure $s -sockname] 2] close $f set timer [after 10000 "set x timed_out"] vwait x @@ -832,19 +836,19 @@ test socket_$af-6.1 {accept callback error} -constraints [list socket supported_ } -result {divide by zero} test socket_$af-6.2 { - readable fileevent on server socket + readable chan event on server socket } -setup { set sock [socket -server dummy 0] } -constraints [list socket supported_$af] -body { - fileevent $sock readable dummy + chan event $sock readable dummy } -cleanup { close $sock } -returnCodes 1 -result "channel is not readable" -test socket_$af-6.3 {writable fileevent on server socket} -setup { +test socket_$af-6.3 {writable chan event on server socket} -setup { set sock [socket -server dummy 0] } -constraints [list socket supported_$af] -body { - fileevent $sock writable dummy + chan event $sock writable dummy } -cleanup { close $sock } -returnCodes 1 -result "channel is not writable" @@ -859,7 +863,7 @@ test socket_$af-7.1 {testing socket specific options} -setup { set x done } puts ready - puts [lindex [fconfigure $ss -sockname] 2] + puts [lindex [chan configure $ss -sockname] 2] set timer [after 10000 "set x timed_out"] vwait x after cancel $timer @@ -871,7 +875,7 @@ test socket_$af-7.1 {testing socket specific options} -setup { set l "" } -constraints [list socket supported_$af stdio] -body { set s [socket $localhost $listen] - set p [fconfigure $s -peername] + set p [chan configure $s -peername] close $s lappend l [string compare [lindex $p 0] $localhost] lappend l [string compare [lindex $p 2] $listen] @@ -890,7 +894,7 @@ test socket_$af-7.2 {testing socket specific options} -setup { set x done } puts ready - puts [lindex [fconfigure $ss -sockname] 2] + puts [lindex [chan configure $ss -sockname] 2] set timer [after 10000 "set x timed_out"] vwait x after cancel $timer @@ -901,7 +905,7 @@ test socket_$af-7.2 {testing socket specific options} -setup { gets $f listen } -constraints [list socket supported_$af stdio] -body { set s [socket $localhost $listen] - set p [fconfigure $s -sockname] + set p [chan configure $s -sockname] close $s list [llength $p] \ [regexp {^(127\.0\.0\.1|0\.0\.0\.0|::1)$} [lindex $p 0]] \ @@ -911,7 +915,7 @@ test socket_$af-7.2 {testing socket specific options} -setup { } -result {3 1 0} test socket_$af-7.3 {testing socket specific options} -constraints [list socket supported_$af] -body { set s [socket -server accept -myaddr $localhost 0] - set l [fconfigure $s] + set l [chan configure $s] close $s update llength $l @@ -923,10 +927,10 @@ test socket_$af-7.4 {testing socket specific options} -constraints [list socket set s [socket -server accept -myaddr $localhost 0] proc accept {s a p} { global x - set x [fconfigure $s -sockname] + set x [chan configure $s -sockname] close $s } - set listen [lindex [fconfigure $s -sockname] 2] + set listen [lindex [chan configure $s -sockname] 2] set s1 [socket $localhost $listen] vwait x lappend l [expr {[lindex $x 2] == $listen}] [llength $x] @@ -942,10 +946,10 @@ test socket_$af-7.5 {testing socket specific options} -setup { set s [socket -server accept 0] proc accept {s a p} { global x - set x [fconfigure $s -sockname] + set x [chan configure $s -sockname] close $s } - set listen [lindex [fconfigure $s -sockname] 2] + set listen [lindex [chan configure $s -sockname] 2] set s1 [socket $localhost $listen] vwait x lappend l [lindex $x 0] [expr {[lindex $x 2] == $listen}] [llength $x] @@ -977,7 +981,7 @@ test socket_$af-8.1 {testing -async flag on sockets} -constraints [list socket s close $s set x done } - set s1 [socket -async $localhost [lindex [fconfigure $s -sockname] 2]] + set s1 [socket -async $localhost [lindex [chan configure $s -sockname] 2]] vwait x gets $s1 } -cleanup { @@ -1006,11 +1010,11 @@ test socket_$af-9.1 {testing spurious events} -constraints [list socket supporte } } proc accept {s a p} { - fconfigure $s -buffering none -blocking off - fileevent $s readable [list readlittle $s] + chan configure $s -buffering none -blocking off + chan event $s readable [list readlittle $s] } set s [socket -server accept -myaddr $localhost 0] - set c [socket $localhost [lindex [fconfigure $s -sockname] 2]] + set c [socket $localhost [lindex [chan configure $s -sockname] 2]] puts -nonewline $c 01234567890123456789012345678901234567890123456789 close $c vwait done @@ -1019,7 +1023,7 @@ test socket_$af-9.1 {testing spurious events} -constraints [list socket supporte } -cleanup { after cancel $timer } -result {0 50} -test socket_$af-9.2 {testing async write, fileevents, flush on close} -constraints [list socket supported_$af] -setup { +test socket_$af-9.2 {testing async write, chan events, flush on close} -constraints [list socket supported_$af] -setup { set firstblock "" for {set i 0} {$i < 5} {incr i} {set firstblock "a$firstblock$firstblock"} set secondblock "" @@ -1029,13 +1033,13 @@ test socket_$af-9.2 {testing async write, fileevents, flush on close} -constrain set timer [after 10000 "set done timed_out"] set l [socket -server accept -myaddr $localhost 0] proc accept {s a p} { - fconfigure $s -blocking 0 -translation lf -buffersize 16384 \ + chan configure $s -blocking 0 -translation lf -buffersize 16384 \ -buffering line - fileevent $s readable "readable $s" + chan event $s readable "readable $s" } proc readable {s} { set l [gets $s] - fileevent $s readable {} + chan event $s readable {} after idle respond $s } proc respond {s} { @@ -1049,8 +1053,8 @@ test socket_$af-9.2 {testing async write, fileevents, flush on close} -constrain close $s } } -body { - set s [socket $localhost [lindex [fconfigure $l -sockname] 2]] - fconfigure $s -blocking 0 -trans lf -buffering line + set s [socket $localhost [lindex [chan configure $l -sockname] 2]] + chan configure $s -blocking 0 -trans lf -buffering line set count 0 puts $s hello proc readit {s} { @@ -1062,7 +1066,7 @@ test socket_$af-9.2 {testing async write, fileevents, flush on close} -constrain set done 1 } } - fileevent $s readable "readit $s" + chan event $s readable "readit $s" vwait done return $count } -cleanup { @@ -1073,12 +1077,12 @@ test socket_$af-9.3 {testing EOF stickyness} -constraints [list socket supported set count 0 set done false proc write_then_close {s} { - puts $s bye - close $s + chan puts $s bye + chan close $s } proc accept {s a p} { - fconfigure $s -buffering line -translation lf - fileevent $s writable "write_then_close $s" + chan configure $s -buffering line -translation lf + chan event $s writable "write_then_close $s" } set s [socket -server accept -myaddr $localhost 0] } -body { @@ -1100,9 +1104,9 @@ test socket_$af-9.3 {testing EOF stickyness} -constraints [list socket supported set count {timer went off, eof is not sticky} close $s } - set c [socket $localhost [lindex [fconfigure $s -sockname] 2]] - fconfigure $c -blocking off -buffering line -translation lf - fileevent $c readable "count_to_eof $c" + set c [socket $localhost [lindex [chan configure $s -sockname] 2]] + chan configure $c -blocking off -buffering line -translation lf + chan event $c readable "count_to_eof $c" set timer [after 1000 timerproc $c] vwait done return $count @@ -1124,7 +1128,7 @@ test socket_$af-10.1 {testing socket accept callback error handling} \ } -body { set s [socket -server accept -myaddr $localhost 0] proc accept {s a p} {close $s; error} - set c [socket $localhost [lindex [fconfigure $s -sockname] 2]] + set c [socket $localhost [lindex [chan configure $s -sockname] 2]] vwait goterror close $s close $c @@ -1162,7 +1166,7 @@ test socket_$af-11.2 {client specifies its port} -setup { } -constraints [list socket supported_$af doTestsWithRemoteServer] -body { set s [socket -myport $lport $remoteServerIP $rport] set r [gets $s] - expr {$r==$lport ? "ok" : "broken: $r != $port"} + expr {($r == $lport) ? "ok" : "broken: $r != $port"} } -cleanup { close $s sendCommand {close $server} @@ -1181,8 +1185,8 @@ test socket_$af-11.4 {remote echo, one line} -setup { set port [sendCommand { set server [socket -server accept 0] proc accept {s a p} { - fileevent $s readable [list echo $s] - fconfigure $s -buffering line -translation crlf + chan event $s readable [list echo $s] + chan configure $s -buffering line -translation crlf } proc echo {s} { set l [gets $s] @@ -1196,7 +1200,7 @@ test socket_$af-11.4 {remote echo, one line} -setup { }] } -constraints [list socket supported_$af doTestsWithRemoteServer] -body { set f [socket $remoteServerIP $port] - fconfigure $f -translation crlf -buffering line + chan configure $f -translation crlf -buffering line puts $f hello gets $f } -cleanup { @@ -1207,8 +1211,8 @@ test socket_$af-11.5 {remote echo, 50 lines} -setup { set port [sendCommand { set server [socket -server accept 0] proc accept {s a p} { - fileevent $s readable [list echo $s] - fconfigure $s -buffering line -translation crlf + chan event $s readable [list echo $s] + chan configure $s -buffering line -translation crlf } proc echo {s} { set l [gets $s] @@ -1222,10 +1226,10 @@ test socket_$af-11.5 {remote echo, 50 lines} -setup { }] } -constraints [list socket supported_$af doTestsWithRemoteServer] -body { set f [socket $remoteServerIP $port] - fconfigure $f -translation crlf -buffering line + chan configure $f -translation crlf -buffering line for {set cnt 0} {$cnt < 50} {incr cnt} { puts $f "hello, $cnt" - if {[gets $f] != "hello, $cnt"} { + if {[gets $f] ne "hello, $cnt"} { break } } @@ -1246,8 +1250,8 @@ test socket_$af-11.7 {server with several clients} -setup { set port [sendCommand { set server [socket -server accept 0] proc accept {s a p} { - fconfigure $s -buffering line - fileevent $s readable [list echo $s] + chan configure $s -buffering line + chan event $s readable [list echo $s] } proc echo {s} { set l [gets $s] @@ -1261,11 +1265,11 @@ test socket_$af-11.7 {server with several clients} -setup { }] } -constraints [list socket supported_$af doTestsWithRemoteServer] -body { set s1 [socket $remoteServerIP $port] - fconfigure $s1 -buffering line + chan configure $s1 -buffering line set s2 [socket $remoteServerIP $port] - fconfigure $s2 -buffering line + chan configure $s2 -buffering line set s3 [socket $remoteServerIP $port] - fconfigure $s3 -buffering line + chan configure $s3 -buffering line for {set i 0} {$i < 100} {incr i} { puts $s1 hello,s1 gets $s1 @@ -1321,11 +1325,11 @@ test socket_$af-11.9 {accept callback error} -constraints [list socket supported sendCommand "set port [getPort $s]" if {[catch { sendCommand { - set peername [fconfigure $callerSocket -peername] + set peername [chan configure $callerSocket -peername] set s [socket [lindex $peername 0] $port] close $s } - } msg]} then { + } msg]} { close $s error $msg } @@ -1344,8 +1348,8 @@ test socket_$af-11.10 {testing socket specific options} -setup { }] } -constraints [list socket supported_$af doTestsWithRemoteServer] -body { set s [socket $remoteServerIP $port] - set p [fconfigure $s -peername] - set n [fconfigure $s -sockname] + set p [chan configure $s -peername] + set n [chan configure $s -sockname] list [expr {[lindex $p 2] == $port}] [llength $p] [llength $n] } -cleanup { close $s @@ -1355,7 +1359,7 @@ test socket_$af-11.11 {testing spurious events} -setup { set port [sendCommand { set server [socket -server accept 0] proc accept {s a p} { - fconfigure $s -translation "auto lf" + chan configure $s -translation "auto lf" after idle writesome $s } proc writesome {s} { @@ -1386,7 +1390,7 @@ test socket_$af-11.11 {testing spurious events} -setup { } } set c [socket $remoteServerIP $port] - fileevent $c readable "readlittle $c" + chan event $c readable "readlittle $c" vwait done list $spurious $len $done } -cleanup { @@ -1422,7 +1426,7 @@ test socket_$af-11.12 {testing EOF stickyness} -constraints [list socket support } } set c [socket $remoteServerIP $port] - fileevent $c readable [list count_up $c] + chan event $c readable [list count_up $c] vwait done return $done } -cleanup { @@ -1441,13 +1445,13 @@ test socket_$af-11.13 {testing async write, async flush, async close} -setup { } set l [socket -server accept 0] proc accept {s a p} { - fconfigure $s -blocking 0 -translation lf -buffersize 16384 \ + chan configure $s -blocking 0 -translation lf -buffersize 16384 \ -buffering line - fileevent $s readable "readable $s" + chan event $s readable "readable $s" } proc readable {s} { set l [gets $s] - fileevent $s readable {} + chan event $s readable {} after idle respond $s } proc respond {s} { @@ -1474,10 +1478,10 @@ test socket_$af-11.13 {testing async write, async flush, async close} -setup { } } set s [socket $remoteServerIP $port] - fconfigure $s -blocking 0 -trans lf -buffering line + chan configure $s -blocking 0 -trans lf -buffering line set count 0 puts $s hello - fileevent $s readable "readit $s" + chan event $s readable "readit $s" vwait done return $count } -cleanup { @@ -1495,7 +1499,7 @@ test socket_$af-12.1 {testing inheritance of server sockets} -setup { # will be held open for 10 seconds set f [open $path(script1) w] puts $f { - fileevent stdin readable exit + chan event stdin readable exit after 10000 exit vwait forever } @@ -1512,7 +1516,7 @@ test socket_$af-12.1 {testing inheritance of server sockets} -setup { close $file } exec $tcltest $delay & - puts [lindex [fconfigure $f -sockname] 2] + puts [lindex [chan configure $f -sockname] 2] close $f exit } @@ -1537,7 +1541,7 @@ test socket_$af-12.2 {testing inheritance of client sockets} -setup { # will be held open for 20 seconds set f [open $path(script1) w] puts $f { - fileevent stdin readable exit + chan event stdin readable exit after 20000 exit vwait forever } @@ -1569,8 +1573,8 @@ test socket_$af-12.2 {testing inheritance of client sockets} -setup { # When the client connects, establish the read handler global server close $server - fileevent $file readable [list getdata $file] - fconfigure $file -buffering line -blocking 0 + chan event $file readable [list getdata $file] + chan configure $file -buffering line -blocking 0 } proc getdata { file } { # Read handler on the accepted socket. @@ -1580,7 +1584,7 @@ test socket_$af-12.2 {testing inheritance of client sockets} -setup { set x {read failed, error was $data} catch { close $file } } elseif {$data ne ""} { - } elseif {[fblocked $file]} { + } elseif {[chan blocked $file]} { } elseif {[eof $file]} { if {$failed} { set x {client socket was inherited} @@ -1596,7 +1600,7 @@ test socket_$af-12.2 {testing inheritance of client sockets} -setup { # Launch the script2 process ### exec [interpreter] script2 & set p [open "|[list [interpreter] $path(script2)]" w] - puts $p [lindex [fconfigure $server -sockname] 2] ; flush $p + puts $p [lindex [chan configure $server -sockname] 2] ; flush $p vwait x return $x } -cleanup { @@ -1608,7 +1612,7 @@ test socket_$af-12.3 {testing inheritance of accepted sockets} -setup { file delete $path(script2) set f [open $path(script1) w] puts $f { - fileevent stdin readable exit + chan event stdin readable exit after 10000 exit vwait forever } @@ -1625,7 +1629,7 @@ test socket_$af-12.3 {testing inheritance of accepted sockets} -setup { exec $tcltest $delay & after idle exit } - puts stdout [lindex [fconfigure $server -sockname] 2] + puts stdout [lindex [chan configure $server -sockname] 2] vwait forever } close $f @@ -1636,8 +1640,8 @@ test socket_$af-12.3 {testing inheritance of accepted sockets} -setup { set p [open "|[list [interpreter] $path(script2)]" r] gets $p listen set f [socket $localhost $listen] - fconfigure $f -buffering full -blocking 0 - fileevent $f readable [list getdata $f] + chan configure $f -buffering full -blocking 0 + chan event $f readable [list getdata $f] # If the socket is still open after 5 seconds, the script1 process must # have inherited the accepted socket. set failed 0 @@ -1650,9 +1654,9 @@ test socket_$af-12.3 {testing inheritance of accepted sockets} -setup { if {$status != 0} { set x {read failed, error was $data} catch { close $file } - } elseif {[string compare {} $data]} { - } elseif {[fblocked $file]} { - } elseif {[eof $file]} { + } elseif {[string compare "" $data]} { + } elseif {[chan blocked $file]} { + } elseif {[chan eof $file]} { if {$failed} { set x {accepted socket was inherited} } else { @@ -1676,10 +1680,10 @@ test socket_$af-13.1 {Testing use of shared socket between two threads} -body { # create a thread set serverthread [thread::create -preserved [string map [list @localhost@ $localhost] { set f [socket -server accept -myaddr @localhost@ 0] - set listen [lindex [fconfigure $f -sockname] 2] + set listen [lindex [chan configure $f -sockname] 2] proc accept {s a p} { - fileevent $s readable [list echo $s] - fconfigure $s -buffering line + chan event $s readable [list echo $s] + chan configure $s -buffering line } proc echo {s} { global i @@ -1700,7 +1704,7 @@ test socket_$af-13.1 {Testing use of shared socket between two threads} -body { }]] set port [thread::send $serverthread {set listen}] set s [socket $localhost $port] - fconfigure $s -buffering line + chan configure $s -buffering line catch { puts $s "hello" gets $s result @@ -1733,10 +1737,10 @@ test socket-14.0 {[socket -async] when server only listens on IPv4} \ set x ok } set server [socket -server accept -myaddr 127.0.0.1 0] - set port [lindex [fconfigure $server -sockname] 2] + set port [lindex [chan configure $server -sockname] 2] } -body { set client [socket -async localhost $port] - set after [after 1000 {set x [fconfigure $client -error]}] + set after [after 1000 {set x [chan configure $client -error]}] vwait x set x } -cleanup { @@ -1745,7 +1749,7 @@ test socket-14.0 {[socket -async] when server only listens on IPv4} \ close $client unset x } -result ok -test socket-14.1 {[socket -async] fileevent while still connecting} \ +test socket-14.1 {[socket -async] chan event while still connecting} \ -constraints [list socket supported_any] \ -setup { proc accept {s a p} { @@ -1755,13 +1759,13 @@ test socket-14.1 {[socket -async] fileevent while still connecting} \ lappend x ok } set server [socket -server accept -myaddr localhost 0] - set port [lindex [fconfigure $server -sockname] 2] + set port [lindex [chan configure $server -sockname] 2] set x "" } -body { set client [socket -async localhost $port] - fileevent $client writable { - lappend x [fconfigure $client -error] - fileevent $client writable {} + chan event $client writable { + lappend x [chan configure $client -error] + chan event $client writable {} } set after [after 1000 {lappend x timeout}] while {[llength $x] < 2 && "timeout" ni $x} { @@ -1774,18 +1778,18 @@ test socket-14.1 {[socket -async] fileevent while still connecting} \ close $client unset x } -result {{} ok} -test socket-14.2 {[socket -async] fileevent connection refused} \ +test socket-14.2 {[socket -async] chan event connection refused} \ -constraints [list socket supported_any] \ -body { if {[catch {socket -async localhost [randport]} client]} { regexp {[^:]*: (.*)} $client -> x } else { - fileevent $client writable {set x [fconfigure $client -error]} + chan event $client writable {set x [chan configure $client -error]} set after [after 1000 {set x timeout}] vwait x after cancel $after if {$x eq "timeout"} { - append x ": [fconfigure $client -error]" + append x ": [chan configure $client -error]" } close $client } @@ -1803,10 +1807,10 @@ test socket-14.3 {[socket -async] when server only listens on IPv6} \ set x ok } set server [socket -server accept -myaddr ::1 0] - set port [lindex [fconfigure $server -sockname] 2] + set port [lindex [chan configure $server -sockname] 2] } -body { set client [socket -async localhost $port] - set after [after 1000 {set x [fconfigure $client -error]}] + set after [after 1000 {set x [chan configure $client -error]}] vwait x set x } -cleanup { @@ -1815,7 +1819,7 @@ test socket-14.3 {[socket -async] when server only listens on IPv6} \ close $client unset x } -result ok -test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \ +test socket-14.4 {[socket -async] and both, readdable and writable chan events} \ -constraints [list socket supported_any] \ -setup { proc accept {s a p} { @@ -1823,17 +1827,17 @@ test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \ close $s } set server [socket -server accept -myaddr localhost 0] - set port [lindex [fconfigure $server -sockname] 2] + set port [lindex [chan configure $server -sockname] 2] set x "" } -body { set client [socket -async localhost $port] - fileevent $client writable { - lappend x [fconfigure $client -error] - fileevent $client writable {} + chan event $client writable { + lappend x [chan configure $client -error] + chan event $client writable "" } - fileevent $client readable {lappend x [gets $client]} + chan event $client readable {lappend x [gets $client]} set after [after 1000 {lappend x timeout}] - while {[llength $x] < 2 && "timeout" ni $x} { + while {([llength $x] < 2) && ("timeout" ni $x)} { vwait x } lsort $x diff --git a/tests/source.test b/tests/source.test index d71212d..eaf8a22 100644 --- a/tests/source.test +++ b/tests/source.test @@ -45,7 +45,7 @@ test source-1.2 {source command} -setup { test source-1.3 {source command} -setup { set sourcefile [makeFile {} source.file] set fd [open $sourcefile w] - fconfigure $fd -translation lf + chan configure $fd -translation lf puts $fd "list a b c \\" puts $fd "d e f" close $fd @@ -111,7 +111,7 @@ test source-2.7 {utf-8 with BOM} -setup { set sourcefile [makeFile {} source.file] } -body { set out [open $sourcefile w] - fconfigure $out -encoding utf-8 + chan configure $out -encoding utf-8 puts $out "\ufeffset y new-y" close $out set y old-y @@ -212,7 +212,7 @@ test source-7.1 {source -encoding test} -setup { set sourcefile [makeFile {} source.file] file delete $sourcefile set f [open $sourcefile w] - fconfigure $f -encoding utf-8 + chan configure $f -encoding utf-8 puts $f "set symbol(square-root) \u221A; set x correct" close $f } -body { @@ -231,7 +231,7 @@ test source-7.2 {source -encoding test} -setup { set sourcefile [makeFile {} source.file] file delete $sourcefile set f [open $sourcefile w] - fconfigure $f -encoding unicode + chan configure $f -encoding unicode puts $f "set symbol(square-root) \u221A; set x correct" close $f } -body { @@ -256,7 +256,7 @@ test source-7.5 {source -encoding: correct operation} -setup { set sourcefile [makeFile {} source.file] file delete $sourcefile set f [open $sourcefile w] - fconfigure $f -encoding utf-8 + chan configure $f -encoding utf-8 puts $f "proc \u20ac {} {return foo}" close $f } -body { @@ -270,7 +270,7 @@ test source-7.6 {source -encoding: mismatch encoding error} -setup { set sourcefile [makeFile {} source.file] file delete $sourcefile set f [open $sourcefile w] - fconfigure $f -encoding utf-8 + chan configure $f -encoding utf-8 puts $f "proc \u20ac {} {return foo}" close $f } -body { diff --git a/tests/split.test b/tests/split.test index 778131f..65202bd 100644 --- a/tests/split.test +++ b/tests/split.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } diff --git a/tests/string.test b/tests/string.test index f558d30..2f78242 100644 --- a/tests/string.test +++ b/tests/string.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -22,8 +22,8 @@ catch [list package require -exact Tcltest [info patchlevel]] # Some tests require the testobj command -testConstraint testobj [expr {[info commands testobj] != {}}] -testConstraint testindexobj [expr {[info commands testindexobj] != {}}] +testConstraint testobj [expr {[info commands testobj] ne ""}] +testConstraint testindexobj [expr {[info commands testindexobj] ne ""}] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] @@ -291,14 +291,13 @@ test string-5.20 {string index, bytearray object out of bounds} { string index [binary format I* {0x50515253 0x52}] 20 } {} - proc largest_int {} { # This will give us what the largest valid int on this machine is, # so we can test for overflow properly below on >32 bit systems set int 1 set exp 7; # assume we get at least 8 bits - while {wide($int) > 0} { set int [expr {wide(1) << [incr exp]}] } - return [expr {$int-1}] + while { ( wide ($int) ) > 0} { set int [expr { ( wide (1) ) << [incr exp]}] } + return [expr {$int - 1}] } test string-6.1 {string is, too few args} { @@ -326,7 +325,7 @@ test string-6.8 {string is, error in var} { list [string is alpha -failindex var abc5def] $var } {0 3} test string-6.9 {string is, var shouldn't get set} { - catch {unset var} + unset -nocomplain var list [catch {string is alpha -failindex var abc; set var} msg] $msg } {1 {can't read "var": no such variable}} test string-6.10 {string is, ok on empty} { @@ -444,11 +443,11 @@ test string-6.45 {string is false, false} { list [string is false -fail var abc] $var } {0 0} test string-6.46 {string is false, false} { - catch {unset var} + unset -nocomplain var list [string is false -fail var Y] $var } {0 0} test string-6.47 {string is false, false} { - catch {unset var} + unset -nocomplain var list [string is false -fail var offensive] $var } {0 0} test string-6.48 {string is integer, true} { @@ -530,11 +529,11 @@ test string-6.72 {string is true, false} { list [string is true -fail var onto] $var } {0 0} test string-6.73 {string is true, false} { - catch {unset var} + unset -nocomplain var list [string is true -fail var 25] $var } {0 0} test string-6.74 {string is true, false} { - catch {unset var} + unset -nocomplain var list [string is true -fail var no] $var } {0 0} test string-6.75 {string is upper, true} { diff --git a/tests/stringComp.test b/tests/stringComp.test index 9e00ce7..2a92e59 100644 --- a/tests/stringComp.test +++ b/tests/stringComp.test @@ -15,7 +15,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -39,7 +39,7 @@ test stringComp-1.3 {error condition - undefined method during compile} { # We don't want this to complain about 'never' because it may never # be called, or string may get redefined. This must compile OK. proc foo {str i} { - if {"yes" == "no"} { string never called but complains here } + if {"yes" eq "no"} { string never called but complains here } string index $str $i } foo abc 0 @@ -353,14 +353,13 @@ test stringComp-5.20 {string index, bytearray object out of bounds} { foo } {} - proc largest_int {} { # This will give us what the largest valid int on this machine is, # so we can test for overflow properly below on >32 bit systems set int 1 set exp 7; # assume we get at least 8 bits while {$int > 0} { set int [expr {1 << [incr exp]}] } - return [expr {$int-1}] + return [expr {$int - 1}] } ## string is diff --git a/tests/stringObj.test b/tests/stringObj.test index 6f331d3..0cc2d81 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } diff --git a/tests/subst.test b/tests/subst.test index 4be4798..9df0a1b 100644 --- a/tests/subst.test +++ b/tests/subst.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.1 namespace import -force ::tcltest::* } @@ -55,13 +55,13 @@ test subst-4.2 {variable substitutions} { subst {x$a.y{$a}.z} } {x44.y{44}.z} test subst-4.3 {variable substitutions} -setup { - catch {unset a} + unset -nocomplain a } -body { set a(13) 82 set i 13 subst {x.$a($i)} } -result {x.82} -catch {unset a} +unset -nocomplain a set long {This is a very long string, intentionally made so long that it will overflow the static character size for dstrings, so that additional memory will have to be allocated by subst. That way, @@ -113,7 +113,7 @@ test subst-5.10 {command substitutions} { } {1 {missing close-bracket}} test subst-6.1 {clear the result after command substitution} -body { - catch {unset a} + unset -nocomplain a subst {[concat foo] $a} } -returnCodes error -result {can't read "a": no such variable} @@ -178,7 +178,7 @@ test subst-9.2 {error in a subst} -body { subst {[if 1 { error foo; bogus code}]bar} } -returnCodes error -result foo test subst-9.3 {error in a variable subst} -setup { - catch {unset var} + unset -nocomplain var } -body { subst {foo $var([error foo]) bar} } -returnCodes error -result foo diff --git a/tests/switch.test b/tests/switch.test index a03948b..c384766 100644 --- a/tests/switch.test +++ b/tests/switch.test @@ -327,14 +327,70 @@ test switch-10.5 {compiled -exact switch} { } 1 test switch-10.6 {compiled -exact switch} { if 1 {switch -exact -- b {a { - set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1 - set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1 - set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1 - set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1 - set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1 - set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1 - set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1 - set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 } b {subst 2}}} } 2 @@ -342,118 +398,146 @@ test switch-10.6 {compiled -exact switch} { # c* are compiled switches, i* are interpreted # *-glob use glob matching, *-exact use exact matching # *2* include a default clause (different results too.) -proc cswtest-glob s { - set x 0; set y 0 - foreach c [split $s {}] { - switch -glob $c { +proc cswtest-glob {s} { + set x 0 + set y 0 + foreach c [split $s ""] { + switch -glob -- $c { a {incr x} b {incr y} } } - set x [expr {$x*100}]; set y [expr {$y*100}] - foreach c [split $s {}] { + set x [expr {$x * 100}] + set y [expr {$y * 100}] + foreach c [split $s ""] { switch -glob -- $c a {incr x} b {incr y} } return $x,$y } -proc iswtest-glob s { - set x 0; set y 0; set switch switch - foreach c [split $s {}] { - $switch -glob $c { +proc iswtest-glob {s} { + set x 0 + set y 0 + set switch switch + foreach c [split $s ""] { + $switch -glob -- $c { a {incr x} b {incr y} } } - set x [expr {$x*100}]; set y [expr {$y*100}] - foreach c [split $s {}] { + set x [expr {$x * 100}] + set y [expr {$y * 100}] + foreach c [split $s ""] { $switch -glob -- $c a {incr x} b {incr y} } return $x,$y } -proc cswtest-exact s { - set x 0; set y 0 - foreach c [split $s {}] { - switch -exact $c { +proc cswtest-exact {s} { + set x 0 + set y 0 + foreach c [split $s ""] { + switch -exact -- $c { a {incr x} b {incr y} } } - set x [expr {$x*100}]; set y [expr {$y*100}] + set x [expr {$x * 100}] + set y [expr {$y * 100}] foreach c [split $s {}] { switch -exact -- $c a {incr x} b {incr y} } return $x,$y } -proc iswtest-exact s { - set x 0; set y 0; set switch switch - foreach c [split $s {}] { - $switch -exact $c { +proc iswtest-exact {s} { + set x 0 + set y 0 + set switch switch + foreach c [split $s ""] { + $switch -exact -- $c { a {incr x} b {incr y} } } - set x [expr {$x*100}]; set y [expr {$y*100}] - foreach c [split $s {}] { + set x [expr {$x * 100}] + set y [expr {$y * 100}] + foreach c [split $s ""] { $switch -exact -- $c a {incr x} b {incr y} } return $x,$y } -proc cswtest2-glob s { - set x 0; set y 0; set z 0 - foreach c [split $s {}] { - switch -glob $c { +proc cswtest2-glob {s} { + set x 0 + set y 0 + set z 0 + foreach c [split $s ""] { + switch -glob -- $c { a {incr x} b {incr y} default {incr z} } } - set x [expr {$x*100}]; set y [expr {$y*100}]; set z [expr {$z*100}] - foreach c [split $s {}] { + set x [expr {$x * 100}] + set y [expr {$y * 100}] + set z [expr {$z * 100}] + foreach c [split $s ""] { switch -glob -- $c a {incr x} b {incr y} default {incr z} } return $x,$y,$z } -proc iswtest2-glob s { - set x 0; set y 0; set z 0; set switch switch - foreach c [split $s {}] { - $switch -glob $c { +proc iswtest2-glob {s} { + set x 0 + set y 0 + set z 0 + set switch switch + foreach c [split $s ""] { + $switch -glob -- $c { a {incr x} b {incr y} default {incr z} } } - set x [expr {$x*100}]; set y [expr {$y*100}]; set z [expr {$z*100}] - foreach c [split $s {}] { + set x [expr {$x * 100}] + set y [expr {$y * 100}] + set z [expr {$z * 100}] + foreach c [split $s ""] { $switch -glob -- $c a {incr x} b {incr y} default {incr z} } return $x,$y,$z } -proc cswtest2-exact s { - set x 0; set y 0; set z 0 - foreach c [split $s {}] { - switch -exact $c { +proc cswtest2-exact {s} { + set x 0 + set y 0 + set z 0 + foreach c [split $s ""] { + switch -exact -- $c { a {incr x} b {incr y} default {incr z} } } - set x [expr {$x*100}]; set y [expr {$y*100}]; set z [expr {$z*100}] - foreach c [split $s {}] { + set x [expr {$x * 100}] + set y [expr {$y * 100}] + set z [expr {$z * 100}] + foreach c [split $s ""] { switch -exact -- $c a {incr x} b {incr y} default {incr z} } return $x,$y,$z } -proc iswtest2-exact s { - set x 0; set y 0; set z 0; set switch switch - foreach c [split $s {}] { - $switch -exact $c { +proc iswtest2-exact {s} { + set x 0 + set y 0 + set z 0 + set switch switch + foreach c [split $s ""] { + $switch -exact -- $c { a {incr x} b {incr y} default {incr z} } } - set x [expr {$x*100}]; set y [expr {$y*100}]; set z [expr {$z*100}] - foreach c [split $s {}] { + set x [expr {$x * 100}] + set y [expr {$y * 100}] + set z [expr {$z * 100}] + foreach c [split $s ""] { $switch -exact -- $c a {incr x} b {incr y} default {incr z} } return $x,$y,$z diff --git a/tests/tailcall.test b/tests/tailcall.test index 2d04f82..dcbdaa7 100644 --- a/tests/tailcall.test +++ b/tests/tailcall.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -34,9 +34,9 @@ if {[testConstraint testnrelevels]} { proc depthDiff {} { variable last set depth [testnrelevels] - set res {} + set res [list] foreach t $depth l $last { - lappend res [expr {$t-$l}] + lappend res [expr {$t - $l}] } set last $depth return $res @@ -46,7 +46,7 @@ if {[testConstraint testnrelevels]} { namespace import testnre::* } -proc errorcode options { +proc errorcode {options} { dict get [dict merge {-errorcode NONE} $options] -errorcode } @@ -222,7 +222,6 @@ test tailcall-1 {tailcall} -body { namespace delete a b } -result {1::b | 0:: *::a *::b | {{1 ::b::moo} {2 xset}}} - test tailcall-2 {tailcall in non-proc} -body { namespace eval a [list tailcall set x 1] } -match glob -result *tailcall* -returnCodes error @@ -232,7 +231,7 @@ test tailcall-3 {tailcall falls off tebc} -body { proc foo {} {tailcall set x 1} list [catch foo msg] $msg [set x] } -cleanup { - rename foo {} + rename foo "" unset x } -result {0 1 1} diff --git a/tests/timer.test b/tests/timer.test index ab6efc9..45c3a3a 100644 --- a/tests/timer.test +++ b/tests/timer.test @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -466,7 +466,7 @@ test timer-7.5 {GetAfterEvent procedure} -returnCodes error -body { } -result "event \"after#${lastId}x\" doesn't exist" test timer-7.6 {GetAfterEvent procedure} -returnCodes error -body { after info afterx[expr {$lastId+1}] -} -result "event \"afterx[expr {$lastId+1}]\" doesn't exist" +} -result "event \"afterx[expr {$lastId + 1}]\" doesn't exist" after cancel $event test timer-8.1 {AfterProc procedure} { diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test index 2453e01..9b5d305 100644 --- a/tests/unixFCmd.test +++ b/tests/unixFCmd.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -28,10 +28,10 @@ cd [temporaryDirectory] set user {} if {[testConstraint unix]} { catch {set user [exec whoami]} - if {$user == ""} { + if {$user eq ""} { catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} } - if {$user == ""} { + if {$user eq ""} { set user "root" } } @@ -77,9 +77,9 @@ proc cleanup {args} { } foreach file $x { if { - [catch {file delete -force -- $file}] - && [testConstraint testchmod] - } then { + [catch {file delete -force -- $file}] && + [testConstraint testchmod] + } { openup $file file delete -force -- $file } diff --git a/tests/unixFile.test b/tests/unixFile.test index 8147f48..4dd9920 100644 --- a/tests/unixFile.test +++ b/tests/unixFile.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } diff --git a/tests/unixNotfy.test b/tests/unixNotfy.test index 2f03529..a88be90 100644 --- a/tests/unixNotfy.test +++ b/tests/unixNotfy.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -20,8 +20,8 @@ testConstraint noTk [expr {0 != [catch {package present Tk}]}] testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] # Darwin always uses a threaded notifier testConstraint unthreaded [expr { - ![::tcl::pkgconfig get threaded] - && $tcl_platform(os) ne "Darwin" + (![::tcl::pkgconfig get threaded]) && + ($tcl_platform(os) ne "Darwin") }] # The next two tests will hang if threads are enabled because the notifier @@ -30,7 +30,7 @@ testConstraint unthreaded [expr { test unixNotfy-1.1 {Tcl_DeleteFileHandler} -constraints {noTk unix unthreaded} -body { catch {vwait x} set f [open [makeFile "" foo] w] - fileevent $f writable {set x 1} + chan event $f writable {set x 1} vwait x close $f list [catch {vwait x} msg] $msg @@ -42,8 +42,8 @@ test unixNotfy-1.2 {Tcl_DeleteFileHandler} -constraints {noTk unix unthreaded} - catch {vwait x} set f1 [open [makeFile "" foo] w] set f2 [open [makeFile "" foo2] w] - fileevent $f1 writable {set x 1} - fileevent $f2 writable {set y 1} + chan event $f1 writable {set x 1} + chan event $f2 writable {set y 1} vwait x close $f1 vwait y @@ -61,7 +61,7 @@ test unixNotfy-2.1 {Tcl_DeleteFileHandler} \ -body { update set f [open [makeFile "" foo] w] - fileevent $f writable {set x 1} + chan event $f writable {set x 1} vwait x close $f thread::create "thread::send [thread::id] {set x ok}" @@ -79,8 +79,8 @@ test unixNotfy-2.2 {Tcl_DeleteFileHandler} \ update set f1 [open [makeFile "" foo] w] set f2 [open [makeFile "" foo2] w] - fileevent $f1 writable {set x 1} - fileevent $f2 writable {set y 1} + chan event $f1 writable {set x 1} + chan event $f2 writable {set y 1} vwait x close $f1 vwait y diff --git a/tests/unload.test b/tests/unload.test index 5a374c4..56e71cd 100644 --- a/tests/unload.test +++ b/tests/unload.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } diff --git a/tests/uplevel.test b/tests/uplevel.test index 0410469..fa185a5 100644 --- a/tests/uplevel.test +++ b/tests/uplevel.test @@ -11,13 +11,13 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } proc a {x y} { - newset z [expr $x+$y] + newset z [expr {$x + $y}] return $z } proc newset {name value} { @@ -103,7 +103,7 @@ test uplevel-4.4 {error: not enough args} -returnCodes error -body { } -result {wrong # args: should be "uplevel ?level? command ?arg ...?"} proc a2 {} { - uplevel a3 + uplevel 1 a3 } proc a3 {} { global x y @@ -114,11 +114,11 @@ a2 test uplevel-5.1 {info level} {set x} 1 test uplevel-5.2 {info level} {set y} a3 -namespace eval ns1 { - proc set args {return ::ns1} +namespace eval {ns1} { + proc set {args} {return ::ns1} } proc a2 {} { - uplevel {set x ::} + uplevel 1 {set x ::} } test uplevel-6.1 {uplevel and shadowed cmds} { set res [namespace eval ns1 a2] diff --git a/tests/upvar.test b/tests/upvar.test index e2c9ffd..0087c62 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -83,8 +83,7 @@ test upvar-2.2 {writing variables with upvar} { list $x1 $x2 } {newbits morebits} test upvar-2.3 {writing variables with upvar} { - catch {unset x1} - catch {unset x2} + unset -nocomplain x1 x2 proc p1 {x1 x2} { upvar #0 x1 a upvar x2 b @@ -156,11 +155,15 @@ test upvar-3.6 {unsetting then resetting array elements with upvar} { set a(0) zeroth set a(1) first set a(2) second - p2 + p2 list [lsort [array names a]] [catch {set a(0)} msg] $msg } - proc p2 {} {upvar a(0) x; unset x; set x 12345} - p1 + proc p2 {} { + upvar a(0) x + unset x + set x 12345 + } + p1 } {{0 1 2} 0 12345} test upvar-4.1 {nested upvars} { @@ -185,10 +188,21 @@ test upvar-4.2 {nested upvars} { list [p1 14 15] $x1 } {{14 15 bar 33} foo} -proc tproc {args} {global x; set x [list $args [uplevel info vars]]} +proc tproc {args} { + global x + set x [list $args [uplevel 1 info vars]] +} test upvar-5.1 {traces involving upvars} { - proc p1 {a b} {set c 22; set d 33; trace var c rw tproc; p2} - proc p2 {} {upvar c x1; set x1 22} + proc p1 {a b} { + set c 22 + set d 33 + trace var c rw tproc + p2 + } + proc p2 {} { + upvar 1 c x1 + set x1 22 + } set x --- p1 foo bar set x @@ -252,7 +266,7 @@ test upvar-6.3 {retargeting an upvar} { test upvar-7.1 {upvar to same level} { set x 44 set y 55 - catch {unset uv} + unset -nocomplain uv upvar #0 x uv set uv abc upvar 0 y uv @@ -322,7 +336,7 @@ test upvar-8.7 {errors in upvar command} -returnCodes error -body { } -result {variable "a" has traces: can't use for upvar} test upvar-8.8 {create nested array with upvar} -body { proc p1 {} {upvar x(a) b; set b(2) 44} - catch {unset x} + unset -nocomplain x p1 } -returnCodes error -cleanup { unset x @@ -341,13 +355,13 @@ test upvar-8.9 {upvar won't create namespace variable that refers to procedure v MakeLink 1 } -result {bad variable name "a": upvar won't create namespace variable that refers to procedure variable} test upvar-8.10 {upvar will create element alias for new array element} -setup { - catch {unset upvarArray} + unset -nocomplain upvarArray } -body { array set upvarArray {} catch {upvar 0 upvarArray(elem) upvarArrayElemAlias} } -result {0} test upvar-8.11 {upvar will not create a variable that looks like an array} -setup { - catch {unset upvarArray} + unset -nocomplain upvarArray } -body { array set upvarArray {} upvar 0 upvarArray(elem) upvarArrayElemAlias(elem) @@ -357,8 +371,7 @@ test upvar-9.1 {Tcl_UpVar2 procedure} testupvar { list [catch {testupvar xyz a {} x global} msg] $msg } {1 {bad level "xyz"}} test upvar-9.2 {Tcl_UpVar2 procedure} testupvar { - catch {unset a} - catch {unset x} + unset -nocomplain a x set a 44 list [catch "testupvar #0 a 1 x global" msg] $msg } {1 {can't access "a(1)": variable isn't array}} @@ -367,8 +380,7 @@ test upvar-9.3 {Tcl_UpVar2 procedure} testupvar { testupvar 1 a {} x local set x } - catch {unset a} - catch {unset x} + unset -nocomplain a x set a 44 foo } {44} @@ -377,8 +389,7 @@ test upvar-9.4 {Tcl_UpVar2 procedure} testupvar { testupvar 1 a {} _up_ global list [catch {set x} msg] $msg } - catch {unset a} - catch {unset _up_} + unset -nocomplain a _up_ set a 44 concat [foo] $_up_ } {1 {can't read "x": no such variable} 44} @@ -387,8 +398,7 @@ test upvar-9.5 {Tcl_UpVar2 procedure} testupvar { testupvar 1 a b x local set x } - catch {unset a} - catch {unset x} + unset -nocomplain a x set a(b) 1234 foo } {1234} @@ -397,8 +407,7 @@ test upvar-9.6 {Tcl_UpVar procedure} testupvar { testupvar 1 a x local set x } - catch {unset a} - catch {unset x} + unset -nocomplain a x set a xyzzy foo } {xyzzy} @@ -407,12 +416,11 @@ test upvar-9.7 {Tcl_UpVar procedure} testupvar { testupvar #0 a(b) x local set x } - catch {unset a} - catch {unset x} + unset -nocomplain a x set a(b) 1234 foo } {1234} -catch {unset a} +unset -nocomplain a # # Tests for 'namespace upvar'. As the implementation is essentially the same as diff --git a/tests/utf.test b/tests/utf.test index c41cfe3..aea9cf6 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -16,7 +16,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] -catch {unset x} +unset -nocomplain x test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} { set x \x01 @@ -120,7 +120,6 @@ test utf-9.2 {Tcl_UtfAtIndex: index > 0} { string range \u4e4e\u25a\xff\u543klmnop 1 5 } "\u25a\xff\u543kl" - test utf-10.1 {Tcl_UtfBackslash: dst == NULL} { set x \n } { diff --git a/tests/util.test b/tests/util.test index 0e50483..0718239 100644 --- a/tests/util.test +++ b/tests/util.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -96,26 +96,26 @@ proc convertDouble { x } { return $result } -proc verdonk_test {sig binexp shouldbe exp} { - regexp {([-+]?)([0-9a-f]+)} $sig -> signum sig +proc verdonk_test {a_sig a_binexp shouldbe exp} { + regexp {([-+]?)([0-9a-f]+)} $a_sig ___ signum sig scan $sig %llx sig - if {$signum eq {-}} { - set signum [expr 1<<63] + if {$signum eq "-"} { + set signum [expr {1 << 63}] } else { set signum 0 } - regexp {E([-+]?[0-9]+)} $binexp -> binexp - set word [expr {$signum | (($binexp + 0x3ff)<<52)|($sig & ~(1<<52))}] + regexp {E([-+]?[0-9]+)} $a_binexp ___ binexp + set word [expr {$signum | (($binexp + 0x3ff) << 52) | ($sig & ( ~ (1 << 52)))}] binary scan [binary format w $word] q double - regexp {([-+])(\d+)_(\d+)\&} $shouldbe -> signum digits1 digits2 - regexp {E([-+]\d+)} $exp -> decexp + regexp {([-+])(\d+)_(\d+)&} $shouldbe ___ signum digits1 digits2 + regexp {E([-+]\d+)} $exp ___ decexp incr decexp [expr {[string length $digits1] - 1}] lassign [testdoubledigits $double [string length $digits1] e] \ outdigits decpt outsign if {[string index $digits2 0] >= 5} { incr digits1 } - if {$outsign != $signum || $outdigits != $digits1 || $decpt != $decexp} { + if {($outsign != $signum) || ($outdigits != $digits1) || ($decpt != $decexp)} { return -code error "result is ${outsign}0.${outdigits}E$decpt\ should be ${signum}0.${digits1}E$decexp" } @@ -2153,8 +2153,8 @@ foreach ::tcl_precision {0 12} { 1.1 for {set e 1} {$e < 17} {incr e} { test util-16.1.$::tcl_precision.$e {shortening of numbers} \ - "expr 11[string repeat 0 [expr {$e-1}]].0" \ - 11[string repeat 0 [expr {$e-1}]].0 + "expr 11[string repeat 0 [expr {$e - 1}]].0" \ + 11[string repeat 0 [expr {$e - 1}]].0 } for {set e 17} {$e < 309} {incr e} { test util-16.1.$::tcl_precision.$e {shortening of numbers} \ diff --git a/tests/var.test b/tests/var.test index ed7e930..e3f2914 100644 --- a/tests/var.test +++ b/tests/var.test @@ -28,15 +28,10 @@ testConstraint testsetnoerr [llength [info commands testsetnoerr]] catch {rename p ""} catch {namespace delete test_ns_var} -catch {unset xx} -catch {unset x} -catch {unset y} -catch {unset i} -catch {unset a} -catch {unset arr} +unset -nocomplain xx x y i a arr test var-1.1 {TclLookupVar, Array handling} -setup { - catch {unset a} + unset -nocomplain a } -body { set x "incr" ;# force no compilation and runtime call to Tcl_IncrCmd set i 10 @@ -84,7 +79,7 @@ test var-1.9 {TclLookupVar, create new namespace var} { } } {hello} test var-1.10 {TclLookupVar, create new namespace var} -setup { - catch {unset y} + unset -nocomplain y } -body { namespace eval test_ns_var { set ::y 789 @@ -102,7 +97,7 @@ test var-1.12 {TclLookupVar, error creating new namespace var} -body { } } -returnCodes error -result {can't set "::test_ns_var::foo::": parent namespace doesn't exist} test var-1.13 {TclLookupVar, new namespace var is created in a particular namespace} { - catch {unset aNeWnAmEiNnS} + unset -nocomplain aNeWnAmEiNnS namespace eval test_ns_var { namespace eval test_ns_var2::test_ns_var3 { set aNeWnAmEiNnS 77777 @@ -184,12 +179,12 @@ test var-1.19 {TclLookupVar, right error message when parsing variable name} -bo } -returnCodes error -result {can't read "thisvar(doesntexist)": no such variable} test var-2.1 {Tcl_LappendObjCmd, create var if new} { - catch {unset x} + unset -nocomplain x lappend x 1 2 } {1 2} test var-3.1 {MakeUpvar, TCL_NAMESPACE_ONLY not specified for other var} -setup { - catch {unset x} + unset -nocomplain x } -body { set x 1997 proc p {} { @@ -200,7 +195,7 @@ test var-3.1 {MakeUpvar, TCL_NAMESPACE_ONLY not specified for other var} -setup } -result {1997} test var-3.2 {MakeUpvar, other var has TCL_NAMESPACE_ONLY specified} { namespace eval test_ns_var { - catch {unset v} + unset -nocomplain v variable v 1998 proc p {} { variable v ;# TCL_NAMESPACE_ONLY specified for other var x @@ -210,7 +205,7 @@ test var-3.2 {MakeUpvar, other var has TCL_NAMESPACE_ONLY specified} { } } {1998} test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} -setup { - catch {unset a} + unset -nocomplain a } -constraints testupvar -body { set a 123321 proc p {} { @@ -220,11 +215,11 @@ test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} -setup { list [p] $xx [set xx 789] $a } -result {{} 123321 789 789} test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} -setup { - catch {unset a} + unset -nocomplain a } -constraints testupvar -body { set a 456 namespace eval test_ns_var { - catch {unset ::test_ns_var::vv} + unset -nocomplain ::test_ns_var::vv proc p {} { # create namespace var vv linked to global a testupvar 1 a {} vv namespace @@ -234,15 +229,14 @@ test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} -setup { list $test_ns_var::vv [set test_ns_var::vv 123] $a } -result {456 123 123} test var-3.5 {MakeUpvar, no call frame so my var will be in global :: ns} -setup { - catch {unset aaaaa} - catch {unset xxxxx} + unset -nocomplain aaaaa xxxxx } -body { set aaaaa 77777 upvar #0 aaaaa xxxxx list [set xxxxx] [set aaaaa] } -result {77777 77777} test var-3.6 {MakeUpvar, active call frame pushed for namespace eval} -setup { - catch {unset a} + unset -nocomplain a } -body { set a 121212 namespace eval test_ns_var { @@ -251,7 +245,7 @@ test var-3.6 {MakeUpvar, active call frame pushed for namespace eval} -setup { } } -result {121212} test var-3.7 {MakeUpvar, my var has ::s} -setup { - catch {unset a} + unset -nocomplain a } -body { set a 789789 upvar #0 a test_ns_var::lnk @@ -260,8 +254,7 @@ test var-3.7 {MakeUpvar, my var has ::s} -setup { } } -result {789789} test var-3.8 {MakeUpvar, my var already exists in global ns} -setup { - catch {unset aaaaa} - catch {unset xxxxx} + unset -nocomplain aaaaa xxxxx } -body { set aaaaa 456654 set xxxxx hello @@ -269,7 +262,7 @@ test var-3.8 {MakeUpvar, my var already exists in global ns} -setup { set xxxxx } -result {hello} test var-3.9 {MakeUpvar, my var has invalid ns name} -setup { - catch {unset aaaaa} + unset -nocomplain aaaaa } -returnCodes error -body { set aaaaa 789789 upvar #0 aaaaa test_ns_fred::lnk @@ -285,14 +278,14 @@ test var-3.10 {MakeUpvar, between namespaces} -body { unset ::aaaaa } -result {1 1} test var-3.11 {MakeUpvar, my var looks like array elem} -setup { - catch {unset aaaaa} + unset -nocomplain aaaaa } -returnCodes error -body { set aaaaa 789789 upvar #0 aaaaa foo(bar) } -result {bad variable name "foo(bar)": upvar won't create a scalar variable that looks like an array element} test var-4.1 {Tcl_GetVariableName, global variable} testgetvarfullname { - catch {unset a} + unset -nocomplain a set a 123 testgetvarfullname a global } ::a @@ -303,14 +296,14 @@ test var-4.2 {Tcl_GetVariableName, namespace variable} testgetvarfullname { } } ::test_ns_var::george test var-4.3 {Tcl_GetVariableName, variable can't be array element} -setup { - catch {unset a} + unset -nocomplain a } -constraints testgetvarfullname -body { set a(1) foo testgetvarfullname a(1) global } -returnCodes error -result {unknown variable "a(1)"} test var-5.1 {Tcl_GetVariableFullName, global variable} -setup { - catch {unset a} + unset -nocomplain a } -body { set a bar namespace which -variable a @@ -403,9 +396,7 @@ test var-7.4 {Tcl_VariableObjCmd, list of vars} { [namespace eval test_ns_var {expr $three+$four}] } [list [lsort {::test_ns_var::four ::test_ns_var::three ::test_ns_var::two ::test_ns_var::one}] 7] test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} -setup { - catch {unset a} - catch {unset five} - catch {unset six} + unset -nocomplain a five six } -body { set a "" set five 555 @@ -417,18 +408,17 @@ test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} -setup { lappend a $test_ns_var::five \ [set test_ns_var::six 6] [set test_ns_var::six] $six } -cleanup { - catch {unset five} - catch {unset six} + unset -nocomplain five six } -result {5 5 6 6 666} test var-7.6 {Tcl_VariableObjCmd, variable name can be qualified} -setup { - catch {unset newvar} + unset -nocomplain newvar } -body { namespace eval test_ns_var { variable ::newvar cheers! } return $newvar } -cleanup { - catch {unset newvar} + unset -nocomplain newvar } -result {cheers!} test var-7.7 {Tcl_VariableObjCmd, bad var name} -returnCodes error -body { namespace eval test_ns_var { @@ -532,7 +522,7 @@ test var-7.17 {Tcl_VariableObjCmd, no args (TIP 323)} { test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var names} -setup { catch {namespace delete test_ns_var} - catch {unset a} + unset -nocomplain a } -body { namespace eval test_ns_var { variable v 123 @@ -547,7 +537,7 @@ test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var } -result {{} {test_ns_var::v {} u}} test var-8.2 {TclDeleteNamespaceVars, "unset" traces on ns delete are called with fully-qualified var names} -setup { catch {namespace delete test_ns_var} - catch {unset a} + unset -nocomplain a } -body { set info "" namespace eval test_ns_var { @@ -561,8 +551,7 @@ test var-8.2 {TclDeleteNamespaceVars, "unset" traces on ns delete are called wit } -result {{} {::test_ns_var::v {} u}} test var-9.1 {behaviour of TclGet/SetVar simple get/set} -setup { - catch {unset u} - catch {unset v} + unset -nocomplain u v } -constraints testsetnoerr -body { list \ [set u a; testsetnoerr u] \ @@ -581,7 +570,7 @@ test var-9.2 {behaviour of TclGet/SetVar namespace get/set} -setup { [unset ns::v; testseterr ns::v b] } -result [list {before get a} {before set b} {before get a} {before set b}] test var-9.3 {behaviour of TclGetVar no variable} -setup { - catch {unset u} + unset -nocomplain u } -constraints testsetnoerr -body { list \ [catch {testsetnoerr u} res] $res \ @@ -610,7 +599,7 @@ test var-9.6 {behaviour of TclSetVar no namespace} -setup { [catch {testseterr ns::v 1} res] $res } -result {1 {before set} 1 {can't set "ns::v": parent namespace doesn't exist}} test var-9.7 {behaviour of TclGetVar array variable} -setup { - catch {unset arr} + unset -nocomplain arr } -constraints testsetnoerr -body { set arr(1) 1 list \ @@ -618,7 +607,7 @@ test var-9.7 {behaviour of TclGetVar array variable} -setup { [catch {testseterr arr} res] $res } -result {1 {before get} 1 {can't read "arr": variable is array}} test var-9.8 {behaviour of TclSetVar array variable} -setup { - catch {unset arr} + unset -nocomplain arr } -constraints testsetnoerr -body { set arr(1) 1 list \ @@ -626,8 +615,7 @@ test var-9.8 {behaviour of TclSetVar array variable} -setup { [catch {testseterr arr 2} res] $res } -result {1 {before set} 1 {can't set "arr": variable is array}} test var-9.9 {behaviour of TclGetVar read trace success} -setup { - catch {unset u} - catch {unset v} + unset -nocomplain u v } -constraints testsetnoerr -body { proc resetvar {val name elem op} {upvar 1 $name v; set v $val} set u 10 @@ -646,8 +634,7 @@ test var-9.10 {behaviour of TclGetVar read trace error} testsetnoerr { [catch {testseterr v} msg] $msg } {1 {before get} 1 {can't read "v": write-only}} test var-9.11 {behaviour of TclSetVar write trace success} -setup { - catch {unset u} - catch {unset v} + unset -nocomplain u v } -constraints testsetnoerr -body { proc doubleval {name elem op} {upvar 1 $name v; set v [expr {2 * $v}]} set v 1 @@ -667,32 +654,32 @@ test var-9.12 {behaviour of TclSetVar write trace error} testsetnoerr { } {1 {before set} 2 1 {can't set "v": read-only} 3} test var-10.1 {can't nest arrays with array set} -setup { - catch {unset arr} + unset -nocomplain arr } -returnCodes error -body { array set arr(x) {a 1 b 2} } -result {can't set "arr(x)": variable isn't array} test var-10.2 {can't nest arrays with array set} -setup { - catch {unset arr} + unset -nocomplain arr } -returnCodes error -body { array set arr(x) {} } -result {can't set "arr(x)": variable isn't array} test var-11.1 {array unset} -setup { - catch {unset a} + unset -nocomplain a } -body { array set a { 1,1 a 1,2 b 2,1 c 2,3 d } array unset a 1,* lsort -dict [array names a] } -result {2,1 2,3} test var-11.2 {array unset} -setup { - catch {unset a} + unset -nocomplain a } -body { array set a { 1,1 a 1,2 b } array unset a array exists a } -result 0 test var-11.3 {array unset errors} -setup { - catch {unset a} + unset -nocomplain } -returnCodes error -body { array set a { 1,1 a 1,2 b } array unset a pattern too @@ -714,7 +701,7 @@ test var-12.1 {TclFindCompiledLocals, {} array name} { } {0 1 2 2,foo} test var-13.1 {Tcl_UnsetVar2, unset array with trace set on element} -setup { - catch {unset t} + unset -nocomplain t } -body { proc foo {var ind op} { global t @@ -795,19 +782,12 @@ test var-19.1 {crash when freeing locals hashtable: Bug 3037525} { } {} catch {namespace delete ns} -catch {unset arr} -catch {unset v} +unset -nocomplain arr v catch {rename p ""} catch {namespace delete test_ns_var} catch {namespace delete test_ns_var2} -catch {unset xx} -catch {unset x} -catch {unset y} -catch {unset i} -catch {unset a} -catch {unset xxxxx} -catch {unset aaaaa} +unset -nocomplain xx x y i a xxxxx aaaaa # cleanup ::tcltest::cleanupTests diff --git a/tests/while-old.test b/tests/while-old.test index ee17d0b..96e7d09 100644 --- a/tests/while-old.test +++ b/tests/while-old.test @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -94,7 +94,7 @@ test while-old-4.4 {errors in while loops} { list $err $msg } {1 {can't use non-numeric string as operand of "+"}} test while-old-4.5 {errors in while loops} { - catch {unset x} + unset -nocomplain x set x 1 set err [catch {while {$x} {set x foo}} msg] list $err $msg diff --git a/tests/while.test b/tests/while.test index 642ec93..de12d53 100644 --- a/tests/while.test +++ b/tests/while.test @@ -17,8 +17,7 @@ if {"::tcltest" ni [namespace children]} { # Basic "while" operation. -catch {unset i} -catch {unset a} +unset -nocomplain i a test while-1.1 {TclCompileWhileCmd: missing test expression} -body { while @@ -94,16 +93,14 @@ test while-1.10 {TclCompileWhileCmd: command body in quotes} -body { unset a i } -result {xxxxx} test while-1.11 {TclCompileWhileCmd: computed command body} -setup { - catch {unset x1} - catch {unset bb} - catch {unset x2} + unset -nocomplain x1 bb x2 } -body { set x1 {append a x1; } set bb {break} set x2 {; append a x2; incr i} - set a {} + set a "" set i 1 - while {$i<6} $x1$bb$x2 + while {$i < 6} $x1$bb$x2 return $a } -cleanup { unset x1 bb x2 a i @@ -114,27 +111,27 @@ test while-1.12 {TclCompileWhileCmd: long command body} -body { while {$i<6} { if $i==4 break if $i>5 continue - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg @@ -210,27 +207,27 @@ test while-2.4 {continue tests, long command body} -body { if $i==2 {incr i; continue} if $i==4 break if $i>5 continue - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg @@ -274,34 +271,34 @@ test while-3.2 {break tests, nested loops} -body { unset a i msg } -result {1.1 1.2 2.1 3.1 4.1} test while-3.3 {break tests, long command body} -body { - set a {} + set a "" set i 1 - while {$i<6} { - if $i==2 {incr i; continue} - if $i==5 break - if $i>5 continue - if {$i>6 && $tcl_platform(machine)=="xxx"} { + while {$i < 6} { + if {$i == 2} {incr i; continue} + if {$i == 5} break + if {$i > 5} continue + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } if $i==4 break - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg @@ -419,9 +416,7 @@ test while-4.11 {while (not compiled): command body in quotes} -body { unset a i z } -result {xxxxx} test while-4.12 {while (not compiled): computed command body} -setup { - catch {unset x1} - catch {unset bb} - catch {unset x2} + unset -nocomplain x1 bb x2 } -body { set z while set x1 {append a x1; } @@ -441,27 +436,27 @@ test while-4.13 {while (not compiled): long command body} -body { $z {$i<6} { if $i==4 break if $i>5 continue - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg @@ -541,28 +536,28 @@ test while-5.4 {break tests, long command body with computed command names} -bod if $i==2 {incr i; continue} if $i==5 $z if $i>5 continue - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } if $i==4 $z - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg @@ -640,27 +635,27 @@ test while-6.5 {continue tests, long command body with computed command names} - if $i==2 {incr i; continue} if $i==4 break if $i>5 $z - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg diff --git a/tests/winConsole.test b/tests/winConsole.test index fdde41c..2e0e904 100644 --- a/tests/winConsole.test +++ b/tests/winConsole.test @@ -9,18 +9,17 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } - test winConsole-1.1 {Console file channel: non-blocking gets} {win interactive} { - set oldmode [fconfigure stdin] + set oldmode [chan configure stdin] puts stdout "Enter abcdef<return> now: " nonewline flush stdout - fileevent stdin readable { + chan event stdin readable { if {[gets stdin line] >= 0} { set result $line } else { @@ -28,14 +27,14 @@ test winConsole-1.1 {Console file channel: non-blocking gets} {win interactive} } } - fconfigure stdin -blocking 0 -buffering line + chan configure stdin -blocking 0 -buffering line set result {} vwait result - #cleanup the fileevent - fileevent stdin readable {} - fconfigure stdin {*}$oldmode + #cleanup the chan event + chan event stdin readable {} + chan configure stdin {*}$oldmode set result diff --git a/tests/winDde.test b/tests/winDde.test index f04fb45..3acfe2b 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -31,10 +31,10 @@ if {[testConstraint win]} { # Setup a script for a test server # -set scriptName [makeFile {} script1.tcl] +set scriptName [makeFile "" script1.tcl] proc createChildProcess {ddeServerName args} { - file delete -force $::scriptName + file delete -force -- $::scriptName set f [open $::scriptName w+] puts $f [list set ddeServerName $ddeServerName] @@ -60,7 +60,7 @@ proc createChildProcess {ddeServerName args} { # Define a restricted handler. proc Handler1 {cmd} { if {$cmd eq "stop"} {set ::done 1} - if {$cmd == ""} { + if {$cmd eq ""} { set cmd "null data" } puts $cmd ; flush stdout @@ -96,8 +96,8 @@ proc createChildProcess {ddeServerName args} { # run the child server script. set f [open |[list [interpreter] $::scriptName] r] - fconfigure $f -buffering line - gets $f line + chan configure $f -buffering line + chan gets $f line return $f } @@ -482,7 +482,7 @@ test winDde-9.4 {External safe DDE check null data passing} -constraints {dde st #cleanup #catch {interp delete $slave}; # ensure we clean up the slave. -file delete -force $::scriptName +file delete -force -- $::scriptName ::tcltest::cleanupTests return diff --git a/tests/winFCmd.test b/tests/winFCmd.test index 28a0e9f..6cb2fd1 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -50,7 +50,7 @@ proc cleanup {args} { catch { set x [glob -directory $p tf* td*] } - if {$x != ""} { + if {$x ne ""} { catch {file delete -force -- {*}$x} } } @@ -58,7 +58,7 @@ proc cleanup {args} { if {[testConstraint winOnly]} { set major [string index $tcl_platform(osVersion) 0] - if {[testConstraint nt] && $major > 4} { + if {[testConstraint nt] && ($major > 4)} { if {$major > 5} { testConstraint winVista 1 } elseif {$major == 5} { @@ -86,7 +86,7 @@ proc findfile {dir} { if {[testConstraint testvolumetype]} { foreach p {d e f g h i j k l m n o p q r s t u v w x y z} { - if {![catch {testvolumetype ${p}:} result] && $result in {CDFS UDF}} { + if {(![catch {testvolumetype ${p}:} result]) && ($result in {CDFS UDF})} { set cdrom ${p}: set cdfile [findfile $cdrom] testConstraint cdrom 1 @@ -424,14 +424,13 @@ test winFCmd-1.38 {TclpRenameFile: check rename of conflicting inodes} -setup { cleanup } -constraints {win winNonZeroInodes} -body { file mkdir td1 - foreach {a b} [MakeFiles td1] break + lassign [MakeFiles td1] a b file rename -force $a $b file exists $a } -cleanup { cleanup } -result {0} - test winFCmd-2.1 {TclpCopyFile: errno: EACCES} -setup { cleanup } -constraints {win cdrom testfile} -body { diff --git a/tests/winFile.test b/tests/winFile.test index fba9bcb..2954272 100644 --- a/tests/winFile.test +++ b/tests/winFile.test @@ -26,7 +26,7 @@ testConstraint win2000 0 if {[testConstraint testvolumetype]} { testConstraint notNTFS [expr {[testvolumetype] eq "NTFS"}] } -if {[testConstraint nt] && $::tcl_platform(osVersion) >= 5.0} { +if {[testConstraint nt] && ($::tcl_platform(osVersion) >= 5.0)} { testConstraint win2000 1 } @@ -86,7 +86,7 @@ test winFile-3.1 {file system} -constraints {win testvolumetype} -setup { } } set res -} -result {} +} -result "" proc cacls {fname args} { string trim [eval [list exec cacls [file nativename $fname]] $args <<y] @@ -106,7 +106,7 @@ proc getuser {fname} { } set owner "" set tail [file tail $tryname] - if {[info exists env(OSTYPE)] && $env(OSTYPE) eq "msys"} { + if {[info exists env(OSTYPE)] && ($env(OSTYPE) eq "msys")} { set dirtext [exec ls -l $fname] foreach line [split $dirtext "\n"] { set owner [lindex $line 2] @@ -131,26 +131,26 @@ proc test_read {fname} { if {[catch {open $fname r} ifs]} { return 0 } - set readfailed [catch {read $ifs}] - return [expr {![catch {close $ifs}] && !$readfailed}] + set readfailed [catch {chan read $ifs}] + return [expr {(![catch {chan close $ifs}]) && (!$readfailed)}] } proc test_writ {fname} { if {[catch {open $fname w} ofs]} { return 0 } - set writefailed [catch {puts $ofs "Hello"}] - return [expr {![catch {close $ofs}] && !$writefailed}] + set writefailed [catch {chan puts $ofs "Hello"}] + return [expr {(![catch {chan close $ofs}]) && (!$writefailed)}] } proc test_access {fname read writ} { - set problem {} + set problem [list] foreach type {read writ} { - if {[set $type] != [file ${type}able $fname]} { - lappend problem "[set $type] != \[file ${type}able $fname\]" + if {[set [set type]] != [file ${type}able $fname]} { + lappend problem "[set [set type]] != \[file ${type}able $fname\]" } - if {[set $type] != [test_${type} $fname]} { - lappend problem "[set $type] != \[test_${type} $fname\]" + if {[set [set type]] != [test_${type} $fname]} { + lappend problem "[set [set type]] != \[test_${type} $fname\]" } } if {![llength $problem]} { @@ -165,8 +165,8 @@ if {[testConstraint win]} { # creation in a particular filesystem? If not, try [makeFile] # in a -setup script. set fname test.dat - file delete $fname - close [open $fname w] + file delete -- $fname + chan close [open $fname w] } test winFile-4.0 { @@ -183,7 +183,7 @@ test winFile-4.0 { catch {cacls $fname /E /R $owner} result cacls $fname /E /P $user:N test_access $fname 0 0 -} -result {} +} -result "" test winFile-4.1 { Enhanced NTFS user/group permissions: test readable only } -constraints { @@ -194,7 +194,7 @@ test winFile-4.1 { cacls $fname /E /P $user:N cacls $fname /E /G $user:R test_access $fname 1 0 -} -result {} +} -result "" test winFile-4.2 { Enhanced NTFS user/group permissions: test writable only } -constraints { @@ -206,7 +206,7 @@ test winFile-4.2 { cacls $fname /E /P $user:N cacls $fname /E /G $user:W test_access $fname 0 1 -} -result {} +} -result "" test winFile-4.3 { Enhanced NTFS user/group permissions: test read+write } -constraints { @@ -219,7 +219,7 @@ test winFile-4.3 { cacls $fname /E /G $user:R cacls $fname /E /G $user:W test_access $fname 1 1 -} -result {} +} -result "" test winFile-4.4 { Enhanced NTFS user/group permissions: test full access } -constraints { @@ -231,10 +231,10 @@ test winFile-4.4 { cacls $fname /E /P $user:N cacls $fname /E /G $user:F test_access $fname 1 1 -} -result {} +} -result "" if {[testConstraint win]} { - file delete $fname + file delete -- $fname } # cleanup diff --git a/tests/winNotify.test b/tests/winNotify.test index 3e9aa29..3e48dbf 100644 --- a/tests/winNotify.test +++ b/tests/winNotify.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } diff --git a/tests/winPipe.test b/tests/winPipe.test index d2e804d..f93e3e9 100644 --- a/tests/winPipe.test +++ b/tests/winPipe.test @@ -31,7 +31,6 @@ testConstraint AllocConsole [catch {puts console1 ""}] testConstraint RealConsole [expr {![testConstraint AllocConsole]}] testConstraint testexcept [llength [info commands testexcept]] - set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n append big $big append big $big @@ -42,8 +41,8 @@ append big $big set path(little) [makeFile {} little] set f [open $path(little) w] -puts -nonewline $f "little" -close $f +chan puts -nonewline $f "little" +chan close $f set path(big) [makeFile {} big] set f [open $path(big) w] @@ -191,8 +190,8 @@ test winpipe-4.1 {Tcl_WaitPid} {win nt exec cat32} { } } set f [open "|[list $cat32] < $path(big) 2> $path(stderr)" r] - fconfigure $f -buffering none -blocking 0 - fileevent $f readable "readResults $f" + chan configure $f -buffering none -blocking 0 + chan event $f readable "readResults $f" set x 0 set result "" vwait x @@ -284,12 +283,12 @@ test winpipe-5.4 {TclpCreateTempFile: TEMP specifies non-existent directory} \ test winpipe-6.1 {PipeSetupProc & PipeCheckProc: read threads} \ {win exec cat32} { set f [open "|[list $cat32]" r+] - fconfigure $f -blocking 0 - fileevent $f writable { set x writable } - set x {} + chan configure $f -blocking 0 + chan event $f writable { set x writable } + set x "" vwait x - fileevent $f writable {} - fileevent $f readable { lappend x readable } + chan event $f writable {} + chan event $f readable { lappend x readable } after 100 { lappend x timeout } vwait x puts $f foobar @@ -298,16 +297,16 @@ test winpipe-6.1 {PipeSetupProc & PipeCheckProc: read threads} \ lappend x [read $f] after 100 { lappend x timeout } vwait x - fconfigure $f -blocking 1 + chan configure $f -blocking 1 lappend x [catch {close $f} msg] $msg } {writable timeout readable {foobar } timeout 1 stderr32} test winpipe-6.2 {PipeSetupProc & PipeCheckProc: write threads} \ {win exec cat32} { set f [open "|[list $cat32]" r+] - fconfigure $f -blocking 0 - fileevent $f writable { set x writable } - set x {} + chan configure $f -blocking 0 + chan event $f writable { set x writable } + set x "" vwait x puts -nonewline $f $big$big$big$big flush $f diff --git a/tests/winTime.test b/tests/winTime.test index add8f98..ceeca55 100644 --- a/tests/winTime.test +++ b/tests/winTime.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -45,18 +45,18 @@ test winTime-2.1 {Synchronization of Tcl and Windows clocks} {testwinclock} { # http://support.microsoft.com/default.aspx?scid=kb;en-us;274323 set failed {} set ok 1 - foreach start_sec [testwinclock] break + lassign [testwinclock] start_sec while { 1 } { - foreach { sys_sec sys_usec tcl_sec tcl_usec } [testwinclock] break + lassign [testwinclock] sys_sec sys_usec tcl_sec tcl_usec set diff [expr { $tcl_sec - $sys_sec - + 1.0e-6 * ( $tcl_usec - $sys_usec ) }] + + (1.0e-6 * ( $tcl_usec - $sys_usec )) }] if { abs($diff) > 0.06 } { set failed "Tcl clock differs from system clock by $diff sec" break } else { testwinsleep 1 } - if { $sys_sec - $start_sec >= 30 } break + if { ($sys_sec - $start_sec) >= 30 } break } set failed } {} diff --git a/tests/zlib.test b/tests/zlib.test index 891dba0..c09e848 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -150,22 +150,22 @@ test zlib-8.2 {zlib transformation} -constraints zlib -setup { close $f removeFile $file } -result ok -test zlib-8.3 {zlib transformation and fileevent} -constraints zlib -setup { +test zlib-8.3 {zlib transformation and chan event} -constraints zlib -setup { set srv [socket -myaddr localhost -server {apply {{c a p} { - fconfigure $c -translation binary -buffering none -blocking 0 + chan configure $c -translation binary -buffering none -blocking 0 puts -nonewline $c [zlib gzip [string repeat a 81920]] close $c }}} 0] - set port [lindex [fconfigure $srv -sockname] 2] + set port [lindex [chan configure $srv -sockname] 2] set file [makeFile {} test.gz] set fout [open $file wb] } -body { set sin [socket localhost $port] try { - fconfigure $sin -translation binary + chan configure $sin -translation binary zlib push gunzip $sin after 1000 {set total timeout} - fcopy $sin $fout -command {apply {{c {e {}}} { + chan copy $sin $fout -command {apply {{c {e {}}} { set ::total [expr {$e eq {} ? $c : $e}] }}} vwait total @@ -185,46 +185,46 @@ test zlib-8.4 {transformation and flushing: Bug 3517696} -setup { } -constraints zlib -body { zlib push compress $fd puts $fd "qwertyuiop" - fconfigure $fd -flush sync + chan configure $fd -flush sync puts $fd "qwertyuiop" } -cleanup { catch {close $fd} removeFile $file } -result {} -test zlib-8.5 {transformation and flushing and fileevents: Bug 3525907} -setup { - foreach {r w} [chan pipe] break +test zlib-8.5 {transformation and flushing and chan events: Bug 3525907} -setup { + lassign [chan pipe] r w } -constraints zlib -body { set ::res {} - fconfigure $w -buffering none + chan configure $w -buffering none zlib push compress $w puts -nonewline $w qwertyuiop chan configure $w -flush sync after 500 {puts -nonewline $w asdfghjkl;close $w} - fconfigure $r -blocking 0 -buffering none + chan configure $r -blocking 0 -buffering none zlib push decompress $r - fileevent $r readable {set msg [read $r];lappend ::res $msg;if {[eof $r]} {set ::done 1}} + chan event $r readable {set msg [read $r];lappend ::res $msg;if {[eof $r]} {set ::done 1}} after 250 {lappend ::res MIDDLE} vwait ::done set ::res } -cleanup { catch {close $r} } -result {qwertyuiop MIDDLE asdfghjkl} -test zlib-8.6 {transformation and fconfigure} -setup { +test zlib-8.6 {transformation and chan configure} -setup { set file [makeFile {} test.z] set fd [open $file wb] } -constraints zlib -body { - list [fconfigure $fd] [zlib push compress $fd; fconfigure $fd] \ - [chan pop $fd; fconfigure $fd] + list [chan configure $fd] [zlib push compress $fd; chan configure $fd] \ + [chan pop $fd; chan configure $fd] } -cleanup { catch {close $fd} removeFile $file } -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}} -test zlib-8.7 {transformation and fconfigure} -setup { +test zlib-8.7 {transformation and chan configure} -setup { set file [makeFile {} test.gz] set fd [open $file wb] } -constraints zlib -body { - list [fconfigure $fd] [zlib push gzip $fd; fconfigure $fd] \ - [chan pop $fd; fconfigure $fd] + list [chan configure $fd] [zlib push gzip $fd; chan configure $fd] \ + [chan pop $fd; chan configure $fd] } -cleanup { catch {close $fd} removeFile $file @@ -233,12 +233,12 @@ test zlib-8.7 {transformation and fconfigure} -setup { # Dictionary is that which is proposed _in_ SPDY draft set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" set spdyDict "optionsgetheadpostputdeletetraceacceptaccept-charsetaccept-encodingaccept-languageauthorizationexpectfromhostif-modified-sinceif-matchif-none-matchif-rangeif-unmodifiedsincemax-forwardsproxy-authorizationrangerefererteuser-agent100101200201202203204205206300301302303304305306307400401402403404405406407408409410411412413414415416417500501502503504505accept-rangesageetaglocationproxy-authenticatepublicretry-afterservervarywarningwww-authenticateallowcontent-basecontent-encodingcache-controlconnectiondatetrailertransfer-encodingupgradeviawarningcontent-languagecontent-lengthcontent-locationcontent-md5content-rangecontent-typeetagexpireslast-modifiedset-cookieMondayTuesdayWednesdayThursdayFridaySaturdaySundayJanFebMarAprMayJunJulAugSepOctNovDecchunkedtext/htmlimage/pngimage/jpgimage/gifapplication/xmlapplication/xhtmltext/plainpublicmax-agecharset=iso-8859-1utf-8gzipdeflateHTTP/1.1statusversionurl" -test zlib-8.8 {transformtion and fconfigure} -setup { +test zlib-8.8 {transformtion and chan configure} -setup { lassign [chan pipe] inSide outSide } -constraints zlib -body { zlib push compress $outSide -dictionary $spdyDict - fconfigure $outSide -blocking 0 -translation binary -buffering none - fconfigure $inSide -blocking 0 -translation binary + chan configure $outSide -blocking 0 -translation binary -buffering none + chan configure $inSide -blocking 0 -translation binary puts -nonewline $outSide $spdyHeaders chan pop $outSide set compressed [read $inSide] @@ -250,15 +250,15 @@ test zlib-8.8 {transformtion and fconfigure} -setup { catch {close $outSide} catch {close $inSide} } -result {260 222 {need dictionary} {TCL ZLIB NEED_DICT 2381337010} 2381337010} -test zlib-8.9 {transformtion and fconfigure} -setup { +test zlib-8.9 {transformtion and chan configure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream decompress] } -constraints zlib -body { zlib push compress $outSide -dictionary $spdyDict - fconfigure $outSide -blocking 0 -translation binary -buffering none - fconfigure $inSide -blocking 0 -translation binary + chan configure $outSide -blocking 0 -translation binary -buffering none + chan configure $inSide -blocking 0 -translation binary puts -nonewline $outSide $spdyHeaders - set result [fconfigure $outSide -checksum] + set result [chan configure $outSide -checksum] chan pop $outSide $strm put -dictionary $spdyDict [read $inSide] lappend result [string length $spdyHeaders] [string length [$strm get]] @@ -267,12 +267,12 @@ test zlib-8.9 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {3064818174 358 358} -test zlib-8.10 {transformtion and fconfigure} -setup { +test zlib-8.10 {transformtion and chan configure} -setup { lassign [chan pipe] inSide outSide } -constraints zlib -body { zlib push deflate $outSide -dictionary $spdyDict - fconfigure $outSide -blocking 0 -translation binary -buffering none - fconfigure $inSide -blocking 0 -translation binary + chan configure $outSide -blocking 0 -translation binary -buffering none + chan configure $inSide -blocking 0 -translation binary puts -nonewline $outSide $spdyHeaders chan pop $outSide set compressed [read $inSide] @@ -284,13 +284,13 @@ test zlib-8.10 {transformtion and fconfigure} -setup { catch {close $outSide} catch {close $inSide} } -result {254 212 {data error} {TCL ZLIB DATA}} -test zlib-8.11 {transformtion and fconfigure} -setup { +test zlib-8.11 {transformtion and chan configure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream inflate] } -constraints zlib -body { zlib push deflate $outSide -dictionary $spdyDict - fconfigure $outSide -blocking 0 -translation binary -buffering none - fconfigure $inSide -blocking 0 -translation binary + chan configure $outSide -blocking 0 -translation binary -buffering none + chan configure $inSide -blocking 0 -translation binary puts -nonewline $outSide $spdyHeaders chan pop $outSide $strm put -dictionary $spdyDict [read $inSide] @@ -300,48 +300,48 @@ test zlib-8.11 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358} -test zlib-8.12 {transformtion and fconfigure} -setup { +test zlib-8.12 {transformtion and chan configure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream compress] } -constraints zlib -body { $strm put -dictionary $spdyDict -finalize $spdyHeaders zlib push decompress $inSide - fconfigure $outSide -blocking 0 -translation binary - fconfigure $inSide -translation binary -dictionary $spdyDict + chan configure $outSide -blocking 0 -translation binary + chan configure $inSide -translation binary -dictionary $spdyDict puts -nonewline $outSide [$strm get] close $outSide list [string length $spdyHeaders] [string length [read $inSide]] \ - [fconfigure $inSide -checksum] + [chan configure $inSide -checksum] } -cleanup { catch {close $outSide} catch {close $inSide} catch {$strm close} } -result {358 358 3064818174} -test zlib-8.13 {transformtion and fconfigure} -setup { +test zlib-8.13 {transformtion and chan configure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream compress] } -constraints zlib -body { $strm put -dictionary $spdyDict -finalize $spdyHeaders zlib push decompress $inSide -dictionary $spdyDict - fconfigure $outSide -blocking 0 -translation binary - fconfigure $inSide -translation binary + chan configure $outSide -blocking 0 -translation binary + chan configure $inSide -translation binary puts -nonewline $outSide [$strm get] close $outSide list [string length $spdyHeaders] [string length [read $inSide]] \ - [fconfigure $inSide -checksum] + [chan configure $inSide -checksum] } -cleanup { catch {close $outSide} catch {close $inSide} catch {$strm close} } -result {358 358 3064818174} -test zlib-8.14 {transformtion and fconfigure} -setup { +test zlib-8.14 {transformtion and chan configure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream deflate] } -constraints zlib -body { $strm put -finalize -dictionary $spdyDict $spdyHeaders zlib push inflate $inSide - fconfigure $outSide -blocking 0 -buffering none -translation binary - fconfigure $inSide -translation binary -dictionary $spdyDict + chan configure $outSide -blocking 0 -buffering none -translation binary + chan configure $inSide -translation binary -dictionary $spdyDict puts -nonewline $outSide [$strm get] close $outSide list [string length $spdyHeaders] [string length [read $inSide]] @@ -350,14 +350,14 @@ test zlib-8.14 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358} -test zlib-8.15 {transformtion and fconfigure} -setup { +test zlib-8.15 {transformtion and chan configure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream deflate] } -constraints zlib -body { $strm put -finalize -dictionary $spdyDict $spdyHeaders zlib push inflate $inSide -dictionary $spdyDict - fconfigure $outSide -blocking 0 -buffering none -translation binary - fconfigure $inSide -translation binary + chan configure $outSide -blocking 0 -buffering none -translation binary + chan configure $inSide -translation binary puts -nonewline $outSide [$strm get] close $outSide list [string length $spdyHeaders] [string length [read $inSide]] @@ -367,7 +367,7 @@ test zlib-8.15 {transformtion and fconfigure} -setup { catch {$strm close} } -result {358 358} -test zlib-9.1 "check fcopy with push" -constraints zlib -setup { +test zlib-9.1 "check chan copy with push" -constraints zlib -setup { set sfile [makeFile {} testsrc.gz] set file [makeFile {} test.gz] set f [open $sfile wb] @@ -376,14 +376,14 @@ test zlib-9.1 "check fcopy with push" -constraints zlib -setup { } -body { set fin [zlib push gunzip [open $sfile rb]] set fout [open $file wb] - set total [fcopy $fin $fout] + set total [chan copy $fin $fout] close $fin ; close $fout list copied $total size [file size $file] } -cleanup { removeFile $file removeFile $sfile } -result {copied 81920 size 81920} -test zlib-9.2 "socket fcopy with push" -constraints zlib -setup { +test zlib-9.2 "socket chan copy with push" -constraints zlib -setup { set srv [socket -myaddr localhost -server {apply {{c a p} { chan configure $c -translation binary -buffering none -blocking 0 puts -nonewline $c [zlib gzip [string repeat a 81920]] @@ -396,7 +396,7 @@ test zlib-9.2 "socket fcopy with push" -constraints zlib -setup { chan configure $sin -translation binary zlib push gunzip $sin update - set total [fcopy $sin [set fout [open $file wb]]] + set total [chan copy $sin [set fout [open $file wb]]] close $sin close $fout list read $total size [file size $file] @@ -404,7 +404,7 @@ test zlib-9.2 "socket fcopy with push" -constraints zlib -setup { close $srv removeFile $file } -result {read 81920 size 81920} -test zlib-9.3 "socket fcopy bg (identity)" -constraints {tempNotWin zlib} -setup { +test zlib-9.3 "socket chan copy bg (identity)" -constraints {tempNotWin zlib} -setup { set srv [socket -myaddr localhost -server {apply {{c a p} { #puts "connection from $a:$p on $c" chan configure $c -translation binary -buffering none -blocking 0 @@ -420,7 +420,7 @@ test zlib-9.3 "socket fcopy bg (identity)" -constraints {tempNotWin zlib} -setup update set fout [open $file wb] after 1000 {set ::total timeout} - fcopy $sin $fout -command {apply {{c {e {}}} { + chan copy $sin $fout -command {apply {{c {e {}}} { set ::total [expr {$e eq {} ? $c : $e}] }}} vwait ::total @@ -431,7 +431,7 @@ test zlib-9.3 "socket fcopy bg (identity)" -constraints {tempNotWin zlib} -setup close $srv removeFile $file } -returnCodes {ok error} -result {read 81920 size 81920} -test zlib-9.4 "socket fcopy bg (gzip)" -constraints zlib -setup { +test zlib-9.4 "socket chan copy bg (gzip)" -constraints zlib -setup { set srv [socket -myaddr localhost -server {apply {{c a p} { chan configure $c -translation binary -buffering none -blocking 0 puts -nonewline $c [zlib gzip [string repeat a 81920]] @@ -446,7 +446,7 @@ test zlib-9.4 "socket fcopy bg (gzip)" -constraints zlib -setup { update set fout [open $file wb] after 1000 {set ::total timeout} - fcopy $sin $fout -command {apply {{c {e {}}} { + chan copy $sin $fout -command {apply {{c {e {}}} { set ::total [expr {$e eq {} ? $c : $e}] }}} vwait ::total @@ -457,7 +457,7 @@ test zlib-9.4 "socket fcopy bg (gzip)" -constraints zlib -setup { close $srv removeFile $file } -result {read 81920 size 81920} -test zlib-9.5 "socket fcopy incremental (gzip)" -constraints zlib -setup { +test zlib-9.5 "socket chan copy incremental (gzip)" -constraints zlib -setup { set srv [socket -myaddr localhost -server {apply {{c a p} { chan configure $c -translation binary -buffering none -blocking 0 puts -nonewline $c [zlib gzip [string repeat a 81920]] @@ -470,7 +470,7 @@ test zlib-9.5 "socket fcopy incremental (gzip)" -constraints zlib -setup { } elseif {[eof $i]} { set ::total [list eof $t] } else { - fcopy $i $o -size 8192 -command [list zlib95copy $i $o $t] + chan copy $i $o -size 8192 -command [list zlib95copy $i $o $t] } } set file [makeFile {} test.gz] @@ -482,7 +482,7 @@ test zlib-9.5 "socket fcopy incremental (gzip)" -constraints zlib -setup { update set fout [open $file wb] after 1000 {set ::total timeout} - fcopy $sin $fout -size 8192 -command [list zlib95copy $sin $fout 0] + chan copy $sin $fout -size 8192 -command [list zlib95copy $sin $fout 0] vwait ::total after cancel {set ::total timeout} close $sin; close $fout |