summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
authorjan.nijtmans <nijtmans@users.sourceforge.net>2019-09-25 13:42:11 (GMT)
committerjan.nijtmans <nijtmans@users.sourceforge.net>2019-09-25 13:42:11 (GMT)
commit2c327304a1fe9e05367e2845d7a53d7807325473 (patch)
treef52ff2b3681c317f970cc66b9656a920deaf0c2b /tests
parent261bde3156d50771907d0e386439fd241874b9eb (diff)
parent13f90df6597eb8749645582c67de29865ea50950 (diff)
downloadtcl-2c327304a1fe9e05367e2845d7a53d7807325473.zip
tcl-2c327304a1fe9e05367e2845d7a53d7807325473.tar.gz
tcl-2c327304a1fe9e05367e2845d7a53d7807325473.tar.bz2
Merge 8.7
Diffstat (limited to 'tests')
-rw-r--r--tests/all.tcl9
-rw-r--r--tests/basic.test2
-rw-r--r--tests/chanio.test20
-rw-r--r--tests/cmdAH.test37
-rw-r--r--tests/cmdMZ.test6
-rw-r--r--tests/compile.test61
-rw-r--r--tests/execute.test84
-rw-r--r--tests/fCmd.test6
-rw-r--r--tests/fileName.test42
-rw-r--r--tests/interp.test2
-rw-r--r--tests/io.test6
-rw-r--r--tests/ioCmd.test17
-rw-r--r--tests/lrange.test12
-rw-r--r--tests/namespace.test1
-rw-r--r--tests/pid.test2
-rw-r--r--tests/socket.test2
-rw-r--r--tests/tcltest.test108
-rw-r--r--tests/tm.test2
-rw-r--r--tests/uplevel.test10
-rw-r--r--tests/upvar.test13
-rw-r--r--tests/winTime.test5
21 files changed, 318 insertions, 129 deletions
diff --git a/tests/all.tcl b/tests/all.tcl
index 89a4f1a..52c8763 100644
--- a/tests/all.tcl
+++ b/tests/all.tcl
@@ -12,7 +12,7 @@
package prefer latest
package require Tcl 8.5-
-package require tcltest 2.2
+package require tcltest 2.5
namespace import ::tcltest::*
configure {*}$argv -testdir [file dirname [file dirname [file normalize [
@@ -25,4 +25,9 @@ if {[singleProcess]} {
set ErrorOnFailures [info exists env(ERROR_ON_FAILURES)]
unset -nocomplain env(ERROR_ON_FAILURES)
if {[runAllTests] && $ErrorOnFailures} {exit 1}
-proc exit args {}
+# if calling direct only (avoid rewrite exit if inlined or interactive):
+if { [info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]
+ && !([info exists ::tcl_interactive] && $::tcl_interactive)
+} {
+ proc exit args {}
+} \ No newline at end of file
diff --git a/tests/basic.test b/tests/basic.test
index 4561667..428fd93 100644
--- a/tests/basic.test
+++ b/tests/basic.test
@@ -964,7 +964,7 @@ test basic-48.24.$noComp {expansion: empty not canonical list, regression test,
run {list [list {*}{ }] [list {*}[format %c 32]] [list {*}[set a { }]]}
} -result [lrepeat 3 {}] -cleanup {unset -nocomplain a}
-test basic-48.25.$noComp {Bug cc191552c: expansion: empty non-canonical list} -setup {
+test basic-48.25.$noComp {Bug cc191552c: expansion: empty non-canonical list} -constraints $constraints -setup {
unset -nocomplain ::CRLF
set ::CRLF "\r\n"
} -body {
diff --git a/tests/chanio.test b/tests/chanio.test
index 4b71fef..c7c07ce 100644
--- a/tests/chanio.test
+++ b/tests/chanio.test
@@ -1881,7 +1881,7 @@ test chan-io-20.3 {Tcl_CreateChannel: initial settings} -constraints {unix} -bod
} -result {{{} {}} {auto lf}}
test chan-io-20.5 {Tcl_CreateChannel: install channel in empty slot} -setup {
set path(stdout) [makeFile {} stdout]
-} -constraints {stdio openpipe} -body {
+} -constraints {stdio openpipe knownMsvcBug} -body {
set f [open $path(script) w]
chan puts -nonewline $f {
chan close stdout
@@ -2025,7 +2025,7 @@ test chan-io-27.4 {FlushChannel, implicit flush when buffer fills} -setup {
test chan-io-27.5 {FlushChannel, implicit flush when buffer fills and on chan close} -setup {
file delete $path(test1)
set l ""
-} -constraints {unixOrPc} -body {
+} -constraints {unixOrWin} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -buffersize 60 -eofchar {}
lappend l [file size $path(test1)]
@@ -2817,7 +2817,7 @@ test chan-io-29.34 {Tcl_Chan Close, async flush on chan close, using sockets} -s
chan close $cs
chan close $ss
vwait [namespace which -variable x]
- return $c
+ set c
} -result 2000
test chan-io-29.35 {Tcl_Chan Close vs chan event vs multiple interpreters} -setup {
catch {interp delete x}
@@ -7033,7 +7033,7 @@ test chan-io-53.8 {CopyData: async callback and error handling, Bug 1932639} -se
vwait ::forever
catch {after cancel $token}
# Report
- return $::RES
+ set ::RES
} -cleanup {
chan close $f
chan close $g
@@ -7233,7 +7233,7 @@ test chan-io-54.1 {Recursive channel events} {socket fileevent} {
for {set i 0} {$i < 10} {incr i} {
if {![catch {
set cs [socket 127.0.0.1 [lindex [chan configure $ss -sockname] 2]]
- }]} then {
+ }]} {
set done 1
break
}
@@ -7305,7 +7305,7 @@ test chan-io-54.2 {Testing for busy-wait in recursive channel events} -setup {
chan close $writer
chan close $s
after cancel $after
- return $counter
+ set counter
} -cleanup {
if {$accept ne {}} {chan close $accept}
} -result 1
@@ -7332,7 +7332,7 @@ test chan-io-55.1 {ChannelEventScriptInvoker: deletion} -constraints {
chan event $f writable [namespace code [list eventScript $f]]
variable x not_done
vwait [namespace which -variable x]
- return $x
+ set x
} -cleanup {
interp bgerror {} $handler
} -result {got_error}
@@ -7377,7 +7377,7 @@ test chan-io-57.1 {buffered data and file events, gets} -setup {
vwait [namespace which -variable result]
lappend result [chan gets $s2]
vwait [namespace which -variable result]
- return $result
+ set result
} -cleanup {
chan close $s
chan close $s2
@@ -7402,14 +7402,14 @@ test chan-io-57.2 {buffered data and file events, read} -setup {
vwait [namespace which -variable result]
lappend result [chan read $s2 9]
vwait [namespace which -variable result]
- return $result
+ set result
} -cleanup {
chan close $s
chan close $s2
chan close $server
} -result {1 readable 234567890 timer}
-test chan-io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrPc openpipe fileevent} {
+test chan-io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrWin openpipe fileevent} {
set out [open $path(script) w]
chan puts $out {
chan puts "normal message from pipe"
diff --git a/tests/cmdAH.test b/tests/cmdAH.test
index b15c77d..992a8f4 100644
--- a/tests/cmdAH.test
+++ b/tests/cmdAH.test
@@ -23,14 +23,13 @@ testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint time64bit [expr {
$::tcl_platform(pointerSize) >= 8 ||
- [llength [info command testsize]] && [testsize time_t] >= 8
+ [llength [info command testsize]] && [testsize st_mtime] >= 8
}]
testConstraint linkDirectory [expr {
![testConstraint win] ||
($::tcl_platform(osVersion) >= 5.0
&& [lindex [file system [temporaryDirectory]] 1] eq "NTFS")
}]
-testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}]
global env
set cmdAHwd [pwd]
@@ -893,7 +892,7 @@ test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unix testchmod} {
file exe $gorpfile
} 1
test cmdAH-18.5 {Tcl_FileObjCmd: executable} -constraints {win} -body {
- # On pc, must be a .exe, .com, etc.
+ # On windows, must be a .exe, .com, etc.
set x {}
set gorpexes {}
foreach ext {exe com cmd bat} {
@@ -1315,8 +1314,28 @@ test cmdAH-24.20.2 {Tcl_FileObjCmd: mtime 64-bit time_t, bug [4718b41c56]} -cons
test cmdAH-25.1 {Tcl_FileObjCmd: owned} -returnCodes error -body {
file owned a b
} -result {wrong # args: should be "file owned name"}
-test cmdAH-25.2 {Tcl_FileObjCmd: owned} -constraints win -body {
- file owned $gorpfile
+test cmdAH-25.2 {Tcl_FileObjCmd: owned} -constraints win -setup {
+ set fn $gorpfile
+ # prefer temp file to check owner (try to avoid bug [7de2d722bd]):
+ if {
+ [info exists ::env(TEMP)] && [file isdirectory $::env(TEMP)] &&
+ [file dirname $fn] ne [file normalize $::env(TEMP)]
+ } {
+ set fn [file join $::env(TEMP)/test-owner-from-tcl.txt]
+ set fn [makeFile "data" test-owner-from-tcl.txt $::env(TEMP)]
+ }
+ # be sure we have really owned this file before trying to check that
+ # (avoid dependency on admin with UAC and the setting "System objects:
+ # Default owner for objects created by members of the Administrators group"):
+ catch {
+ exec takeown /F [file nativename $fn]
+ }
+} -body {
+ file owned $fn
+} -cleanup {
+ if {$fn ne $gorpfile} {
+ removeFile $fn
+ }
} -result 1
test cmdAH-25.2.1 {Tcl_FileObjCmd: owned} -constraints unix -setup {
# Avoid problems with AFS
@@ -1329,8 +1348,12 @@ test cmdAH-25.2.1 {Tcl_FileObjCmd: owned} -constraints unix -setup {
test cmdAH-25.3 {Tcl_FileObjCmd: owned} {unix notRoot} {
file owned /
} 0
-test cmdAH-25.3.1 {Tcl_FileObjCmd: owned} -constraints {win knownMsvcBug} -body {
- file owned $env(windir)
+test cmdAH-25.3.1 {Tcl_FileObjCmd: owned} -constraints win -body {
+ if {[info exists env(SystemRoot)]} {
+ file owned $env(SystemRoot)
+ } else {
+ file owned $env(windir)
+ }
} -result 0
test cmdAH-25.4 {Tcl_FileObjCmd: owned} -body {
file owned nosuchfile
diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test
index 9df6d20..1790f1d 100644
--- a/tests/cmdMZ.test
+++ b/tests/cmdMZ.test
@@ -26,7 +26,7 @@ namespace eval ::tcl::test::cmdMZ {
namespace import ::tcltest::test
testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}]
-
+
proc ListGlobMatch {expected actual} {
if {[llength $expected] != [llength $actual]} {
return 0
@@ -230,12 +230,12 @@ foreach {testid script} {
# More tests of Tcl_SourceObjCmd are in source.test
test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} -constraints {
- unixOrPc
+ unixOrWin
} -returnCodes error -body {
source
} -match glob -result {wrong # args: should be "source*fileName"}
test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} -constraints {
- unixOrPc
+ unixOrWin
} -returnCodes error -body {
source a b c d e f
} -match glob -result {wrong # args: should be "source*fileName"}
diff --git a/tests/compile.test b/tests/compile.test
index fb9a87a..4d57549 100644
--- a/tests/compile.test
+++ b/tests/compile.test
@@ -466,6 +466,67 @@ test compile-13.1 {testing underestimate of maxStackSize in list cmd} {exec} {
list [catch {exec [interpreter] << $script} msg] $msg
} {0 OK}
+# Tests of nested compile (body in body compilation), should not generate stack overflow
+# (with abnormal program termination), bug [fec0c17d39]:
+proc _ti_gencode {} {
+ # creates test interpreter on demand with [gencode] generator:
+ if {[interp exists ti]} {
+ return
+ }
+ interp create ti
+ ti eval {proc gencode {nr {cmd eval} {nl 0}} {
+ set code ""
+ set e ""; if {$nl} {set e "\n"}
+ for {set i 0} {$i < $nr} {incr i} {
+ append code "$cmd \{$e"
+ }
+ append code "lappend result 1$e"
+ for {set i 0} {$i < $nr} {incr i} {
+ append code "\}$e"
+ }
+ #puts [format "%% %.40s ... %d bytes" $code [string length $code]]
+ return $code
+ }}
+}
+test compile-13.2 {TclCompileScript: testing expected nested scripts compilation} -setup {
+ _ti_gencode
+ interp recursionlimit ti [expr {10000+50}]
+ ti eval {set result {}}
+} -body {
+ # Test different compilation variants (instructions evalStk, invokeStk, etc),
+ # with 2000 (1000 in debug) nested scripts (bodies). If you get SO/SF exceptions on some low-stack
+ # boxes or systems, please don't decrease it (either provide a constraint)
+ ti eval {foreach cmd {eval "if 1" try catch} {
+ set c [gencode [expr {![::tcl::pkgconfig get debug] ? 2000 : 1000}] $cmd]
+ if 1 $c
+ }}
+ ti eval {set result}
+} -result {1 1 1 1}
+test compile-13.3 {TclCompileScript: testing check of max depth by nested scripts compilation} -setup {
+ _ti_gencode
+ interp recursionlimit ti 100
+ ti eval {set result {}}
+} -body {
+ # Test different compilation variants (instructions evalStk, invokeStk, etc),
+ # with 500 nested scripts (bodies). It must generate "too many nested compilations"
+ # error for any variant we're testing here:
+ ti eval {foreach cmd {eval "if 1" try catch} {
+ set c [gencode [expr {![info exists ::tcl_platform(debug)] ? 2000 : 1000}] $cmd]
+ lappend errors [catch $c e] $e
+ }}
+ #puts $errors
+ # all of nested calls exceed the limit, so must end with "too many nested compilations"
+ # (or evaluations, depending on compile method/instruction and "mixed" compile within
+ # evaliation), so no one succeeds, the result must be empty:
+ ti eval {set result}
+} -result {}
+#
+# clean up:
+if {[interp exists ti]} {
+ interp delete ti
+}
+rename _ti_gencode {}
+
# Tests compile-14.* for [Bug 599788] [Bug 0c043a175a47da8c2342]
test compile-14.1 {testing errors in element name; segfault?} {} {
catch {set a([error])} msg1
diff --git a/tests/execute.test b/tests/execute.test
index 808574b..fbc4f99 100644
--- a/tests/execute.test
+++ b/tests/execute.test
@@ -37,6 +37,11 @@ testConstraint testobj [expr {
testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
testConstraint testexprlongobj [llength [info commands testexprlongobj]]
+
+if {[namespace which -command testbumpinterpepoch] eq ""} {
+ proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set }
+}
+
# Tests for the omnibus TclExecuteByteCode function:
# INST_DONE not tested
@@ -933,8 +938,7 @@ test execute-8.3 {Stack restoration} -setup {
proc f {args} "f $arglst"
proc run {} {
# bump the interp's epoch
- rename ::set ::dummy
- rename ::dummy ::set
+ testbumpinterpepoch
catch f msg
set msg
}
@@ -948,8 +952,7 @@ test execute-8.4 {Compile epoch bump effect on stack trace} -setup {
}
proc FOO {} {
catch {error bar} m o
- rename ::set ::dummy
- rename ::dummy ::set
+ testbumpinterpepoch
return -options $o $m
}
} -body {
@@ -978,10 +981,80 @@ test execute-8.5 {Bug 2038069} -setup {
invoked from within
"catch \[list error FOO\] m o"} -errorline 2}
+test execute-8.6 {Compile epoch bump in global level (bug [fa6bf38d07])} -setup {
+ interp create slave
+ slave eval {
+ package require tcltest
+ catch [list package require -exact Tcltest [info patchlevel]]
+ ::tcltest::loadTestedCommands
+ if {[namespace which -command testbumpinterpepoch] eq ""} {
+ proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set }
+ }
+ }
+} -body {
+ slave eval {
+ lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C;
+ }
+ slave eval {
+ set i 0; while {[incr i] < 3} {
+ lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C;
+ }
+ }
+ slave eval {
+ set i 0; while {[incr i] < 3} {
+ lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C;
+ }
+ }
+ slave eval {
+ catch {
+ lappend res A; testbumpinterpepoch; lappend res B; error test; lappend res C;
+ }
+ }
+ slave eval {set res}
+} -cleanup {
+ interp delete slave
+} -result [lrepeat 4 A B]
+test execute-8.7 {Compile epoch bump in global level (bug [fa6bf38d07]), exception case} -setup {
+ interp create slave
+ slave eval {
+ package require tcltest
+ catch [list package require -exact Tcltest [info patchlevel]]
+ ::tcltest::loadTestedCommands
+ if {[namespace which -command testbumpinterpepoch] eq ""} {
+ proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set }
+ }
+ }
+} -body {
+ set res {}
+ lappend res [catch {
+ slave eval {
+ lappend res A; testbumpinterpepoch; lappend res B; return -code error test; lappend res C;
+ }
+ } e] $e
+ lappend res [catch {
+ slave eval {
+ lappend res A; testbumpinterpepoch; lappend res B; error test; lappend res C;
+ }
+ } e] $e
+ lappend res [catch {
+ slave eval {
+ lappend res A; testbumpinterpepoch; lappend res B; return -code return test; lappend res C;
+ }
+ } e] $e
+ lappend res [catch {
+ slave eval {
+ lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C;
+ }
+ } e] $e
+ list $res [slave eval {set res}]
+} -cleanup {
+ interp delete slave
+} -result [list {1 test 1 test 2 test 3 {}} [lrepeat 4 A B]]
+
test execute-9.1 {Interp result resetting [Bug 1522803]} {
set c 0
catch {
- catch {set foo}
+ catch {error foo}
expr {1/$c}
}
if {[string match *foo* $::errorInfo]} {
@@ -1016,6 +1089,7 @@ test execute-10.3 {Bug 3072640} -setup {
proc t {args} {
incr ::foo
}
+ set ::foo 0
trace add execution ::generate enterstep ::t
} -body {
coroutine coro generate 5
diff --git a/tests/fCmd.test b/tests/fCmd.test
index a6e90a1..e8ed6f9 100644
--- a/tests/fCmd.test
+++ b/tests/fCmd.test
@@ -276,7 +276,7 @@ test fCmd-3.14 {FileCopyRename: FileBasename fails} -setup {
} -result {user "_totally_bogus_user" doesn't exist}
test fCmd-3.15 {FileCopyRename: source[0] == '\0'} -setup {
cleanup
-} -constraints {notRoot unixOrPc} -returnCodes error -body {
+} -constraints {notRoot unixOrWin} -returnCodes error -body {
file mkdir td1
file rename / td1
} -result {error renaming "/" to "td1": file already exists}
@@ -416,7 +416,7 @@ test fCmd-5.4 {TclFileDeleteCmd: multiple files} -constraints notRoot -setup {
} -cleanup {cleanup} -result {1 1 1 0 0 0}
test fCmd-5.5 {TclFileDeleteCmd: stop at first error} -setup {
cleanup
-} -constraints {notRoot unixOrPc} -body {
+} -constraints {notRoot unixOrWin} -body {
createfile tf1
createfile tf2
file mkdir td1
@@ -1116,7 +1116,7 @@ test fCmd-10.5 {file copy: comprehensive: dir to empty dir} -setup {
} -result [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4 tds1 tds2 tds3 tds4} {1 {error copying "td1" to "[file join td2 td1]": file already exists}} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} 1 1 1}]
test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} -setup {
cleanup
-} -constraints {notRoot unixOrPc testchmod} -body {
+} -constraints {notRoot unixOrWin testchmod} -body {
file mkdir tds1
file mkdir tds2
file mkdir [file join tdd1 tds1 xxx]
diff --git a/tests/fileName.test b/tests/fileName.test
index 7b51da1..0e4cb9e 100644
--- a/tests/fileName.test
+++ b/tests/fileName.test
@@ -1089,13 +1089,13 @@ file delete -force $tildeglobname
set globname globTest
unset horribleglobname tildeglobname
-test filename-12.1 {simple globbing} {unixOrPc} {
+test filename-12.1 {simple globbing} {unixOrWin} {
glob {}
} {.}
-test filename-12.1.1 {simple globbing} -constraints {unixOrPc} -body {
+test filename-12.1.1 {simple globbing} -constraints {unixOrWin} -body {
glob -types f {}
} -returnCodes error -result {no files matched glob pattern ""}
-test filename-12.1.2 {simple globbing} {unixOrPc} {
+test filename-12.1.2 {simple globbing} {unixOrWin} {
glob -types d {}
} {.}
test filename-12.1.3 {simple globbing} {unix} {
@@ -1116,7 +1116,7 @@ test filename-12.3 {simple globbing} {
set globPreResult globTest/
set x1 x1.c
set y1 y1.c
-test filename-12.4 {simple globbing} {unixOrPc} {
+test filename-12.4 {simple globbing} {unixOrWin} {
lsort [glob globTest/x1.c globTest/y1.c globTest/foo]
} "$globPreResult$x1 $globPreResult$y1"
test filename-12.5 {simple globbing} {
@@ -1178,32 +1178,32 @@ test filename-13.9 {globbing with brace substitution} {
test filename-13.10 {globbing with brace substitution} {
lsort [glob globTest/\{x,,y\}1.c]
} [list $globPreResult$x1 $globPreResult$y1]
-test filename-13.11 {globbing with brace substitution} {unixOrPc} {
+test filename-13.11 {globbing with brace substitution} {unixOrWin} {
lsort [glob globTest/\{x,x\\,z,z\}1.c]
} [lsort {globTest/x1.c globTest/x,z1.c globTest/z1.c}]
test filename-13.13 {globbing with brace substitution} {
lsort [glob globTest/{a,b,x,y}1.c]
} [list $globPreResult$x1 $globPreResult$y1]
-test filename-13.14 {globbing with brace substitution} {unixOrPc} {
+test filename-13.14 {globbing with brace substitution} {unixOrWin} {
lsort [glob {globTest/{x1,y2,weird name}.c}]
} {{globTest/weird name.c} globTest/x1.c}
-test filename-13.16 {globbing with brace substitution} {unixOrPc} {
+test filename-13.16 {globbing with brace substitution} {unixOrWin} {
lsort [glob globTest/{x1.c,a1/*}]
} {globTest/a1/b1 globTest/a1/b2 globTest/x1.c}
-test filename-13.18 {globbing with brace substitution} {unixOrPc} {
+test filename-13.18 {globbing with brace substitution} {unixOrWin} {
lsort [glob globTest/{x1.c,{a},a1/*}]
} {globTest/a1/b1 globTest/a1/b2 globTest/x1.c}
-test filename-13.20 {globbing with brace substitution} {unixOrPc} {
+test filename-13.20 {globbing with brace substitution} {unixOrWin} {
lsort [glob globTest/{a,x}1/*/{x,y}*]
} {globTest/a1/b1/x2.c globTest/a1/b2/y2.c}
test filename-13.22 {globbing with brace substitution} -body {
glob globTest/\{a,x\}1/*/\{
} -returnCodes error -result {unmatched open-brace in file name}
-test filename-14.1 {asterisks, question marks, and brackets} {unixOrPc} {
+test filename-14.1 {asterisks, question marks, and brackets} {unixOrWin} {
lsort [glob glo*/*.c]
} {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
-test filename-14.3 {asterisks, question marks, and brackets} {unixOrPc} {
+test filename-14.3 {asterisks, question marks, and brackets} {unixOrWin} {
lsort [glob globTest/?1.c]
} {globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.5 {asterisks, question marks, and brackets} -setup {
@@ -1213,7 +1213,7 @@ test filename-14.5 {asterisks, question marks, and brackets} -setup {
file rename globTest [file join globTestContext globTest]
set savepwd [pwd]
cd globTestContext
-} -constraints {unixOrPc} -body {
+} -constraints {unixOrWin} -body {
lsort [glob */*/*/*.c]
} -cleanup {
# Reset to where we were
@@ -1227,16 +1227,16 @@ test filename-14.7 {asterisks, question marks, and brackets} {unix} {
test filename-14.7.1 {asterisks, question marks, and brackets} {win} {
lsort [glob globTest/*]
} {globTest/.1 globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
-test filename-14.9 {asterisks, question marks, and brackets} {unixOrPc} {
+test filename-14.9 {asterisks, question marks, and brackets} {unixOrWin} {
lsort [glob globTest/.*]
} {globTest/. globTest/.. globTest/.1}
-test filename-14.11 {asterisks, question marks, and brackets} {unixOrPc} {
+test filename-14.11 {asterisks, question marks, and brackets} {unixOrWin} {
lsort [glob globTest/*/*]
} {globTest/a1/b1 globTest/a1/b2 globTest/a2/b3}
-test filename-14.13 {asterisks, question marks, and brackets} {unixOrPc} {
+test filename-14.13 {asterisks, question marks, and brackets} {unixOrWin} {
lsort [glob {globTest/[xyab]1.*}]
} {globTest/x1.c globTest/y1.c}
-test filename-14.15 {asterisks, question marks, and brackets} {unixOrPc} {
+test filename-14.15 {asterisks, question marks, and brackets} {unixOrWin} {
lsort [glob globTest/*/]
} {globTest/a1/ globTest/a2/ globTest/a3/}
test filename-14.17 {asterisks, question marks, and brackets} -setup {
@@ -1248,7 +1248,7 @@ test filename-14.17 {asterisks, question marks, and brackets} -setup {
} -cleanup {
set env(HOME) $temp
} -result [list [file join $env(HOME) globTest z1.c]]
-test filename-14.18 {asterisks, question marks, and brackets} {unixOrPc} {
+test filename-14.18 {asterisks, question marks, and brackets} {unixOrWin} {
lsort [glob globTest/*.c goo/*]
} {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.20 {asterisks, question marks, and brackets} {
@@ -1287,16 +1287,16 @@ test filename-14.25.1 {type specific globbing} {win} {
test filename-14.26 {type specific globbing} {
glob -nocomplain -dir globTest -types {readonly} *
} {}
-test filename-14.27 {Bug 2710920} {unixOrPc} {
+test filename-14.27 {Bug 2710920} {unixOrWin} {
file tail [lindex [lsort [glob globTest/*/]] 0]
} a1
-test filename-14.28 {Bug 2710920} {unixOrPc} {
+test filename-14.28 {Bug 2710920} {unixOrWin} {
file dirname [lindex [lsort [glob globTest/*/]] 0]
} globTest
-test filename-14.29 {Bug 2710920} {unixOrPc} {
+test filename-14.29 {Bug 2710920} {unixOrWin} {
file extension [lindex [lsort [glob globTest/*/]] 0]
} {}
-test filename-14.30 {Bug 2710920} {unixOrPc} {
+test filename-14.30 {Bug 2710920} {unixOrWin} {
file rootname [lindex [lsort [glob globTest/*/]] 0]
} globTest/a1/
diff --git a/tests/interp.test b/tests/interp.test
index 76ac01f..599ac08 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -1836,7 +1836,7 @@ test interp-23.1 {testing hiding vs aliases: unsafe interp} -setup {
test interp-23.2 {testing hiding vs aliases: safe interp} -setup {
catch {interp delete a}
set l ""
-} -constraints {unixOrPc} -body {
+} -constraints {unixOrWin} -body {
interp create a -safe
lappend l [lsort [interp hidden a]]
a alias bar bar
diff --git a/tests/io.test b/tests/io.test
index 6d9e1c3..9bd87ef 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -2212,7 +2212,7 @@ test io-27.4 {FlushChannel, implicit flush when buffer fills} {
set l
} {0 60 72}
test io-27.5 {FlushChannel, implicit flush when buffer fills and on close} \
- {unixOrPc} {
+ {unixOrWin} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -buffersize 60 -eofchar {}
@@ -8084,7 +8084,7 @@ test io-53.17 {[7c187a3773] MBWrite: proper inQueueTail handling} -setup {
removeFile out
} -result {line 100 line}
-test io-54.1 {Recursive channel events} {socket fileevent} {
+test io-54.1 {Recursive channel events} {socket fileevent knownMsvcBug} {
# This test checks to see if file events are delivered during recursive
# event loops when there is buffered data on the channel.
@@ -8293,7 +8293,7 @@ test io-57.2 {buffered data and file events, read} {fileevent} {
set result
} {1 readable 234567890 timer}
-test io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrPc openpipe fileevent} {
+test io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrWin openpipe fileevent} {
set out [open $path(script) w]
puts $out {
puts "normal message from pipe"
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index 89afb0a..0e47d2f 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -25,7 +25,6 @@ package require tcltests
# Custom constraints used in this file
testConstraint testchannel [llength [info commands testchannel]]
-testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}]
#----------------------------------------------------------------------
@@ -295,7 +294,7 @@ removeFile fconfigure.dummy
test iocmd-8.14 {fconfigure command} {
fconfigure stdin -buffers
} 4096
-test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOrPc} -setup {
+test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOrWin} -setup {
set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0]
set port [lindex [fconfigure $srv -sockname] 2]
proc iocmdSRV {sock ip port} {close $sock}
@@ -403,18 +402,18 @@ test iocmd-10.5 {fblocked command} {
set path(test4) [makeFile {} test4]
set path(test5) [makeFile {} test5]
-test iocmd-11.1 {I/O to command pipelines} {unixOrPc unixExecs} {
+test iocmd-11.1 {I/O to command pipelines} {unixOrWin unixExecs} {
set f [open $path(test4) w]
close $f
list [catch {open "| cat < \"$path(test4)\" > \"$path(test5)\"" w} msg] $msg $::errorCode
} {1 {can't write input to command: standard input was redirected} {TCL OPERATION EXEC BADREDIRECT}}
-test iocmd-11.2 {I/O to command pipelines} {unixOrPc unixExecs} {
+test iocmd-11.2 {I/O to command pipelines} {unixOrWin unixExecs} {
list [catch {open "| echo > \"$path(test5)\"" r} msg] $msg $::errorCode
} {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}}
-test iocmd-11.3 {I/O to command pipelines} {unixOrPc unixExecs} {
+test iocmd-11.3 {I/O to command pipelines} {unixOrWin unixExecs} {
list [catch {open "| echo > \"$path(test5)\"" r+} msg] $msg $::errorCode
} {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}}
-test iocmd-11.4 {I/O to command pipelines} {notValgrind unixOrPc} {
+test iocmd-11.4 {I/O to command pipelines} {notValgrind unixOrWin} {
list [catch {open "| no_such_command_exists" rb} msg] $msg $::errorCode
} {1 {couldn't execute "no_such_command_exists": no such file or directory} {POSIX ENOENT {no such file or directory}}}
@@ -811,7 +810,7 @@ test iocmd-21.19 {chan create, init failure -> no channel, no finalize} -match g
rename foo {}
set res
} -result {{} {initialize rc* {read write}} 1 {*all required methods*} {}}
-test iocmd-21.20 {Bug 88aef05cda} -constraints knownMsvcBug -setup {
+test iocmd-21.20 {Bug 88aef05cda} -setup {
proc foo {method chan args} {
switch -- $method blocking {
chan configure $chan -blocking [lindex $args 0]
@@ -825,11 +824,11 @@ test iocmd-21.20 {Bug 88aef05cda} -constraints knownMsvcBug -setup {
}
set ch [chan create {read write} foo]
} -body {
- list [catch {chan configure $ch -blocking 0} m] $m
+ chan configure $ch -blocking 0
} -cleanup {
close $ch
rename foo {}
-} -match glob -result {1 {*nested eval*}}
+} -match glob -returnCodes 1 -result {*(infinite loop?)*}
test iocmd-21.21 {[close] in [read] segfaults} -setup {
proc foo {method chan args} {
switch -- $method initialize {
diff --git a/tests/lrange.test b/tests/lrange.test
index dcc0eec..4f7c0d3 100644
--- a/tests/lrange.test
+++ b/tests/lrange.test
@@ -133,15 +133,19 @@ test lrange-3.7b.2 {not compiled on empty not list object, 2nd regression test,
list [$cmd {} 0 1] [$cmd [lindex a -1] 0 1] [$cmd [set a {}] 0 1] \
[$cmd {} 0-1 end+1] [$cmd [lindex a -1] 0-1 end+1] [$cmd $a 0-1 end+1]
} [lrepeat 6 {}]
-test lrange-3.7c.2 {compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} {
+test lrange-3.7c.2 {compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} -constraints {
+ testpurebytesobj
+} -body {
list [lrange [testpurebytesobj] 0 1] [lrange [testpurebytesobj { }] 0 1] [lrange [set a [testpurebytesobj {}]] 0 1] \
[lrange [testpurebytesobj] 0-1 end+1] [lrange [testpurebytesobj { }] 0-1 end+1] [lrange $a 0-1 end+1]
-} [lrepeat 6 {}]
-test lrange-3.7d.2 {not compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} {
+} -result [lrepeat 6 {}]
+test lrange-3.7d.2 {not compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} -constraints {
+ testpurebytesobj
+} -body {
set cmd lrange
list [$cmd [testpurebytesobj] 0 1] [$cmd [testpurebytesobj { }] 0 1] [$cmd [set a [testpurebytesobj {}]] 0 1] \
[$cmd [testpurebytesobj] 0-1 end+1] [$cmd [testpurebytesobj { }] 0-1 end+1] [$cmd $a 0-1 end+1]
-} [lrepeat 6 {}]
+} -result [lrepeat 6 {}]
test lrange-4.1 {lrange pure promise} -body {
set ll1 [list $tcl_version 2 3 4]
diff --git a/tests/namespace.test b/tests/namespace.test
index e90c753..0d93092 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -2624,6 +2624,7 @@ test namespace-51.6 {name resolution path control} -body {
namespace delete ::test_ns_1
catch {rename ::pathtestB {}}
catch {rename ::pathtestD {}}
+ catch {rename ::pathtestC {}}
}
test namespace-51.7 {name resolution path control} -body {
namespace eval ::test_ns_1 {
diff --git a/tests/pid.test b/tests/pid.test
index d21dbaa..af21f30 100644
--- a/tests/pid.test
+++ b/tests/pid.test
@@ -21,7 +21,7 @@ testConstraint pidDefined [llength [info commands pid]]
test pid-1.1 {pid command} pidDefined {
regexp {(^[0-9]+$)|(^0x[0-9a-fA-F]+$)} [pid]
} 1
-test pid-1.2 {pid command} -constraints {unixOrPc unixExecs pidDefined} -setup {
+test pid-1.2 {pid command} -constraints {unixOrWin unixExecs pidDefined} -setup {
set path(test1) [makeFile {} test1]
file delete $path(test1)
} -body {
diff --git a/tests/socket.test b/tests/socket.test
index 84320bd..20b890d 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -1084,7 +1084,7 @@ test socket_$af-7.4 {testing socket specific options} -constraints [list socket
test socket_$af-7.5 {testing socket specific options} -setup {
set timer [after 10000 "set x timed_out"]
set l ""
-} -constraints [list socket supported_$af unixOrPc] -body {
+} -constraints [list socket supported_$af unixOrWin] -body {
set s [socket -server accept 0]
proc accept {s a p} {
global x
diff --git a/tests/tcltest.test b/tests/tcltest.test
index ca720ee..c856209 100644
--- a/tests/tcltest.test
+++ b/tests/tcltest.test
@@ -98,44 +98,44 @@ proc slave {msgVar args} {
}
return $code
}
-test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrPc} {
+test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrWin} {
set result [slave msg test.tcl]
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 0 0 1}
-test tcltest-2.1 {tcltest -verbose 'b'} {unixOrPc} {
+test tcltest-2.1 {tcltest -verbose 'b'} {unixOrWin} {
set result [slave msg test.tcl -verbose 'b']
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 0 0 1}
-test tcltest-2.2 {tcltest -verbose 'p'} {unixOrPc} {
+test tcltest-2.2 {tcltest -verbose 'p'} {unixOrWin} {
set result [slave msg test.tcl -verbose 'p']
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 0 1 0 1}
-test tcltest-2.3 {tcltest -verbose 's'} {unixOrPc} {
+test tcltest-2.3 {tcltest -verbose 's'} {unixOrWin} {
set result [slave msg test.tcl -verbose 's']
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 0 0 1 1}
-test tcltest-2.4 {tcltest -verbose 'ps'} {unixOrPc} {
+test tcltest-2.4 {tcltest -verbose 'ps'} {unixOrWin} {
set result [slave msg test.tcl -verbose 'ps']
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 0 1 1 1}
-test tcltest-2.5 {tcltest -verbose 'psb'} {unixOrPc} {
+test tcltest-2.5 {tcltest -verbose 'psb'} {unixOrWin} {
set result [slave msg test.tcl -verbose 'psb']
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 1 1 1}
-test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrPc} {
+test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrWin} {
set result [slave msg test.tcl -verbose "pass skip body"]
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
@@ -143,7 +143,7 @@ test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrPc} {
} {0 1 1 1 1}
test tcltest-2.6 {tcltest -verbose 't'} {
- -constraints {unixOrPc}
+ -constraints {unixOrWin}
-body {
set result [slave msg test.tcl -verbose 't']
list $result $msg
@@ -153,7 +153,7 @@ test tcltest-2.6 {tcltest -verbose 't'} {
}
test tcltest-2.6a {tcltest -verbose 'start'} {
- -constraints {unixOrPc}
+ -constraints {unixOrWin}
-body {
set result [slave msg test.tcl -verbose start]
list $result $msg
@@ -176,7 +176,7 @@ test tcltest-2.7 {tcltest::verbose} {
}
test tcltest-2.8 {tcltest -verbose 'error'} {
- -constraints {unixOrPc}
+ -constraints {unixOrWin}
-body {
set result [slave msg test.tcl -verbose error]
list $result $msg
@@ -185,22 +185,22 @@ test tcltest-2.8 {tcltest -verbose 'error'} {
-match regexp
}
# -match, [match]
-test tcltest-3.1 {tcltest -match 'a*'} {unixOrPc} {
+test tcltest-3.1 {tcltest -match 'a*'} {unixOrWin} {
set result [slave msg test.tcl -match a* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
} {0 1 0 0 1}
-test tcltest-3.2 {tcltest -match 'b*'} {unixOrPc} {
+test tcltest-3.2 {tcltest -match 'b*'} {unixOrWin} {
set result [slave msg test.tcl -match b* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg]
} {0 0 1 0 1}
-test tcltest-3.3 {tcltest -match 'c*'} {unixOrPc} {
+test tcltest-3.3 {tcltest -match 'c*'} {unixOrWin} {
set result [slave msg test.tcl -match c* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+0.+Skipped.+4.+Failed.+0" $msg]
} {0 0 0 1 1}
-test tcltest-3.4 {tcltest -match 'a* b*'} {unixOrPc} {
+test tcltest-3.4 {tcltest -match 'a* b*'} {unixOrWin} {
set result [slave msg test.tcl -match {a* b*} -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg]
@@ -220,27 +220,27 @@ test tcltest-3.5 {tcltest::match} {
}
# -skip, [skip]
-test tcltest-4.1 {tcltest -skip 'a*'} {unixOrPc} {
+test tcltest-4.1 {tcltest -skip 'a*'} {unixOrWin} {
set result [slave msg test.tcl -skip a* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+0.+Skipped.+2.+Failed.+1" $msg]
} {0 0 1 1 1}
-test tcltest-4.2 {tcltest -skip 'b*'} {unixOrPc} {
+test tcltest-4.2 {tcltest -skip 'b*'} {unixOrWin} {
set result [slave msg test.tcl -skip b* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg]
} {0 1 0 1 1}
-test tcltest-4.3 {tcltest -skip 'c*'} {unixOrPc} {
+test tcltest-4.3 {tcltest -skip 'c*'} {unixOrWin} {
set result [slave msg test.tcl -skip c* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 1 0 1}
-test tcltest-4.4 {tcltest -skip 'a* b*'} {unixOrPc} {
+test tcltest-4.4 {tcltest -skip 'a* b*'} {unixOrWin} {
set result [slave msg test.tcl -skip {a* b*} -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg]
} {0 0 0 1 1}
-test tcltest-4.5 {tcltest -match 'a* b*' -skip 'b*'} {unixOrPc} {
+test tcltest-4.5 {tcltest -match 'a* b*' -skip 'b*'} {unixOrWin} {
set result [slave msg test.tcl -match {a* b*} -skip b* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
@@ -261,12 +261,12 @@ test tcltest-4.6 {tcltest::skip} {
# -constraints, -limitconstraints, [testConstraint],
# $constraintsSpecified, [limitConstraints]
-test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrPc} {
+test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrWin} {
set result [slave msg test.tcl -constraints knownBug -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+2.+Skipped.+0.+Failed.+2" $msg]
} {0 1 1 1 1}
-test tcltest-5.2 {tcltest -constraints 'knownBug' -limitconstraints 1} {unixOrPc} {
+test tcltest-5.2 {tcltest -constraints 'knownBug' -limitconstraints 1} {unixOrWin} {
set result [slave msg test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1]
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
@@ -355,7 +355,7 @@ set printerror [makeFile {
} printerror.tcl]
test tcltest-6.1 {tcltest -outfile, -errfile defaults} {
- -constraints unixOrPc
+ -constraints unixOrWin
-body {
slave msg $printerror
return $msg
@@ -363,21 +363,21 @@ test tcltest-6.1 {tcltest -outfile, -errfile defaults} {
-result {a test.*a really}
-match regexp
}
-test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrPc unixExecs} {
+test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrWin unixExecs} {
slave msg $printerror -outfile a.tmp
set result1 [catch {exec grep "a test" a.tmp}]
set result2 [catch {exec grep "a really" a.tmp}]
list [regexp "a test" $msg] [regexp "a really" $msg] \
$result1 $result2 [file exists a.tmp] [file delete a.tmp]
} {0 1 0 1 1 {}}
-test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrPc unixExecs} {
+test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrWin unixExecs} {
slave msg $printerror -errfile a.tmp
set result1 [catch {exec grep "a test" a.tmp}]
set result2 [catch {exec grep "a really" a.tmp}]
list [regexp "a test" $msg] [regexp "a really" $msg] \
$result1 $result2 [file exists a.tmp] [file delete a.tmp]
} {1 0 1 0 1 {}}
-test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrPc unixExecs} {
+test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrWin unixExecs} {
slave msg $printerror -outfile a.tmp -errfile b.tmp
set result1 [catch {exec grep "a test" a.tmp}]
set result2 [catch {exec grep "a really" b.tmp}]
@@ -464,25 +464,25 @@ test tcltest-6.8 {tcltest::outputFile (implicit outputFile)} {
# Must use child processes to test -debug because it always writes
# messages to stdout, and we have no way to capture stdout of a
# slave interp
-test tcltest-7.1 {tcltest test.tcl -debug 0} {unixOrPc} {
+test tcltest-7.1 {tcltest test.tcl -debug 0} {unixOrWin} {
catch {exec [interpreter] test.tcl -debug 0} msg
regexp "Flags passed into tcltest" $msg
} {0}
-test tcltest-7.2 {tcltest test.tcl -debug 1} {unixOrPc} {
+test tcltest-7.2 {tcltest test.tcl -debug 1} {unixOrWin} {
catch {exec [interpreter] test.tcl -debug 1 -skip b*} msg
list [regexp userSpecifiedSkip $msg] \
[regexp "Flags passed into tcltest" $msg]
} {1 0}
-test tcltest-7.3 {tcltest test.tcl -debug 1} {unixOrPc} {
+test tcltest-7.3 {tcltest test.tcl -debug 1} {unixOrWin} {
catch {exec [interpreter] test.tcl -debug 1 -match b*} msg
list [regexp userSpecifiedNonMatch $msg] \
[regexp "Flags passed into tcltest" $msg]
} {1 0}
-test tcltest-7.4 {tcltest test.tcl -debug 2} {unixOrPc} {
+test tcltest-7.4 {tcltest test.tcl -debug 2} {unixOrWin} {
catch {exec [interpreter] test.tcl -debug 2} msg
list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg]
} {1 0}
-test tcltest-7.5 {tcltest test.tcl -debug 3} {unixOrPc} {
+test tcltest-7.5 {tcltest test.tcl -debug 3} {unixOrWin} {
catch {exec [interpreter] test.tcl -debug 3} msg
list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg]
} {1 1}
@@ -522,7 +522,7 @@ set normaldirectory [makeDirectory normaldirectory]
normalizePath normaldirectory
# -tmpdir, [temporaryDirectory]
-test tcltest-8.1 {tcltest a.tcl -tmpdir a} -constraints unixOrPc -setup {
+test tcltest-8.1 {tcltest a.tcl -tmpdir a} -constraints unixOrWin -setup {
file delete -force thisdirectorydoesnotexist
} -body {
slave msg $a -tmpdir thisdirectorydoesnotexist
@@ -531,7 +531,7 @@ test tcltest-8.1 {tcltest a.tcl -tmpdir a} -constraints unixOrPc -setup {
file delete -force thisdirectorydoesnotexist
} -result 1
test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} {
- -constraints unixOrPc
+ -constraints unixOrWin
-body {
slave msg $a -tmpdir $tdiaf
return $msg
@@ -572,7 +572,7 @@ testConstraint notFAT [expr {
}]
# FAT/NTFS permissions are fairly hopeless; ignore this test if that FS is used
test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {
- -constraints {unixOrPc notRoot notFAT}
+ -constraints {unixOrWin notRoot notFAT}
-body {
slave msg $a -tmpdir $notWriteableDir
return $msg
@@ -581,7 +581,7 @@ test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {
-match glob
}
test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} {
- -constraints unixOrPc
+ -constraints unixOrWin
-body {
slave msg $a -tmpdir $normaldirectory
# The join is necessary because the message can be split on multiple
@@ -624,7 +624,7 @@ test tcltest-8.6a {temporaryDirectory - test format 2} -setup {
cd [temporaryDirectory]
# -testdir, [testsDirectory]
test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {
- -constraints unixOrPc
+ -constraints unixOrWin
-setup {
file delete -force thisdirectorydoesnotexist
}
@@ -636,7 +636,7 @@ test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {
-result {*does not exist*}
}
test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} {
- -constraints unixOrPc
+ -constraints unixOrWin
-body {
slave msg $a -testdir $tdiaf
return $msg
@@ -654,7 +654,7 @@ test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} {
-result {*not readable*}
}
test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} {
- -constraints unixOrPc
+ -constraints unixOrWin
-body {
slave msg $a -testdir $normaldirectory
# The join is necessary because the message can be split on multiple
@@ -731,7 +731,7 @@ removeFile thisdirectoryisafile
removeDirectory normaldirectory
# -file, -notfile, [matchFiles], [skipFiles]
-test tcltest-9.1 {-file d*.tcl} -constraints {unixOrPc} -setup {
+test tcltest-9.1 {-file d*.tcl} -constraints {unixOrWin} -setup {
set old [testsDirectory]
testsDirectory [file dirname [info script]]
} -body {
@@ -741,7 +741,7 @@ test tcltest-9.1 {-file d*.tcl} -constraints {unixOrPc} -setup {
testsDirectory $old
} -match regexp -result {dstring\.test}
-test tcltest-9.2 {-file d*.tcl} -constraints {unixOrPc} -setup {
+test tcltest-9.2 {-file d*.tcl} -constraints {unixOrWin} -setup {
set old [testsDirectory]
testsDirectory [file dirname [info script]]
} -body {
@@ -806,23 +806,23 @@ set mc [makeFile {
} makecore.tcl]
cd [temporaryDirectory]
-test tcltest-10.1 {-preservecore 0} {unixOrPc} {
+test tcltest-10.1 {-preservecore 0} {unixOrWin} {
slave msg $mc -preservecore 0
file delete core
regexp "Core file produced" $msg
} {0}
-test tcltest-10.2 {-preservecore 1} {unixOrPc} {
+test tcltest-10.2 {-preservecore 1} {unixOrWin} {
slave msg $mc -preservecore 1
file delete core
regexp "Core file produced" $msg
} {1}
-test tcltest-10.3 {-preservecore 2} {unixOrPc} {
+test tcltest-10.3 {-preservecore 2} {unixOrWin} {
slave msg $mc -preservecore 2
file delete core
list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \
[regexp "core-" $msg] [file delete core-makecore]
} {1 1 1 {}}
-test tcltest-10.4 {-preservecore 3} {unixOrPc} {
+test tcltest-10.4 {-preservecore 3} {unixOrWin} {
slave msg $mc -preservecore 3
file delete core
list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \
@@ -853,13 +853,13 @@ set contents {
}
set loadfile [makeFile $contents load.tcl]
-test tcltest-12.1 {-load xxx} {unixOrPc} {
+test tcltest-12.1 {-load xxx} {unixOrWin} {
slave msg $loadfile -load xxx
return $msg
} {xxx}
# Using child process because of -debug usage.
-test tcltest-12.2 {-loadfile load.tcl} {unixOrPc} {
+test tcltest-12.2 {-loadfile load.tcl} {unixOrWin} {
catch {exec [interpreter] $loadfile -debug 2 -loadfile $loadfile} msg
list \
[regexp {tcltest} [join [list $msg] [split $msg \n]]] \
@@ -950,7 +950,7 @@ set allfile [makeFile {
cd [workingDirectory]
test tcltest-14.1 {-singleproc - single process} {
- -constraints {unixOrPc}
+ -constraints {unixOrWin}
-body {
slave msg $allfile -singleproc 0 -tmpdir [temporaryDirectory]
return $msg
@@ -960,7 +960,7 @@ test tcltest-14.1 {-singleproc - single process} {
}
test tcltest-14.2 {-singleproc - multiple process} {
- -constraints {unixOrPc}
+ -constraints {unixOrWin}
-body {
slave msg $allfile -singleproc 1 -tmpdir [temporaryDirectory]
return $msg
@@ -1024,7 +1024,7 @@ makeFile {
} all.tcl $dtd3
test tcltest-15.1 {basic directory walking} {
- -constraints {unixOrPc}
+ -constraints {unixOrWin}
-body {
if {[slave msg \
[file join $dtd all.tcl] \
@@ -1038,7 +1038,7 @@ test tcltest-15.1 {basic directory walking} {
}
test tcltest-15.2 {-asidefromdir} {
- -constraints {unixOrPc}
+ -constraints {unixOrWin}
-body {
if {[slave msg \
[file join $dtd all.tcl] \
@@ -1056,7 +1056,7 @@ Error: No test files remain after applying your match and skip patterns!$}
}
test tcltest-15.3 {-relateddir, non-existent dir} {
- -constraints {unixOrPc}
+ -constraints {unixOrWin}
-body {
if {[slave msg \
[file join $dtd all.tcl] \
@@ -1071,7 +1071,7 @@ test tcltest-15.3 {-relateddir, non-existent dir} {
}
test tcltest-15.4 {-relateddir, subdir} {
- -constraints {unixOrPc}
+ -constraints {unixOrWin}
-body {
if {[slave msg \
[file join $dtd all.tcl] \
@@ -1084,7 +1084,7 @@ test tcltest-15.4 {-relateddir, subdir} {
-result {Tests located in:.*dirtestdir2.[^23]}
}
test tcltest-15.5 {-relateddir, -asidefromdir} {
- -constraints {unixOrPc}
+ -constraints {unixOrWin}
-body {
if {[slave msg \
[file join $dtd all.tcl] \
@@ -1173,7 +1173,7 @@ test tcltest-19.1 {TCLTEST_OPTIONS default} -setup {
cd [temporaryDirectory]
# PrintError
-test tcltest-20.1 {PrintError} {unixOrPc} {
+test tcltest-20.1 {PrintError} {unixOrWin} {
set result [slave msg $printerror]
list $result [regexp "Error: a really short string" $msg] \
[regexp " \"quotes\"" $msg] [regexp " \"Path" $msg] \
@@ -1409,7 +1409,7 @@ makeFile {
# Must use a child process because stdout/stderr parsing can't be
# duplicated in slave interp.
test tcltest-22.1 {runAllTests} {
- -constraints {unixOrPc}
+ -constraints {unixOrWin}
-body {
exec [interpreter] \
[file join $atd all.tcl] \
diff --git a/tests/tm.test b/tests/tm.test
index 567d351..001b73e 100644
--- a/tests/tm.test
+++ b/tests/tm.test
@@ -200,7 +200,7 @@ test tm-3.11 {tm: module path management, remove ignores unknown path} -setup {
proc genpaths {base} {
# Normalizing picks up drive letters on windows [Bug 1053568]
set base [file normalize $base]
- lassign [split [package present Tcl] .] major minor
+ regexp {^(\d+)\.(\d+)} [package provide Tcl] - major minor
set results {}
set base [file join $base tcl$major]
lappend results [file join $base site-tcl]
diff --git a/tests/uplevel.test b/tests/uplevel.test
index be2268a..2cbea1a 100644
--- a/tests/uplevel.test
+++ b/tests/uplevel.test
@@ -83,6 +83,16 @@ test uplevel-3.4 {uplevel to same level} {
a1
} 55
+test uplevel-4.0.1 {error: non-existent level} -body {
+ uplevel #0 { uplevel { set y 222 } }
+} -returnCodes error -result {bad level "1"}
+test uplevel-4.0.2 {error: non-existent level} -setup {
+ interp create i
+} -body {
+ i eval { uplevel { set y 222 } }
+} -returnCodes error -result {bad level "1"} -cleanup {
+ interp delete i
+}
test uplevel-4.1 {error: non-existent level} -returnCodes error -body {
apply {{} {
uplevel #2 {set y 222}
diff --git a/tests/upvar.test b/tests/upvar.test
index 91153a6..a483569 100644
--- a/tests/upvar.test
+++ b/tests/upvar.test
@@ -304,6 +304,17 @@ test upvar-8.3 {errors in upvar command} -returnCodes error -body {
proc p1 {} {upvar a b c}
p1
} -result {bad level "a"}
+test upvar-8.3.1 {bad level for upvar (upvar at top-level, bug [775ee88560])} -body {
+ proc p1 {} { uplevel { upvar b b; lappend b UNEXPECTED } }
+ uplevel #0 { p1 }
+} -returnCodes error -result {bad level "1"}
+test upvar-8.3.2 {bad level for upvar (upvar at top-level, bug [775ee88560])} -setup {
+ interp create i
+} -body {
+ i eval { upvar b b; lappend b UNEXPECTED }
+} -returnCodes error -result {bad level "1"} -cleanup {
+ interp delete i
+}
test upvar-8.4 {errors in upvar command} -returnCodes error -body {
proc p1 {} {upvar 0 b b}
p1
@@ -355,7 +366,7 @@ test upvar-8.11 {upvar will not create a variable that looks like an array} -set
test upvar-9.1 {Tcl_UpVar2 procedure} testupvar {
list [catch {testupvar xyz a {} x global} msg] $msg
-} {1 {bad level "xyz"}}
+} {1 {bad level "1"}}
test upvar-9.1.1 {TclGetFrame, via Tcl_UpVar2} testupvar {
apply {{} {testupvar xyz a {} x local; set x foo}}
set a
diff --git a/tests/winTime.test b/tests/winTime.test
index add8f98..dbaa14c 100644
--- a/tests/winTime.test
+++ b/tests/winTime.test
@@ -19,6 +19,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testwinclock [llength [info commands testwinclock]]
+testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}]
# The next two tests will crash on Windows if the check for negative
# clock values is not done properly.
@@ -40,7 +41,7 @@ test winTime-1.2 {TclpGetDate} {win} {
# with the Windows clock. 30 sec really isn't enough,
# but how much time does a tester have patience for?
-test winTime-2.1 {Synchronization of Tcl and Windows clocks} {testwinclock} {
+test winTime-2.1 {Synchronization of Tcl and Windows clocks} {testwinclock knownMsvcBug} {
# May fail due to OS/hardware discrepancies. See:
# http://support.microsoft.com/default.aspx?scid=kb;en-us;274323
set failed {}
@@ -50,7 +51,7 @@ test winTime-2.1 {Synchronization of Tcl and Windows clocks} {testwinclock} {
foreach { sys_sec sys_usec tcl_sec tcl_usec } [testwinclock] break
set diff [expr { $tcl_sec - $sys_sec
+ 1.0e-6 * ( $tcl_usec - $sys_usec ) }]
- if { abs($diff) > 0.06 } {
+ if { abs($diff) > 0.1 } {
set failed "Tcl clock differs from system clock by $diff sec"
break
} else {