From 4dc0eb331451143f9fac2621140d60c8073eb21d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 10 Sep 2019 12:03:40 +0000 Subject: Backport some improvements to tm.tcl (mostly comments). Don't use ::tcl_platform(debug) anymore, since it cannot be thrusted: Better use [::tcl::pkgconfig get debug] Reduce limits in tests/compile.test (13.2), since apparently it's still too much for some platforms. --- library/dde/pkgIndex.tcl | 4 +- library/reg/pkgIndex.tcl | 4 +- library/tm.tcl | 226 ++++++++++++++++++++++------------------------- tests/compile.test | 4 +- 4 files changed, 112 insertions(+), 126 deletions(-) diff --git a/library/dde/pkgIndex.tcl b/library/dde/pkgIndex.tcl index 065dc83..bcb5f9c 100644 --- a/library/dde/pkgIndex.tcl +++ b/library/dde/pkgIndex.tcl @@ -1,6 +1,6 @@ -if {![package vsatisfies [package provide Tcl] 8]} return +if {![package vsatisfies [package provide Tcl] 8.5]} return if {[info sharedlibextension] != ".dll"} return -if {[info exists ::tcl_platform(debug)]} { +if {[::tcl::pkgconfig get debug]} { package ifneeded dde 1.4.1 [list load [file join $dir tcldde14g.dll] dde] } else { package ifneeded dde 1.4.1 [list load [file join $dir tcldde14.dll] dde] diff --git a/library/reg/pkgIndex.tcl b/library/reg/pkgIndex.tcl index 12c7ea5..9a85944 100755 --- a/library/reg/pkgIndex.tcl +++ b/library/reg/pkgIndex.tcl @@ -1,6 +1,6 @@ -if {![package vsatisfies [package provide Tcl] 8]} return +if {![package vsatisfies [package provide Tcl] 8.5]} return if {[info sharedlibextension] != ".dll"} return -if {[info exists ::tcl_platform(debug)]} { +if {[::tcl::pkgconfig get debug]} { package ifneeded registry 1.3.3 \ [list load [file join $dir tclreg13g.dll] registry] } else { diff --git a/library/tm.tcl b/library/tm.tcl index 87db0df..40b8e40 100644 --- a/library/tm.tcl +++ b/library/tm.tcl @@ -1,48 +1,44 @@ # -*- tcl -*- # -# Searching for Tcl Modules. Defines a procedure, declares it as the -# primary command for finding packages, however also uses the former -# 'package unknown' command as a fallback. +# Searching for Tcl Modules. Defines a procedure, declares it as the primary +# command for finding packages, however also uses the former 'package unknown' +# command as a fallback. # -# Locates all possible packages in a directory via a less restricted -# glob. The targeted directory is derived from the name of the -# requested package. I.e. the TM scan will look only at directories -# which can contain the requested package. It will register all -# packages it found in the directory so that future requests have a -# higher chance of being fulfilled by the ifneeded database without -# having to come to us again. +# Locates all possible packages in a directory via a less restricted glob. The +# targeted directory is derived from the name of the requested package, i.e. +# the TM scan will look only at directories which can contain the requested +# package. It will register all packages it found in the directory so that +# future requests have a higher chance of being fulfilled by the ifneeded +# database without having to come to us again. # -# We do not remember where we have been and simply rescan targeted -# directories when invoked again. The reasoning is this: +# We do not remember where we have been and simply rescan targeted directories +# when invoked again. The reasoning is this: # -# - The only way we get back to the same directory is if someone is -# trying to [package require] something that wasn't there on the -# first scan. +# - The only way we get back to the same directory is if someone is trying to +# [package require] something that wasn't there on the first scan. # # Either # 1) It is there now: If we rescan, you get it; if not you don't. # -# This covers the possibility that the application asked for a -# package late, and the package was actually added to the -# installation after the application was started. It shoukld -# still be able to find it. +# This covers the possibility that the application asked for a package +# late, and the package was actually added to the installation after the +# application was started. It shoukld still be able to find it. # -# 2) It still is not there: Either way, you don't get it, but the -# rescan takes time. This is however an error case and we dont't -# care that much about it +# 2) It still is not there: Either way, you don't get it, but the rescan +# takes time. This is however an error case and we dont't care that much +# about it # -# 3) It was there the first time; but for some reason a "package -# forget" has been run, and "package" doesn't know about it -# anymore. +# 3) It was there the first time; but for some reason a "package forget" has +# been run, and "package" doesn't know about it anymore. # -# This can be an indication that the application wishes to reload -# some functionality. And should work as well. +# This can be an indication that the application wishes to reload some +# functionality. And should work as well. # -# Note that this also strikes a balance between doing a glob targeting -# a single package, and thus most likely requiring multiple globs of -# the same directory when the application is asking for many packages, -# and trying to glob for _everything_ in all subdirectories when -# looking for a package, which comes with a heavy startup cost. +# Note that this also strikes a balance between doing a glob targeting a +# single package, and thus most likely requiring multiple globs of the same +# directory when the application is asking for many packages, and trying to +# glob for _everything_ in all subdirectories when looking for a package, +# which comes with a heavy startup cost. # # We scan for regular packages only if no satisfying module was found. @@ -71,46 +67,43 @@ namespace eval ::tcl::tm { # path with 'list'. # # Results -# No result for subcommands 'add' and 'remove'. A list of paths -# for 'list'. +# No result for subcommands 'add' and 'remove'. A list of paths for +# 'list'. # # Sideeffects -# The subcommands 'add' and 'remove' manipulate the list of -# paths to search for Tcl Modules. The subcommand 'list' has no -# sideeffects. +# The subcommands 'add' and 'remove' manipulate the list of paths to +# search for Tcl Modules. The subcommand 'list' has no sideeffects. -proc ::tcl::tm::add {path args} { +proc ::tcl::tm::add {args} { # PART OF THE ::tcl::tm::path ENSEMBLE # # The path is added at the head to the list of module paths. # - # The command enforces the restriction that no path may be an - # ancestor directory of any other path on the list. If the new - # path violates this restriction an error wil be raised. + # The command enforces the restriction that no path may be an ancestor + # directory of any other path on the list. If the new path violates this + # restriction an error wil be raised. # - # If the path is already present as is no error will be raised and - # no action will be taken. + # If the path is already present as is no error will be raised and no + # action will be taken. variable paths - # We use a copy of the path as source during validation, and - # extend it as well. Because we not only have to detect if the new - # paths are bogus with respect to the existing paths, but also - # between themselves. Otherwise we can still add bogus paths, by - # specifying them in a single call. This makes the use of the new - # paths simpler as well, a trivial assignment of the collected - # paths to the official state var. + # We use a copy of the path as source during validation, and extend it as + # well. Because we not only have to detect if the new paths are bogus with + # respect to the existing paths, but also between themselves. Otherwise we + # can still add bogus paths, by specifying them in a single call. This + # makes the use of the new paths simpler as well, a trivial assignment of + # the collected paths to the official state var. set newpaths $paths - foreach p [linsert $args 0 $path] { + foreach p $args { if {$p in $newpaths} { # Ignore a path already on the list. continue } - # Search for paths which are subdirectories of the new one. If - # there are any then the new path violates the restriction - # about ancestors. + # Search for paths which are subdirectories of the new one. If there + # are any then the new path violates the restriction about ancestors. set pos [lsearch -glob $newpaths ${p}/*] # Cannot use "in", we need the position for the message. @@ -119,10 +112,9 @@ proc ::tcl::tm::add {path args} { "$p is ancestor of existing module path [lindex $newpaths $pos]." } - # Now look for existing paths which are ancestors of the new - # one. This reverse question forces us to loop over the - # existing paths, as each element is the pattern, not the new - # path :( + # Now look for existing paths which are ancestors of the new one. This + # reverse question forces us to loop over the existing paths, as each + # element is the pattern, not the new path :( foreach ep $newpaths { if {[string match ${ep}/* $p]} { @@ -134,24 +126,23 @@ proc ::tcl::tm::add {path args} { set newpaths [linsert $newpaths 0 $p] } - # The validation of the input is complete and successful, and - # everything in newpaths is either an old path, or added. We can - # now extend the official list of paths, a simple assignment is - # sufficient. + # The validation of the input is complete and successful, and everything + # in newpaths is either an old path, or added. We can now extend the + # official list of paths, a simple assignment is sufficient. set paths $newpaths return } -proc ::tcl::tm::remove {path args} { +proc ::tcl::tm::remove {args} { # PART OF THE ::tcl::tm::path ENSEMBLE # - # Removes the path from the list of module paths. The command is - # silently ignored if the path is not on the list. + # Removes the path from the list of module paths. The command is silently + # ignored if the path is not on the list. variable paths - foreach p [linsert $args 0 $path] { + foreach p $args { set pos [lsearch -exact $paths $p] if {$pos >= 0} { set paths [lreplace $paths $pos $pos] @@ -177,17 +168,16 @@ proc ::tcl::tm::list {} { # empty string. # exact - Either -exact or ommitted. # -# Name, version, and exact are used to determine -# satisfaction. The original is called iff no satisfaction was -# achieved. The name is also used to compute the directory to -# target in the search. +# Name, version, and exact are used to determine satisfaction. The +# original is called iff no satisfaction was achieved. The name is also +# used to compute the directory to target in the search. # # Results # None. # # Sideeffects -# May populate the package ifneeded database with additional -# provide scripts. +# May populate the package ifneeded database with additional provide +# scripts. proc ::tcl::tm::UnknownHandler {original name args} { # Import the list of paths to search for packages in module form. @@ -196,8 +186,8 @@ proc ::tcl::tm::UnknownHandler {original name args} { variable paths variable pkgpattern - # Without paths to search we can do nothing. (Except falling back - # to the regular search). + # Without paths to search we can do nothing. (Except falling back to the + # regular search). if {[llength $paths]} { set pkgpath [string map {:: /} $name] @@ -206,11 +196,10 @@ proc ::tcl::tm::UnknownHandler {original name args} { set pkgroot "" } - # We don't remember a copy of the paths while looping. Tcl - # Modules are unable to change the list while we are searching - # for them. This also simplifies the loop, as we cannot get - # additional directories while iterating over the list. A - # simple foreach is sufficient. + # We don't remember a copy of the paths while looping. Tcl Modules are + # unable to change the list while we are searching for them. This also + # simplifies the loop, as we cannot get additional directories while + # iterating over the list. A simple foreach is sufficient. set satisfied 0 foreach path $paths { @@ -223,12 +212,11 @@ proc ::tcl::tm::UnknownHandler {original name args} { } set strip [llength [file split $path]] - # We can't use glob in safe interps, so enclose the following - # in a catch statement, where we get the module files out - # of the subdirectories. In other words, Tcl Modules are - # not-functional in such an interpreter. This is the same - # as for the command "tclPkgUnknown", i.e. the search for - # regular packages. + # We can't use glob in safe interps, so enclose the following in a + # catch statement, where we get the module files out of the + # subdirectories. In other words, Tcl Modules are not-functional + # in such an interpreter. This is the same as for the command + # "tclPkgUnknown", i.e. the search for regular packages. catch { # We always look for _all_ possible modules in the current @@ -238,13 +226,13 @@ proc ::tcl::tm::UnknownHandler {original name args} { set pkgfilename [join [lrange [file split $file] $strip end] ::] if {![regexp -- $pkgpattern $pkgfilename --> pkgname pkgversion]} { - # Ignore everything not matching our pattern - # for package names. + # Ignore everything not matching our pattern for + # package names. continue } if {[catch {package vcompare $pkgversion 0}]} { - # Ignore everything where the version part is - # not acceptable to "package vcompare". + # Ignore everything where the version part is not + # acceptable to "package vcompare". continue } @@ -257,38 +245,36 @@ proc ::tcl::tm::UnknownHandler {original name args} { continue } - # We have found a candidate, generate a "provide - # script" for it, and remember it. Note that we - # are using ::list to do this; locally [list] - # means something else without the namespace - # specifier. - - # NOTE. When making changes to the format of the - # provide command generated below CHECK that the - # 'LOCATE' procedure in core file - # 'platform/shell.tcl' still understands it, or, - # if not, update its implementation appropriately. + # We have found a candidate, generate a "provide script" + # for it, and remember it. Note that we are using ::list + # to do this; locally [list] means something else without + # the namespace specifier. + + # NOTE. When making changes to the format of the provide + # command generated below CHECK that the 'LOCATE' + # procedure in core file 'platform/shell.tcl' still + # understands it, or, if not, update its implementation + # appropriately. # - # Right now LOCATE's implementation assumes that - # the path of the package file is the last element - # in the list. + # Right now LOCATE's implementation assumes that the path + # of the package file is the last element in the list. package ifneeded $pkgname $pkgversion \ "[::list package provide $pkgname $pkgversion];[::list source -encoding utf-8 $file]" - # We abort in this unknown handler only if we got - # a satisfying candidate for the requested - # package. Otherwise we still have to fallback to - # the regular package search to complete the - # processing. + # We abort in this unknown handler only if we got a + # satisfying candidate for the requested package. + # Otherwise we still have to fallback to the regular + # package search to complete the processing. if {($pkgname eq $name) && [package vsatisfies $pkgversion {*}$args]} { set satisfied 1 - # We do not abort the loop, and keep adding - # provide scripts for every candidate in the - # directory, just remember to not fall back to - # the regular search anymore. + + # We do not abort the loop, and keep adding provide + # scripts for every candidate in the directory, just + # remember to not fall back to the regular search + # anymore. } } } @@ -299,8 +285,8 @@ proc ::tcl::tm::UnknownHandler {original name args} { } } - # Fallback to previous command, if existing. See comment above - # about ::list... + # Fallback to previous command, if existing. See comment above about + # ::list... if {[llength $original]} { uplevel 1 $original [::linsert $args 0 $name] @@ -366,22 +352,22 @@ proc ::tcl::tm::Defaults {} { # Calls 'path add' to paths to the list of module search paths. proc ::tcl::tm::roots {paths} { - lassign [split [package present Tcl] .] major minor + regexp {^(\d+)\.(\d+)} [package present Tcl] - major minor foreach pa $paths { set p [file join $pa tcl$major] for {set n $minor} {$n >= 0} {incr n -1} { set px [file join $p ${major}.${n}] - if {![interp issafe]} { set px [file normalize $px] } + if {![interp issafe]} {set px [file normalize $px]} path add $px } set px [file join $p site-tcl] - if {![interp issafe]} { set px [file normalize $px] } + if {![interp issafe]} {set px [file normalize $px]} path add $px } return } -# Initialization. Set up the default paths, then insert the new -# handler into the chain. +# Initialization. Set up the default paths, then insert the new handler into +# the chain. -if {![interp issafe]} { ::tcl::tm::Defaults } +if {![interp issafe]} {::tcl::tm::Defaults} diff --git a/tests/compile.test b/tests/compile.test index cd26fdf..a66da22 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -442,10 +442,10 @@ test compile-13.2 {TclCompileScript: testing nested scripts compilation} -setup }} } -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 + # with 1500 (750 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) $i eval {foreach cmd {eval "if 1" catch} { - set c [gencode [expr {![::tcl::pkgconfig get debug] ? 2000 : 1000}] $cmd] + set c [gencode [expr {![::tcl::pkgconfig get debug] ? 1500 : 750}] $cmd] if 1 $c }} $i eval {set result} -- cgit v0.12 From 4d51f6b054999c72115751f3895158195e42b40d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 10 Sep 2019 12:05:54 +0000 Subject: Don't use constraints like unixOrPc anymore, use unixOrWin (for example) --- tests/chanio.test | 4 +- tests/cmdAH.test | 6 +-- tests/cmdMZ.test | 4 +- tests/fCmd.test | 17 +++++++-- tests/fileName.test | 46 +++++++++++----------- tests/interp.test | 64 +++++++++++++++---------------- tests/io.test | 4 +- tests/ioCmd.test | 10 ++--- tests/pid.test | 2 +- tests/registry.test | 8 ++-- tests/socket.test | 2 +- tests/tcltest.test | 108 ++++++++++++++++++++++++++-------------------------- 12 files changed, 142 insertions(+), 133 deletions(-) diff --git a/tests/chanio.test b/tests/chanio.test index 5d47e0b..a18bbbe 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -2069,7 +2069,7 @@ test chan-io-27.4 {FlushChannel, implicit flush when buffer fills} { set l } {0 60 72} test chan-io-27.5 {FlushChannel, implicit flush when buffer fills and on chan close} \ - {unixOrPc} { + {unixOrWin} { file delete $path(test1) set f [open $path(test1) w] chan configure $f -translation lf -buffersize 60 -eofchar {} @@ -7339,7 +7339,7 @@ test chan-io-57.2 {buffered data and file events, read} {fileevent} { set 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 c8318c0..03ec3df 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -372,7 +372,7 @@ test cmdAH-8.45 {Tcl_FileObjCmd: dirname} { -match regexp -setup { set temp $::env(HOME) - } + } -body { set ::env(HOME) "/homewontexist/test" testsetplatform windows @@ -878,7 +878,7 @@ test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unix testchmod} { } 1 test cmdAH-18.5 {Tcl_FileObjCmd: executable} {win} { - # On pc, must be a .exe, .com, etc. + # On windows, must be a .exe, .com, etc. set x [file exe $gorpfile] set gorpexe [makeFile foo gorp.exe] @@ -887,7 +887,7 @@ test cmdAH-18.5 {Tcl_FileObjCmd: executable} {win} { set x } {0 1} test cmdAH-18.5.1 {Tcl_FileObjCmd: executable} {win} { - # On pc, must be a .exe, .com, etc. + # On windows, must be a .exe, .com, etc. set x [file exe $gorpfile] set gorpexe [makeFile foo gorp.exe] diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index 98cb0fb..5f94777 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.test @@ -224,12 +224,12 @@ foreach script { # More tests of Tcl_SourceObjCmd are in source.test test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} -constraints { - unixOrPc + unixOrWin } -body { list [catch {source} msg] $msg } -match glob -result {1 {wrong # args: should be "source*fileName"}} test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} -constraints { - unixOrPc + unixOrWin } -body { list [catch {source a b} msg] $msg } -match glob -result {1 {wrong # args: should be "source*fileName"}} diff --git a/tests/fCmd.test b/tests/fCmd.test index f53128d..71bc186 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -26,6 +26,15 @@ testConstraint winOlderThan2000 0 testConstraint notNetworkFilesystem 0 testConstraint 95or98 [expr {[testConstraint 95] || [testConstraint 98]}] testConstraint 2000orNewer [expr {![testConstraint 95or98]}] +testConstraint reg 0 +if {[testConstraint win]} { + if {![catch { + ::tcltest::loadTestedCommands + set ::regver [package require registry 1.3.3] + }]} { + testConstraint reg 1 + } +} set tmpspace /tmp;# default value # Find a group that exists on this Unix system, or else skip tests that @@ -49,7 +58,7 @@ if {[testConstraint unix]} { } # Also used in winFCmd... -if {[testConstraint winOnly]} { +if {[testConstraint win]} { if {[testConstraint nt] && $::tcl_platform(osVersion) >= 5.0} { if {$::tcl_platform(osVersion) >= 6.0} { testConstraint winVista 1 @@ -259,7 +268,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} @@ -387,7 +396,7 @@ test fCmd-5.4 {TclFileDeleteCmd: multiple files} {notRoot} { file delete tf1 td1 tf2 lappend x [file exists tf1] [file exists tf2] [file exists tf3] } {1 1 1 0 0 0} -test fCmd-5.5 {TclFileDeleteCmd: stop at first error} {notRoot unixOrPc} { +test fCmd-5.5 {TclFileDeleteCmd: stop at first error} {notRoot unixOrWin} { cleanup createfile tf1 createfile tf2 @@ -1080,7 +1089,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 a4c8efe..3747fc9 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -1116,13 +1116,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} { list [catch {glob {}} msg] $msg } {0 .} -test filename-12.1.1 {simple globbing} {unixOrPc} { +test filename-12.1.1 {simple globbing} {unixOrWin} { list [catch {glob -types f {}} msg] $msg } {1 {no files matched glob pattern ""}} -test filename-12.1.2 {simple globbing} {unixOrPc} { +test filename-12.1.2 {simple globbing} {unixOrWin} { list [catch {glob -types d {}} msg] $msg } {0 .} test filename-12.1.3 {simple globbing} {unix} { @@ -1144,7 +1144,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} { @@ -1231,32 +1231,32 @@ test filename-13.9 {globbing with brace substitution} { test filename-13.10 {globbing with brace substitution} { list [lsort [catch {glob globTest/\{x,,y\}1.c} msg]] $msg } [list 0 [list $globPreResult$x1 $globPreResult$y1]] -test filename-13.11 {globbing with brace substitution} {unixOrPc} { +test filename-13.11 {globbing with brace substitution} {unixOrWin} { list [lsort [catch {glob globTest/\{x,x\\,z,z\}1.c} msg]] $msg } {0 {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} { list [catch {glob globTest/\{a,x\}1/*/\{} msg] $msg } {1 {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} @@ -1266,7 +1266,7 @@ file rename globTest [file join globTestContext globTest] set savepwd [pwd] cd globTestContext -test filename-14.5 {asterisks, question marks, and brackets} {unixOrPc} { +test filename-14.5 {asterisks, question marks, and brackets} {unixOrWin} { lsort [glob */*/*/*.c] } {globTest/a1/b1/x2.c globTest/a1/b2/y2.c} @@ -1281,16 +1281,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} { @@ -1301,7 +1301,7 @@ test filename-14.17 {asterisks, question marks, and brackets} { set env(HOME) $temp set result } [list 0 [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} { list [catch {lsort [glob globTest/*.c goo/*]} msg] $msg } {0 {{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} { @@ -1340,16 +1340,16 @@ test filename-14.25.1 {type specific globbing} {win} { test filename-14.26 {type specific globbing} { list [catch {glob -nocomplain -dir globTest -types {readonly} *} msg] $msg } [list 0 {}] -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/ @@ -1406,7 +1406,7 @@ test filename-15.4.1 {no complain: errors, sequencing} { } {1 {user "wontexist" doesn't exist} 1 {user "blahxyz" doesn't exist}} test filename-15.4.2 {no complain: errors, sequencing} { # test used to fail because if an error occurs, the interp's result - # is reset... + # is reset... string equal \ [list [catch {glob -nocomplain ~wontexist *} res1] $res1] \ [list [catch {glob -nocomplain * ~wontexist} res2] $res2] @@ -1414,7 +1414,7 @@ test filename-15.4.2 {no complain: errors, sequencing} { test filename-15.5 {unix specific globbing} {unix nonPortable} { glob ~ouster/.csh* } "/home/ouster/.cshrc" -catch {close [open globTest/odd\\\[\]*?\{\}name w]} +catch {close [open globTest/odd\\\[\]*?\{\}name w]} test filename-15.6 {unix specific globbing} {unix} { global env set temp $env(HOME) diff --git a/tests/interp.test b/tests/interp.test index 510ab4a..b5632e1 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -53,7 +53,7 @@ test interp-1.8 {options for interp command} { } {1 {bad option "-froboz": must be alias, aliases, bgerror, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}} test interp-1.9 {options for interp command} { list [catch {interp -froboz -safe} msg] $msg -} {1 {bad option "-froboz": must be alias, aliases, bgerror, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}} +} {1 {bad option "-froboz": must be alias, aliases, bgerror, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}} test interp-1.10 {options for interp command} { list [catch {interp target} msg] $msg } {1 {wrong # args: should be "interp target path alias"}} @@ -68,7 +68,7 @@ test interp-2.2 {basic interpreter creation} { } 0 test interp-2.3 {basic interpreter creation} { catch {interp create -safe} -} 0 +} 0 test interp-2.4 {basic interpreter creation} { list [catch {interp create a} msg] $msg } {1 {interpreter named "a" already exists, cannot create}} @@ -100,7 +100,7 @@ test interp-2.11 {anonymous interps vs existing procs} { set x [interp create] regexp "interp(\[0-9]+)" $x dummy anothernum expr $anothernum > $thenum -} 1 +} 1 test interp-2.12 {anonymous interps vs existing procs} { set x [interp create -safe] regexp "interp(\[0-9]+)" $x dummy thenum @@ -109,11 +109,11 @@ test interp-2.12 {anonymous interps vs existing procs} { set x [interp create -safe] regexp "interp(\[0-9]+)" $x dummy anothernum expr $anothernum - $thenum -} 1 +} 1 test interp-2.13 {correct default when no $path arg is given} -body { interp create -- } -match regexp -result {interp[0-9]+} - + foreach i [interp slaves] { interp delete $i } @@ -854,12 +854,12 @@ test interp-18.9 {eval in deleted interp, bug 495830} { interp create tst interp alias tst suicide {} interp delete tst list [catch {tst eval {suicide; set a 5}} msg] $msg -} {1 {attempt to call eval in deleted interpreter}} +} {1 {attempt to call eval in deleted interpreter}} test interp-18.10 {eval in deleted interp, bug 495830} { interp create tst interp alias tst suicide {} interp delete tst list [catch {tst eval {set set set; suicide; $set a 5}} msg] $msg -} {1 {attempt to call eval in deleted interpreter}} +} {1 {attempt to call eval in deleted interpreter}} # Test alias deletion @@ -949,7 +949,7 @@ test interp-19.9 {alias deletion, renaming} { set l [interp eval a foo] interp delete a set l -} 1156 +} 1156 test interp-20.1 {interp hide, interp expose and interp invokehidden} { set a [interp create] @@ -1170,7 +1170,7 @@ test interp-20.21 {interp hide vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {a hide list} msg] + lappend l [catch {a hide list} msg] lappend l $msg interp delete a set l @@ -1179,7 +1179,7 @@ test interp-20.22 {interp hide vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {interp hide a list} msg] + lappend l [catch {interp hide a list} msg] lappend l $msg interp delete a set l @@ -1188,7 +1188,7 @@ test interp-20.23 {interp hide vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {a eval {interp hide {} list}} msg] + lappend l [catch {a eval {interp hide {} list}} msg] lappend l $msg interp delete a set l @@ -1198,7 +1198,7 @@ test interp-20.24 {interp hide vs safety} { interp create a -safe interp create {a b} set l "" - lappend l [catch {a eval {interp hide b list}} msg] + lappend l [catch {a eval {interp hide b list}} msg] lappend l $msg interp delete a set l @@ -1217,7 +1217,7 @@ test interp-20.26 {interp expoose vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {a hide list} msg] + lappend l [catch {a hide list} msg] lappend l $msg lappend l [catch {a expose list} msg] lappend l $msg @@ -1228,9 +1228,9 @@ test interp-20.27 {interp expose vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {interp hide a list} msg] + lappend l [catch {interp hide a list} msg] lappend l $msg - lappend l [catch {interp expose a list} msg] + lappend l [catch {interp expose a list} msg] lappend l $msg interp delete a set l @@ -1239,7 +1239,7 @@ test interp-20.28 {interp expose vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {a hide list} msg] + lappend l [catch {a hide list} msg] lappend l $msg lappend l [catch {a eval {interp expose {} list}} msg] lappend l $msg @@ -1250,9 +1250,9 @@ test interp-20.29 {interp expose vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {interp hide a list} msg] + lappend l [catch {interp hide a list} msg] lappend l $msg - lappend l [catch {a eval {interp expose {} list}} msg] + lappend l [catch {a eval {interp expose {} list}} msg] lappend l $msg interp delete a set l @@ -1262,9 +1262,9 @@ test interp-20.30 {interp expose vs safety} { interp create a -safe interp create {a b} set l "" - lappend l [catch {interp hide {a b} list} msg] + lappend l [catch {interp hide {a b} list} msg] lappend l $msg - lappend l [catch {a eval {interp expose b list}} msg] + lappend l [catch {a eval {interp expose b list}} msg] lappend l $msg interp delete a set l @@ -1274,7 +1274,7 @@ test interp-20.31 {interp expose vs safety} { interp create a -safe interp create {a b} set l "" - lappend l [catch {interp hide {a b} list} msg] + lappend l [catch {interp hide {a b} list} msg] lappend l $msg lappend l [catch {interp expose {a b} list} msg] lappend l $msg @@ -1631,7 +1631,7 @@ test interp-21.5 {interp hidden} { set l [lsort [interp hidden a]] interp delete a set l -} $hidden_cmds +} $hidden_cmds test interp-21.6 {interp hidden vs interp hide, interp expose} { catch {interp delete a} interp create a @@ -1786,7 +1786,7 @@ test interp-23.1 {testing hiding vs aliases} { interp delete a set l } {{} bar {} bar bar {} {}} -test interp-23.2 {testing hiding vs aliases} {unixOrPc} { +test interp-23.2 {testing hiding vs aliases} {unixOrWin} { catch {interp delete a} interp create a -safe set l "" @@ -1802,7 +1802,7 @@ test interp-23.2 {testing hiding vs aliases} {unixOrPc} { lappend l [lsort [interp hidden a]] interp delete a set l -} {{cd encoding exec exit fconfigure file glob load open pwd socket source unload} {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} {cd encoding exec exit fconfigure file glob load open pwd socket source unload} {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} {bar cd encoding exec exit fconfigure file glob load open pwd socket source unload} {::tcl::mathfunc::max ::tcl::mathfunc::min clock} {cd encoding exec exit fconfigure file glob load open pwd socket source unload}} +} {{cd encoding exec exit fconfigure file glob load open pwd socket source unload} {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} {cd encoding exec exit fconfigure file glob load open pwd socket source unload} {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} {bar cd encoding exec exit fconfigure file glob load open pwd socket source unload} {::tcl::mathfunc::max ::tcl::mathfunc::min clock} {cd encoding exec exit fconfigure file glob load open pwd socket source unload}} test interp-24.1 {result resetting on error} { catch {interp delete a} @@ -2045,7 +2045,7 @@ test interp-26.1 {result code transmission : interp eval direct} { # Test that all the possibles error codes from Tcl get passed up # from the slave interp's context to the master, even though the # slave nominally thinks the command is running at the root level. - + catch {interp delete a} interp create a set res {} @@ -2076,7 +2076,7 @@ test interp-26.3 {result code transmission : aliases} { # Test that all the possibles error codes from Tcl get passed up # from the slave interp's context to the master, even though the # slave nominally thinks the command is running at the root level. - + catch {interp delete a} interp create a set res {} @@ -2193,7 +2193,7 @@ test interp-26.8 {errorInfo transmission: safe interps--bug 1637} {knownBug} { test interp-27.1 {interp aliases & namespaces} { set i [interp create]; set aliasTrace {}; - proc tstAlias {args} { + proc tstAlias {args} { global aliasTrace; lappend aliasTrace [list [namespace current] $args]; } @@ -2206,7 +2206,7 @@ test interp-27.1 {interp aliases & namespaces} { test interp-27.2 {interp aliases & namespaces} { set i [interp create]; set aliasTrace {}; - proc tstAlias {args} { + proc tstAlias {args} { global aliasTrace; lappend aliasTrace [list [namespace current] $args]; } @@ -2219,7 +2219,7 @@ test interp-27.2 {interp aliases & namespaces} { test interp-27.3 {interp aliases & namespaces} { set i [interp create]; set aliasTrace {}; - proc tstAlias {args} { + proc tstAlias {args} { global aliasTrace; lappend aliasTrace [list [namespace current] $args]; } @@ -2234,7 +2234,7 @@ test interp-27.4 {interp aliases & namespaces} { set i [interp create]; namespace eval foo2 { variable aliasTrace {}; - proc bar {args} { + proc bar {args} { variable aliasTrace; lappend aliasTrace [list [namespace current] $args]; } @@ -3206,7 +3206,7 @@ test interp-34.9 {time limits trigger in blocking after} { } msg] set t1 [clock seconds] interp delete $i - list $code $msg [expr {($t1-$t0) < 3 ? "OK" : $t1-$t0}] + list $code $msg [expr {($t1-$t0) < 3 ? "OK" : $t1-$t0}] } {1 {time limit exceeded} OK} test interp-34.10 {time limits trigger in vwaits: Bug 1221395} -body { set i [interp create] @@ -3440,7 +3440,7 @@ test interp-35.24 {interp time limits can't touch current interp} -body { test interp-36.1 {interp bgerror syntax} -body { interp bgerror } -returnCodes error -result {wrong # args: should be "interp bgerror path ?cmdPrefix?"} -test interp-36.2 {interp bgerror syntax} -body { +test interp-36.2 {interp bgerror syntax} -body { interp bgerror x y z } -returnCodes error -result {wrong # args: should be "interp bgerror path ?cmdPrefix?"} test interp-36.3 {interp bgerror syntax} -setup { diff --git a/tests/io.test b/tests/io.test index 13ff38c..4257d51 100644 --- a/tests/io.test +++ b/tests/io.test @@ -2208,7 +2208,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 {} @@ -8102,7 +8102,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 460299b..c3893bc 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -265,7 +265,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} @@ -367,18 +367,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} NONE} -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} NONE} -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} NONE} -test iocmd-11.4 {I/O to command pipelines} unixOrPc { +test iocmd-11.4 {I/O to command pipelines} 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}}} 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/registry.test b/tests/registry.test index 539ba2d..9691b3e 100644 --- a/tests/registry.test +++ b/tests/registry.test @@ -242,7 +242,7 @@ test registry-4.2 {GetKeyNames} {win reg} { registry delete HKEY_CURRENT_USER\\TclFoobar set result } {baz} -test registry-4.3 {GetKeyNames: remote key} {win reg nonPortable english} { +test registry-4.3 {GetKeyNames: remote key} {win reg english} { set hostname [info hostname] registry set \\\\$hostname\\HKEY_CURRENT_USER\\TclFoobar\\baz set result [registry keys \\\\gaspode\\HKEY_CURRENT_USER\\TclFoobar] @@ -535,7 +535,7 @@ test registry-7.3 {GetValueNames} -constraints {win reg} -setup { } -cleanup { registry delete HKEY_CURRENT_USER\\TclFoobar } -result {{} baz blat} -test registry-7.4 {GetValueNames: remote key} -constraints {win reg nonPortable english} -body { +test registry-7.4 {GetValueNames: remote key} -constraints {win reg english} -body { set hostname [info hostname] registry set \\\\$hostname\\HKEY_CURRENT_USER\\TclFoobar baz blat set result [registry values \\\\$hostname\\HKEY_CURRENT_USER\\TclFoobar] @@ -571,7 +571,7 @@ test registry-7.7 {GetValueNames: names with spaces} -constraints {win reg} -set registry delete HKEY_CURRENT_USER\\TclFoobar } -result {{baz bar} blat} -test registry-8.1 {OpenSubKey} -constraints {win reg nonPortable english} \ +test registry-8.1 {OpenSubKey} -constraints {win reg english} \ -body { # This test will only succeed if the current user does not have # registry access on the specified machine. @@ -657,7 +657,7 @@ test registry-11.2 {SetValue: modification} -constraints {win reg} \ set result [registry get HKEY_CURRENT_USER\\TclFoobar\\baz blat] } -result {frob} test registry-11.3 {SetValue: failure} \ - -constraints {win reg nonPortable english} \ + -constraints {win reg english} \ -body { # This test will only succeed if the current user does not have # registry access on the specified machine. diff --git a/tests/socket.test b/tests/socket.test index 2fb8988..3544dd9 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -949,7 +949,7 @@ test socket-7.4 {testing socket specific options} {socket} { set l "" lappend l [expr {[lindex $x 2] == $listen}] [llength $x] } {1 3} -test socket-7.5 {testing socket specific options} {socket unixOrPc} { +test socket-7.5 {testing socket specific options} {socket unixOrWin} { 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] \ -- cgit v0.12