summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog15
-rw-r--r--doc/tcltest.n38
-rw-r--r--library/tcltest/tcltest.tcl356
-rw-r--r--tests/io.test84
-rwxr-xr-xtests/tcltest.test89
5 files changed, 322 insertions, 260 deletions
diff --git a/ChangeLog b/ChangeLog
index a4d0540..9f13eb1 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,16 @@
+2002-06-06 Don Porter <dgp@users.sourceforge.net>
+
+ * tests/io.test: Fixed up namespace variable resolution issues
+ revealed by running test suite with "-singleproc 1".
+
+ * doc/tcltest.n:
+ * library/tcltest/tcltest.tcl:
+ * tests/tcltest.test: Several updates to tcltest.
+ 1) changed to lazy initialization of test constraints
+ 2) deprecated [initConstraintsHook]
+ 3) repaired badly broken [limitConstraints].
+ [Patch 512214, Bug 558742, Bug 461000]
+
2002-06-06 Daniel Steffen <das@users.sourceforge.net>
* unix/tclUnixThrd.c (TclpReaddir, TclpLocaltime, TclpGmtime):
@@ -49,7 +62,7 @@
users to add new legal values of the -match option to [test],
associating each with a Tcl command that does the matching of
expected results with actual results of tests. Thanks to
- Arjen Markus. [Patch 521362]
+ Arjen Markus. => tcltest 2.1 [Patch 521362]
2002-06-03 Miguel Sofer <msofer@users.sourceforge.net>
diff --git a/doc/tcltest.n b/doc/tcltest.n
index 35eb110..2398fcf 100644
--- a/doc/tcltest.n
+++ b/doc/tcltest.n
@@ -7,7 +7,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" RCS: @(#) $Id: tcltest.n,v 1.17 2002/06/03 23:44:32 dgp Exp $
+'\" RCS: @(#) $Id: tcltest.n,v 1.18 2002/06/06 18:44:43 dgp Exp $
'\"
.so man.macros
.TH "tcltest" n 8.4 Tcl "Tcl Built-In Commands"
@@ -28,7 +28,7 @@ tcltest \- Test harness support code and utilities
.sp
\fBtcltest::interpreter \fI?interp?\fR
.sp
-\fBtcltest::singleProcess \fI?boolean?\fR
+\fBtcltest::singleProcess \fI?value?\fR
.sp
\fBtcltest::debug \fI?level?\fR
.sp
@@ -40,7 +40,7 @@ tcltest \- Test harness support code and utilities
.sp
\fBtcltest::testConstraint \fIconstraint ?value?\fR
.sp
-\fBtcltest::limitConstraints \fI?constraintList?\fR
+\fBtcltest::limitConstraints \fI?value?\fR
.sp
\fBtcltest::workingDirectory \fI?dir?\fR
.sp
@@ -151,11 +151,11 @@ suite. This is the interpreter used in runAllTests to run test files
if singleProcess is set to false. The default value for interpreter
is the name of the interpreter in which the tests were started.
.TP
-\fBtcltest::singleProcess\fR \fI?boolean?\fR
+\fBtcltest::singleProcess\fR \fI?value?\fR
Sets or returns a boolean indicating whether test files should be sourced
into the current interpreter by runAllTests or run in their own
-processes. If \fIboolean\fR is true (1), tests are sourced into the
-current interpreter. If \fIboolean\fR is false (0), tests are run in
+processes. If \fIvalue\fR is true (1), tests are sourced into the
+current interpreter. If \fIvalue\fR is false (0), tests are run in
the interpreter specified in tcltest::interpreter. The default value
for tcltest::singleProcess is false.
.TP
@@ -232,11 +232,12 @@ whether or not the results match. The built-in matching modes of
Sets or returns the value associated with the named \fIconstraint\fR.
See the section \fI"Test constraints"\fR for more information.
.TP
-\fBtcltest::limitConstraints \fI?constraintList?\fR
+\fBtcltest::limitConstraints \fI?value?\fR
Sets or returns a boolean indicating whether testing is being limited
-to constraints listed in \fIconstraintList\fR.
-If limitConstraints is not false, only those tests with constraints matching
-values in \fIconstraintList\fR will be run.
+to the list of constraints specified by the \fB-constraints\fR
+command line option. If \fIvalue\fR is true, only those tests
+with constraints present in the list specified in the \fB-constraints\fR
+command line option.
.TP
\fBtcltest::workingDirectory\fR \fI?directoryName?\fR
Sets or returns the directory in which the test suite is being run.
@@ -934,10 +935,6 @@ tell the test harness about additional flags that you want it to understand.
process the additional flags that you told the harness about in
tcltest::processCmdLineArgsFlagHook.
.TP
-\fBtcltest::initConstraintsHook\fR
-used to add additional built-in constraints to those already defined
-by \fBtcltest\fR.
-.TP
\fBtcltest::cleanupTestsHook\fR
do additional cleanup
.PP
@@ -972,19 +969,6 @@ tcltest::PrintUsageInfoHook proc. Within this proc, you should
print out additional usage information for any flags that you've
implemented.
.PP
-To add new built-in
-constraints to the test harness, define your own version of
-\fBtcltest::initConstraintsHook\fR.
-Within your proc, you can add to the \fBtcltest::testConstraints\fR array.
-For example:
-.DS
-proc tcltest::initConstraintsHook {} {
- set tcltest::testConstraints(win95Or98) \\
- [expr {$tcltest::testConstraints(95) || \\
- $tcltest::testConstraints(98)}]
-}
-.DE
-.PP
Finally, if you want to add additional cleanup code to your harness
you can define your own \fBtcltest::cleanupTestsHook\fR. For example:
.DS
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index edda144..0a7e50d 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -15,7 +15,7 @@
# Copyright (c) 2000 by Ajuba Solutions
# All rights reserved.
#
-# RCS: @(#) $Id: tcltest.tcl,v 1.52 2002/06/05 01:12:38 dgp Exp $
+# RCS: @(#) $Id: tcltest.tcl,v 1.53 2002/06/06 18:44:43 dgp Exp $
# create the "tcltest" namespace for all testing variables and
# procedures
@@ -131,9 +131,14 @@ namespace eval tcltest {
# predefined constraints (see the explanation for the
# InitConstraints proc for more details).
ArrayDefault testConstraints {}
+ Default ConstraintsSpecifiedByCommandLineArgument {}
+
+ # Kept only for compatibility
Default constraintsSpecified {}
+ trace variable constraintsSpecified r {set ::tcltest::constraintsSpecified \
+ [array names ::tcltest::testConstraints] ;# }
- # Don't run only the constrained tests by default
+ # Don't run only the "-constraint" specified tests by default
Default limitConstraints false
# A test application has to know how to load the tested commands
@@ -434,7 +439,7 @@ namespace eval tcltest {
foreach var {
match skip matchFiles skipFiles matchDirectories
skipDirectories preserveCore debug loadScript singleProcess
- mainThread
+ mainThread ConstraintsSpecifiedByCommandLineArgument
} {
proc $var { {new ""} } [subst -nocommands {
variable $var
@@ -667,25 +672,29 @@ proc tcltest::errorFile { {filename ""} } {
# content of tcltest::testConstraints($constraint)
#
# Side effects:
-# appends the constraint name to tcltest::constraintsSpecified
+# none
proc tcltest::testConstraint {constraint {value ""}} {
variable testConstraints
- variable constraintsSpecified
DebugPuts 3 "entering testConstraint $constraint $value"
if {[llength [info level 0]] == 2} {
return $testConstraints($constraint)
}
- lappend constraintsSpecified $constraint
+ # Check for boolean values
+ if {[catch {expr {$value && $value}} msg]} {
+ return -code error $msg
+ }
set testConstraints($constraint) $value
}
# tcltest::limitConstraints --
#
-# sets the limited constraints to tcltest::limitConstraints
+# sets/gets flag indicating whether tests run are limited only
+# to those matching constraints specified by the -constraints
+# command line option.
#
# Arguments:
-# list of constraint names
+# new boolean value for the flag
#
# Results:
# content of tcltest::limitConstraints
@@ -693,17 +702,22 @@ proc tcltest::testConstraint {constraint {value ""}} {
# Side effects:
# None.
-proc tcltest::limitConstraints { {constraintList ""} } {
- variable constraintsSpecified
+proc tcltest::limitConstraints { {value ""} } {
variable testConstraints
variable limitConstraints
- DebugPuts 3 "entering limitConstraints $constraintList"
+ DebugPuts 3 "entering limitConstraints $value"
if {[llength [info level 0]] == 1} {
return $limitConstraints
}
- set limitConstraints $constraintList
+ # Check for boolean values
+ if {[catch {expr {$value && $value}} msg]} {
+ return -code error $msg
+ }
+ set limitConstraints $value
+ if {!$limitConstraints} {return $limitConstraints}
foreach elt [array names testConstraints] {
- if {[lsearch -exact $constraintsSpecified $elt] == -1} {
+ if {[lsearch -exact [ConstraintsSpecifiedByCommandLineArgument] $elt]
+ == -1} {
testConstraint $elt 0
}
}
@@ -951,10 +965,6 @@ proc tcltest::PrintError {errorMsg} {
return
}
-if {[llength [info commands tcltest::initConstraintsHook]] == 0} {
- proc tcltest::initConstraintsHook {} {}
-}
-
# tcltest::SafeFetch --
#
# The following trace procedure makes it so that we can safely
@@ -981,16 +991,44 @@ proc tcltest::SafeFetch {n1 n2 op} {
DebugPuts 3 "entering SafeFetch $n1 $n2 $op"
if {[string equal {} $n2]} {return}
if {![info exists testConstraints($n2)]} {
- testConstraint $n2 0
+ if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} {
+ testConstraint $n2 0
+ }
}
}
+# tcltest::ConstraintInitializer --
+#
+# Get or set a script that when evaluated in the tcltest namespace
+# will return a boolean value with which to initialize the
+# associated constraint.
+#
+# Arguments:
+# constraint - name of the constraint initialized by the script
+# script - the initializer script
+#
+# Results
+# boolean value of the constraint - enabled or disabled
+#
+# Side effects:
+# Constraint is initialized for future reference by [test]
+proc tcltest::ConstraintInitializer {constraint {script ""}} {
+ variable ConstraintInitializer
+ DebugPuts 3 "entering ConstraintInitializer $constraint $script"
+ if {[llength [info level 0]] == 2} {
+ return $ConstraintInitializer($constraint)
+ }
+ # Check for boolean values
+ if {![info complete $script]} {
+ return -code error "ConstraintInitializer must be complete script"
+ }
+ set ConstraintInitializer($constraint) $script
+}
+
# tcltest::InitConstraints --
#
-# Check constraint information that will determine which tests to run.
-# To do this, create an array testConstraints. Each element has a value
-# of 0 or 1. If the element is "true" then tests with that constraint
-# will be run, otherwise tests with that constraint will be skipped.
+# Call all registered constraint initializers to force initialization
+# of all known constraints.
# See the tcltest man page for the list of built-in constraints defined
# in this procedure.
#
@@ -1006,118 +1044,109 @@ proc tcltest::SafeFetch {n1 n2 op} {
#
proc tcltest::InitConstraints {} {
- global tcl_platform tcl_interactive tk_version
- variable testConstraints
-
- # Safely refer to non-existent members of the testConstraints array
- # without causing an error.
- trace variable testConstraints r [namespace code SafeFetch]
-
+ variable ConstraintInitializer
initConstraintsHook
+ foreach constraint [array names ConstraintInitializer] {
+ testConstraint $constraint
+ }
+}
- testConstraint singleTestInterp [singleProcess]
+proc tcltest::DefineConstraintInitializers {} {
+ ConstraintInitializer singleTestInterp {singleProcess}
# All the 'pc' constraints are here for backward compatibility and
# are not documented. They have been replaced with equivalent 'win'
# constraints.
- testConstraint unixOnly [string equal $tcl_platform(platform) unix]
- testConstraint macOnly \
- [string equal $tcl_platform(platform) macintosh]
- testConstraint pcOnly [string equal $tcl_platform(platform) windows]
- testConstraint winOnly \
- [string equal $tcl_platform(platform) windows]
-
- testConstraint unix [testConstraint unixOnly]
- testConstraint mac [testConstraint macOnly]
- testConstraint pc [testConstraint pcOnly]
- testConstraint win [testConstraint winOnly]
-
- testConstraint unixOrPc \
- [expr {[testConstraint unix] || [testConstraint pc]}]
- testConstraint macOrPc \
- [expr {[testConstraint mac] || [testConstraint pc]}]
- testConstraint unixOrWin \
- [expr {[testConstraint unix] || [testConstraint win]}]
- testConstraint macOrWin \
- [expr {[testConstraint mac] || [testConstraint win]}]
- testConstraint macOrUnix \
- [expr {[testConstraint mac] || [testConstraint unix]}]
-
- testConstraint nt [string equal $tcl_platform(os) "Windows NT"]
- testConstraint 95 [string equal $tcl_platform(os) "Windows 95"]
- testConstraint 98 [string equal $tcl_platform(os) "Windows 98"]
+ ConstraintInitializer unixOnly \
+ {string equal $::tcl_platform(platform) unix}
+ ConstraintInitializer macOnly \
+ {string equal $::tcl_platform(platform) macintosh}
+ ConstraintInitializer pcOnly \
+ {string equal $::tcl_platform(platform) windows}
+ ConstraintInitializer winOnly \
+ {string equal $::tcl_platform(platform) windows}
+
+ ConstraintInitializer unix {testConstraint unixOnly}
+ ConstraintInitializer mac {testConstraint macOnly}
+ ConstraintInitializer pc {testConstraint pcOnly}
+ ConstraintInitializer win {testConstraint winOnly}
+
+ ConstraintInitializer unixOrPc \
+ {expr {[testConstraint unix] || [testConstraint pc]}}
+ ConstraintInitializer macOrPc \
+ {expr {[testConstraint mac] || [testConstraint pc]}}
+ ConstraintInitializer unixOrWin \
+ {expr {[testConstraint unix] || [testConstraint win]}}
+ ConstraintInitializer macOrWin \
+ {expr {[testConstraint mac] || [testConstraint win]}}
+ ConstraintInitializer macOrUnix \
+ {expr {[testConstraint mac] || [testConstraint unix]}}
+
+ ConstraintInitializer nt {string equal $tcl_platform(os) "Windows NT"}
+ ConstraintInitializer 95 {string equal $tcl_platform(os) "Windows 95"}
+ ConstraintInitializer 98 {string equal $tcl_platform(os) "Windows 98"}
# The following Constraints switches are used to mark tests that
# should work, but have been temporarily disabled on certain
# platforms because they don't and we haven't gotten around to
# fixing the underlying problem.
- testConstraint tempNotPc [expr {![testConstraint pc]}]
- testConstraint tempNotWin [expr {![testConstraint win]}]
- testConstraint tempNotMac [expr {![testConstraint mac]}]
- testConstraint tempNotUnix [expr {![testConstraint unix]}]
+ ConstraintInitializer tempNotPc {expr {![testConstraint pc]}}
+ ConstraintInitializer tempNotWin {expr {![testConstraint win]}}
+ ConstraintInitializer tempNotMac {expr {![testConstraint mac]}}
+ ConstraintInitializer tempNotUnix {expr {![testConstraint unix]}}
# The following Constraints switches are used to mark tests that
# crash on certain platforms, so that they can be reactivated again
# when the underlying problem is fixed.
- testConstraint pcCrash [expr {![testConstraint pc]}]
- testConstraint winCrash [expr {![testConstraint win]}]
- testConstraint macCrash [expr {![testConstraint mac]}]
- testConstraint unixCrash [expr {![testConstraint unix]}]
+ ConstraintInitializer pcCrash {expr {![testConstraint pc]}}
+ ConstraintInitializer winCrash {expr {![testConstraint win]}}
+ ConstraintInitializer macCrash {expr {![testConstraint mac]}}
+ ConstraintInitializer unixCrash {expr {![testConstraint unix]}}
# Skip empty tests
- testConstraint emptyTest 0
+ ConstraintInitializer emptyTest {format 0}
# By default, tests that expose known bugs are skipped.
- testConstraint knownBug 0
+ ConstraintInitializer knownBug {format 0}
# By default, non-portable tests are skipped.
- testConstraint nonPortable 0
+ ConstraintInitializer nonPortable {format 0}
# Some tests require user interaction.
- testConstraint userInteraction 0
+ ConstraintInitializer userInteraction {format 0}
# Some tests must be skipped if the interpreter is not in
# interactive mode
- if {[info exists tcl_interactive]} {
- testConstraint interactive $tcl_interactive
- } else {
- testConstraint interactive 0
- }
+ ConstraintInitializer interactive \
+ {expr {[info exists ::tcl_interactive] && $::tcl_interactive}}
# Some tests can only be run if the installation came from a CD
# image instead of a web image. Some tests must be skipped if you
# are running as root on Unix. Other tests can only be run if you
# are running as root on Unix.
- testConstraint root 0
- testConstraint notRoot 1
- if {[string equal unix $tcl_platform(platform)]
- && ([string equal root $tcl_platform(user)]
- || [string equal "" $tcl_platform(user)])} {
- testConstraint root 1
- testConstraint notRoot 0
- }
+ ConstraintInitializer root {expr \
+ {[string equal unix $::tcl_platform(platform)]
+ && ([string equal root $::tcl_platform(user)]
+ || [string equal "" $::tcl_platform(user)])}}
+ ConstraintInitializer notRoot {expr {![testConstraint root]}}
# Set nonBlockFiles constraint: 1 means this platform supports
# setting files into nonblocking mode.
- if {[catch {set f [open defs r]}]} {
- testConstraint nonBlockFiles 1
- } else {
- if {[catch {fconfigure $f -blocking off}] == 0} {
- testConstraint nonBlockFiles 1
- } else {
- testConstraint nonBlockFiles 0
- }
- close $f
+ ConstraintInitializer nonBlockFiles {
+ set code [expr {[catch {set f [open defs r]}]
+ || [catch {fconfigure $f -blocking off}]}]
+ catch {close $f}
+ set code
}
# Set asyncPipeClose constraint: 1 means this platform supports
@@ -1127,94 +1156,82 @@ proc tcltest::InitConstraints {} {
# potential problem with select is apparently interfering.
# (Mark Diekhans).
- testConstraint asyncPipeClose 1
- if {[string equal unix $tcl_platform(platform)] && ([catch {
- exec uname -X | fgrep {Release = 3.2v}}] == 0)} {
- testConstraint asyncPipeClose 0
- }
+ ConstraintInitializer asyncPipeClose {expr {
+ !([string equal unix $::tcl_platform(platform)]
+ && ([catch {exec uname -X | fgrep {Release = 3.2v}}] == 0))}}
# Test to see if we have a broken version of sprintf with respect
# to the "e" format of floating-point numbers.
- testConstraint eformat 1
- if {![string equal [format %g 5e-5] 5e-05]} {
- testConstraint eformat 0
- }
+ ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05}
# Test to see if execed commands such as cat, echo, rm and so forth
# are present on this machine.
- testConstraint unixExecs 1
- if {[string equal macintosh $tcl_platform(platform)]} {
- testConstraint unixExecs 0
- }
- if {[testConstraint unixExecs]
- && [string equal windows $tcl_platform(platform)]} {
- set file "_tcl_test_remove_me.txt"
- if {[catch {
- set fid [open $file w]
- puts $fid "hello"
- close $fid
- }]} {
- testConstraint unixExecs 0
- } elseif {
- [catch {exec cat $file}] ||
- [catch {exec echo hello}] ||
- [catch {exec sh -c echo hello}] ||
- [catch {exec wc $file}] ||
- [catch {exec sleep 1}] ||
- [catch {exec echo abc > $file}] ||
- [catch {exec chmod 644 $file}] ||
- [catch {exec rm $file}] ||
- [string equal {} [auto_execok mkdir]] ||
- [string equal {} [auto_execok fgrep]] ||
- [string equal {} [auto_execok grep]] ||
- [string equal {} [auto_execok ps]]
+ ConstraintInitializer unixExecs {
+ set code 1
+ if {[string equal macintosh $::tcl_platform(platform)]} {
+ set code 0
+ }
+ if {[string equal windows $::tcl_platform(platform)]} {
+ if {[catch {
+ set file _tcl_test_remove_me.txt
+ makeFile {hello} $file
+ }]} {
+ set code 0
+ } elseif {
+ [catch {exec cat $file}] ||
+ [catch {exec echo hello}] ||
+ [catch {exec sh -c echo hello}] ||
+ [catch {exec wc $file}] ||
+ [catch {exec sleep 1}] ||
+ [catch {exec echo abc > $file}] ||
+ [catch {exec chmod 644 $file}] ||
+ [catch {exec rm $file}] ||
+ [llength [auto_execok mkdir]] == 0 ||
+ [llength [auto_execok fgrep]] == 0 ||
+ [llength [auto_execok grep]] == 0 ||
+ [llength [auto_execok ps]] == 0
} {
- testConstraint unixExecs 0
- }
- file delete -force $file
- }
-
- # Locate tcltest executable
- if {![info exists tk_version]} {
- interpreter [info nameofexecutable]
+ set code 0
+ }
+ removeFile $file
+ }
+ set code
}
- testConstraint stdio 0
- catch {
- catch {file delete -force tmp}
- set f [open tmp w]
- puts $f {
- exit
+ ConstraintInitializer stdio {
+ set code 0
+ if {![catch {set f [open "|[list [interpreter]]" w]}]} {
+ if {![catch {puts $f exit}]} {
+ if {![catch {close $f}]} {
+ set code 1
+ }
+ }
}
- close $f
-
- set f [open "|[list [interpreter] tmp]" r]
- close $f
-
- testConstraint stdio 1
+ set code
}
- catch {file delete -force tmp}
# Deliberately call socket with the wrong number of arguments. The
# error message you get will indicate whether sockets are available
# on this system.
- catch {socket} msg
- testConstraint socket [string compare $msg \
- "sockets are not available on this system"]
+ ConstraintInitializer socket {
+ catch {socket} msg
+ string compare $msg "sockets are not available on this system"
+ }
# Check for internationalization
-
- if {[llength [info commands testlocale]] == 0} {
- # No testlocale command, no tests...
- testConstraint hasIsoLocale 0
- } else {
- testConstraint hasIsoLocale \
- [string length [SetIso8859_1_Locale]]
- RestoreLocale
+ ConstraintInitializer hasIsoLocale {
+ if {[llength [info commands testlocale]] == 0} {
+ set code 0
+ } else {
+ set code [string length [SetIso8859_1_Locale]]
+ RestoreLocale
+ }
+ set code
}
+
}
#####################################################################
@@ -1399,12 +1416,12 @@ proc tcltest::ProcessFlags {flagArray} {
# Use the -constraints flag, if given, to turn on constraints that
# are turned off by default: userInteractive knownBug nonPortable.
- # This code fragment must be run after constraints are initialized.
if {[info exists flag(-constraints)]} {
foreach elt $flag(-constraints) {
testConstraint $elt 1
}
+ ConstraintsSpecifiedByCommandLineArgument $flag(-constraints)
}
# Use the -limitconstraints flag, if given, to tell the harness to
@@ -2220,7 +2237,6 @@ proc tcltest::RunTest {
variable numTests
variable skip
variable match
- variable limitConstraints
variable testConstraints
variable originalTclPlatform
variable coreModTime
@@ -2264,7 +2280,7 @@ proc tcltest::RunTest {
if {[string equal {} $constraints]} {
# If we're limited to the listed constraints and there aren't
# any listed, then we shouldn't run the test.
- if {$limitConstraints} {
+ if {[limitConstraints]} {
AddToSkippedBecause userSpecifiedLimitConstraint
if {$testLevel == 1} {
incr numTests(Skipped)
@@ -3309,7 +3325,25 @@ proc tcltest::threadReap {} {
# Initialize the constraints and set up command line arguments
namespace eval tcltest {
- InitConstraints
+ # Define initializers for all the built-in contraint definitions
+ DefineConstraintInitializers
+
+ # Set up the constraints in the testConstraints array to be lazily
+ # initialized by a registered initializer, or by "false" if no
+ # initializer is registered.
+ trace variable testConstraints r [namespace code SafeFetch]
+
+ # Only initialize constraints at package load time if an
+ # [initConstraintsHook] has been pre-defined. This is only
+ # for compatibility support. The modern way to add a custom
+ # test constraint is to just call the [testConstraint] command
+ # straight away, without all this "hook" nonsense.
+ if {[string equal [namespace current] \
+ [namespace qualifiers [namespace which initConstraintsHook]]]} {
+ InitConstraints
+ } else {
+ proc initConstraintsHook {} {}
+ }
ProcessCmdLineArgs
# Save the names of files that already exist in
diff --git a/tests/io.test b/tests/io.test
index c2eae3d..067db18 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -12,7 +12,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: io.test,v 1.30 2002/05/31 23:16:17 dgp Exp $
+# RCS: @(#) $Id: io.test,v 1.31 2002/06/06 18:44:43 dgp Exp $
if {[catch {package require tcltest 2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2 required."
@@ -982,7 +982,7 @@ test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio}
fconfigure $f -buffering none
puts -nonewline $f "foobar"
fconfigure $f -blocking 0
- set x {}
+ variable x {}
after 500 [namespace code { lappend x timeout }]
fileevent $f readable [namespace code { lappend x [gets $f] }]
vwait [namespace which -variable x]
@@ -1042,7 +1042,7 @@ test io-7.4 {FilterInputBytes: recover from split up character} {stdio} {
puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82"
fconfigure $f -encoding shiftjis -blocking 0
fileevent $f read [namespace code "ready $f"]
- set x {}
+ variable x {}
proc ready {f} {
variable x
lappend x [gets $f line] $line [fblocked $f]
@@ -1077,7 +1077,7 @@ test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testcha
set f [open "|[list [interpreter] cat]" w+]
fconfigure $f -translation lf -encoding ascii -buffering none
puts -nonewline $f "123456789012345\r\nbcdefghijklmnopqrstuvwxyz"
- set x {}
+ variable x {}
fileevent $f read [namespace code "ready $f"]
proc ready {f} {
variable x
@@ -1327,7 +1327,7 @@ test io-12.4 {ReadChars: split-up char} {stdio testchannel} {
variable x
lappend x [read $f] [testchannel inputbuffered $f]
}
- set x {}
+ variable x {}
fconfigure $f -encoding shiftjis
vwait [namespace which -variable x]
@@ -1356,7 +1356,7 @@ test io-12.5 {ReadChars: fileevents on partial characters} {stdio} {
puts $f "go1"
flush $f
fconfigure $f -blocking 0 -encoding utf-8
- set x {}
+ variable x {}
vwait [namespace which -variable x]
after 500 [namespace code { lappend x timeout }]
vwait [namespace which -variable x]
@@ -1446,8 +1446,8 @@ test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testc
variable x
lappend x [read $f] [testchannel queuedcr $f]
}
- set x {}
- set y {}
+ variable x {}
+ variable y {}
puts -nonewline $f "abcdefghj\r"
after 500 [namespace code {set y ok}]
@@ -2656,7 +2656,7 @@ test io-29.33 {Tcl_Flush, implicit flush on exit} {stdio} {
} "hello\nbye\nstrange\n"
test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMac} {
set c 0
- set x running
+ variable x running
set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz
proc writelots {s l} {
for {set i 0} {$i < 2000} {incr i} {
@@ -4682,6 +4682,7 @@ test io-36.4 {Tcl_InputBlocked vs files, event driven read} {
set f [open test1 r]
set l ""
fileevent $f readable [namespace code [list in $f]]
+ variable x
vwait [namespace which -variable x]
set l
} {abc def ghi jkl mno {p
@@ -4718,6 +4719,7 @@ test io-36.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles} {
fconfigure $f -blocking off
set l ""
fileevent $f readable [namespace code [list in $f]]
+ variable x
vwait [namespace which -variable x]
set l
} {abc def ghi jkl mno {p
@@ -4998,7 +5000,7 @@ test io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA}
puts -nonewline $f "\xe7"
flush $f
fconfigure $f -encoding utf-8 -blocking 0
- set x {}
+ variable x {}
fileevent $f readable [namespace code { lappend x [read $f] }]
vwait [namespace which -variable x]
after 300 [namespace code { lappend x timeout }]
@@ -5385,7 +5387,7 @@ test io-44.1 {FileEventProc procedure: normal read event} {stdio unixExecs} {
set x [gets $f2]; fileevent $f2 readable {}
}]
puts $f2 text; flush $f2
- set x initial
+ variable x initial
vwait [namespace which -variable x]
set x
} {text}
@@ -5393,7 +5395,7 @@ test io-44.2 {FileEventProc procedure: error in read event} {stdio unixExecs} {
proc ::bgerror args "set [namespace which -variable x] \$args"
fileevent $f2 readable {error bogus}
puts $f2 text; flush $f2
- set x initial
+ variable x initial
vwait [namespace which -variable x]
rename ::bgerror {}
list $x [fileevent $f2 readable]
@@ -5406,7 +5408,7 @@ test io-44.3 {FileEventProc procedure: normal write event} {stdio unixExecs} {
fileevent $f2 writable {}
}
}]
- set x initial
+ variable x initial
set count 3
vwait [namespace which -variable x]
vwait [namespace which -variable x]
@@ -5416,7 +5418,7 @@ test io-44.3 {FileEventProc procedure: normal write event} {stdio unixExecs} {
test io-44.4 {FileEventProc procedure: eror in write event} {stdio unixExecs} {
proc ::bgerror args "set [namespace which -variable x] \$args"
fileevent $f2 writable {error bad-write}
- set x initial
+ variable x initial
vwait [namespace which -variable x]
rename ::bgerror {}
list $x [fileevent $f2 writable]
@@ -5431,7 +5433,7 @@ test io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs} {
lappend x $line
}
}]
- set x initial
+ variable x initial
vwait [namespace which -variable x]
vwait [namespace which -variable x]
close $f4
@@ -5453,6 +5455,7 @@ test io-45.1 {DeleteFileEvent, cleanup on close} {
close $f
set x initial
after 100 [namespace code { set y done }]
+ variable y
vwait [namespace which -variable y]
set x
} {initial}
@@ -5468,7 +5471,7 @@ test io-45.2 {DeleteFileEvent, cleanup on close} {
fileevent $f2 readable {}
}]
close $f
- set x initial
+ variable x initial
vwait [namespace which -variable x]
close $f2
set x
@@ -5516,7 +5519,7 @@ test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent} {
test io-46.2 {Tcl event loop vs multiple interpreters} testfevent {
testfevent create
testfevent cmd {
- set x 0
+ variable x 0
after 100 {set x triggered}
vwait [namespace which -variable x]
set x
@@ -5662,7 +5665,7 @@ test io-48.1 {testing readability conditions} {
}
}
set l ""
- set x not_done
+ variable x not_done
vwait [namespace which -variable x]
list $x $l
} {done {called called called called called called called}}
@@ -5689,7 +5692,7 @@ test io-48.2 {testing readability conditions} {nonBlockFiles} {
}
}
set l ""
- set x not_done
+ variable x not_done
vwait [namespace which -variable x]
list $x $l
} {done {called called called called called called called}}
@@ -5729,7 +5732,7 @@ test io-48.3 {testing readability conditions} {stdio unixOnly nonBlockFiles} {
}
}
set l ""
- set x not_done
+ variable x not_done
puts $f {source my_script}
puts $f {set f [open bar r]}
puts $f {copy_slowly $f}
@@ -5762,6 +5765,7 @@ test io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {
set f [open test1 r]
fconfigure $f -translation auto -eofchar \x1a
fileevent $f readable [namespace code [list consume $f]]
+ variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
@@ -5789,6 +5793,7 @@ test io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} {
set f [open test1 r]
fconfigure $f -eofchar \x1a -translation auto
fileevent $f readable [namespace code [list consume $f]]
+ variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
@@ -5816,6 +5821,7 @@ test io-48.6 {cr write, testing readability, ^Z termination, auto read mode} {
set f [open test1 r]
fconfigure $f -translation auto -eofchar \x1a
fileevent $f readable [namespace code [list consume $f]]
+ variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
@@ -5843,6 +5849,7 @@ test io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} {
set f [open test1 r]
fconfigure $f -eofchar \x1a -translation auto
fileevent $f readable [namespace code [list consume $f]]
+ variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
@@ -5870,6 +5877,7 @@ test io-48.8 {crlf write, testing readability, ^Z termination, auto read mode} {
set f [open test1 r]
fconfigure $f -translation auto -eofchar \x1a
fileevent $f readable [namespace code [list consume $f]]
+ variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
@@ -5897,6 +5905,7 @@ test io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} {
set f [open test1 r]
fconfigure $f -eofchar \x1a -translation auto
fileevent $f readable [namespace code [list consume $f]]
+ variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
@@ -5924,6 +5933,7 @@ test io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} {
set f [open test1 r]
fconfigure $f -eofchar \x1a -translation lf
fileevent $f readable [namespace code [list consume $f]]
+ variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
@@ -5951,6 +5961,7 @@ test io-48.11 {lf write, testing readability, ^Z termination, lf read mode} {
set f [open test1 r]
fconfigure $f -translation lf -eofchar \x1a
fileevent $f readable [namespace code [list consume $f]]
+ variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
@@ -5978,6 +5989,7 @@ test io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} {
set f [open test1 r]
fconfigure $f -eofchar \x1a -translation cr
fileevent $f readable [namespace code [list consume $f]]
+ variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
@@ -6005,6 +6017,7 @@ test io-48.13 {cr write, testing readability, ^Z termination, cr read mode} {
set f [open test1 r]
fconfigure $f -translation cr -eofchar \x1a
fileevent $f readable [namespace code [list consume $f]]
+ variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
@@ -6032,6 +6045,7 @@ test io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} {
set f [open test1 r]
fconfigure $f -eofchar \x1a -translation crlf
fileevent $f readable [namespace code [list consume $f]]
+ variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
@@ -6059,6 +6073,7 @@ test io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} {
set f [open test1 r]
fconfigure $f -translation crlf -eofchar \x1a
fileevent $f readable [namespace code [list consume $f]]
+ variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
@@ -6352,7 +6367,7 @@ test io-51.1 {Test old socket deletion on Macintosh} {socket} {
set wait done
}
set ss [socket -server [namespace code accept] 0]
- set wait ""
+ variable wait ""
set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]
vwait [namespace which -variable wait]
lappend result [gets $cs]
@@ -6607,6 +6622,7 @@ test io-53.2 {CopyData} {
fconfigure $f2 -translation cr -blocking 0
fcopy $f1 $f2 -command [namespace code {set s0}]
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
+ variable s0
vwait [namespace which -variable s0]
close $f1
close $f2
@@ -6649,6 +6665,7 @@ test io-53.3 {CopyData: background read underflow} {stdio unixOnly} {
} "ready line1 line2 {done\n}"
test io-53.4 {CopyData: background write overflow} {stdio unixOnly} {
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
+ variable x
for {set x 0} {$x < 12} {incr x} {
append big $big
}
@@ -6698,12 +6715,14 @@ proc FcopyTestDone {bytes {error {}}} {
}
test io-53.5 {CopyData: error during fcopy} {socket} {
+ variable fcopyTestDone
set listen [socket -server [namespace code FcopyTestAccept] 0]
set in [open $thisScript] ;# 126 K
set out [socket 127.0.0.1 [lindex [fconfigure $listen -sockname] 2]]
catch {unset fcopyTestDone}
close $listen ;# This means the socket open never really succeeds
fcopy $in $out -command [namespace code FcopyTestDone]
+ variable fcopyTestDone
if ![info exists fcopyTestDone] {
vwait [namespace which -variable fcopyTestDone] ;# The error occurs here in the b.g.
}
@@ -6712,6 +6731,7 @@ test io-53.5 {CopyData: error during fcopy} {socket} {
set fcopyTestDone ;# 1 for error condition
} 1
test io-53.6 {CopyData: error during fcopy} {stdio} {
+ variable fcopyTestDone
removeFile pipe
removeFile test1
catch {unset fcopyTestDone}
@@ -6748,6 +6768,7 @@ proc doFcopy {in out {bytes 0} {error {}}} {
}
test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio} {
+ variable fcopyTestDone
removeFile pipe
removeFile test1
catch {unset fcopyTestDone}
@@ -6772,6 +6793,7 @@ test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio} {
set in [open "|[list [interpreter] pipe &]" r+]
set out [open test1 w]
doFcopy $in $out
+ variable fcopyTestDone
if ![info exists fcopyTestDone] {
vwait [namespace which -variable fcopyTestDone]
}
@@ -6819,8 +6841,8 @@ test io-54.1 {Recursive channel events} {socket} {
close $ss
error "failed to connect to server"
}
- set result {}
- set x 0
+ variable result {}
+ variable x 0
variable as
vwait [namespace which -variable as]
fconfigure $cs -translation lf
@@ -6838,7 +6860,7 @@ test io-54.1 {Recursive channel events} {socket} {
test io-54.2 {Testing for busy-wait in recursive channel events} {socket} {
set accept {}
set after {}
- set s [socket -server [namespace code accept] 0]
+ variable s [socket -server [namespace code accept] 0]
proc accept {s a p} {
variable counter
variable accept
@@ -6886,6 +6908,7 @@ test io-54.2 {Testing for busy-wait in recursive channel events} {socket} {
set done 1
}
producer
+ variable done
vwait [namespace which -variable done]
close $writer
close $s
@@ -6905,7 +6928,7 @@ test io-55.1 {ChannelEventScriptInvoker: deletion} {
proc ::bgerror {args} "set [namespace which -variable x] got_error"
set f [open fooBar w]
fileevent $f writable [namespace code [list eventScript $f]]
- set x not_done
+ variable x not_done
vwait [namespace which -variable x]
set x
} {got_error}
@@ -6919,12 +6942,13 @@ test io-56.1 {ChannelTimerProc} {testchannelevent} {
read $f 1
incr x
}]
- set x 0
+ variable x 0
vwait [namespace which -variable x]
vwait [namespace which -variable x]
set result $x
testchannelevent $f set 0 none
after idle [namespace code {set y done}]
+ variable y
vwait [namespace which -variable y]
close $f
lappend result $y
@@ -6937,12 +6961,13 @@ test io-57.1 {buffered data and file events, gets} {
}
set server [socket -server [namespace code accept] 0]
set s [socket 127.0.0.1 [lindex [fconfigure $server -sockname] 2]]
+ variable s2
vwait [namespace which -variable s2]
update
fileevent $s2 readable [namespace code {lappend result readable}]
puts $s "12\n34567890"
flush $s
- set result [gets $s2]
+ variable result [gets $s2]
after 1000 [namespace code {lappend result timer}]
vwait [namespace which -variable result]
lappend result [gets $s2]
@@ -6959,12 +6984,13 @@ test io-57.2 {buffered data and file events, read} {
}
set server [socket -server [namespace code accept] 0]
set s [socket 127.0.0.1 [lindex [fconfigure $server -sockname] 2]]
+ variable s2
vwait [namespace which -variable s2]
update
fileevent $s2 readable [namespace code {lappend result readable}]
puts -nonewline $s "1234567890"
flush $s
- set result [read $s2 1]
+ variable result [read $s2 1]
after 1000 [namespace code {lappend result timer}]
vwait [namespace which -variable result]
lappend result [read $s2 9]
@@ -6996,7 +7022,7 @@ test io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrPc} {
close $out
set pipe [open "|[list [interpreter]] script" r]
fileevent $pipe readable [namespace code [list readit $pipe]]
- set x ""
+ variable x ""
set result ""
vwait [namespace which -variable x]
list $x $result
diff --git a/tests/tcltest.test b/tests/tcltest.test
index b876367..3bb2d36 100755
--- a/tests/tcltest.test
+++ b/tests/tcltest.test
@@ -6,7 +6,7 @@
# Copyright (c) 2000 by Ajuba Solutions
# All rights reserved.
#
-# RCS: @(#) $Id: tcltest.test,v 1.23 2002/06/05 01:12:38 dgp Exp $
+# RCS: @(#) $Id: tcltest.test,v 1.24 2002/06/06 18:44:44 dgp Exp $
if {[catch {package require tcltest 2.1}]} {
puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
@@ -213,7 +213,7 @@ test tcltest-4.6 {tcltest::skip} {
}
# -constraints, -limitconstraints, [testConstraint],
-# [constraintsSpecified], [constraintList], [limitConstraints]
+# $constraintsSpecified, [limitConstraints]
test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrPc} {
set result [catch {exec [interpreter] test.tcl -constraints knownBug -verbose 'ps'} msg]
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
@@ -236,29 +236,31 @@ test tcltest-5.3 {testConstraint - constraint empty (tcltest::safeFetch)} {
-cleanup {unset ::tcltest::testConstraints(tcltestFakeConstraint)}
}
-test tcltest-5.4 {tcltest::constraintsSpecified} {
- -setup {
- set constraintlist $::tcltest::constraintsSpecified
- set ::tcltest::constraintsSpecified {}
- }
- -body {
- set r1 $::tcltest::constraintsSpecified
- testConstraint tcltestFakeConstraint1 1
- set r2 $::tcltest::constraintsSpecified
- testConstraint tcltestFakeConstraint2 1
- set r3 $::tcltest::constraintsSpecified
- list $r1 $r2 $r3
- }
- -result {{} tcltestFakeConstraint1 {tcltestFakeConstraint1 tcltestFakeConstraint2}}
- -cleanup {
- set ::tcltest::constraintsSpecified $constraintlist
- unset ::tcltest::testConstraints(tcltestFakeConstraint1)
- unset ::tcltest::testConstraints(tcltestFakeConstraint2)
- }
-}
-
-test tcltest-5.5 {tcltest::constraintList} \
- -constraints {!$::tcltest::testConstraints(singleTestInterp)} \
+# Removed this test of internals of tcltest. Those internals have changed.
+#test tcltest-5.4 {tcltest::constraintsSpecified} {
+# -setup {
+# set constraintlist $::tcltest::constraintsSpecified
+# set ::tcltest::constraintsSpecified {}
+# }
+# -body {
+# set r1 $::tcltest::constraintsSpecified
+# testConstraint tcltestFakeConstraint1 1
+# set r2 $::tcltest::constraintsSpecified
+# testConstraint tcltestFakeConstraint2 1
+# set r3 $::tcltest::constraintsSpecified
+# list $r1 $r2 $r3
+# }
+# -result {{} tcltestFakeConstraint1 {tcltestFakeConstraint1 tcltestFakeConstraint2}}
+# -cleanup {
+# set ::tcltest::constraintsSpecified $constraintlist
+# unset ::tcltest::testConstraints(tcltestFakeConstraint1)
+# unset ::tcltest::testConstraints(tcltestFakeConstraint2)
+# }
+#}
+
+test tcltest-5.5 {InitConstraints: list of built-in constraints} \
+ -constraints {!singleTestInterp} \
+ -setup {tcltest::InitConstraints} \
-body { lsort [array names ::tcltest::testConstraints] } \
-result [lsort {
95 98 asyncPipeClose eformat emptyTest hasIsoLocale interactive knownBug
@@ -268,23 +270,26 @@ test tcltest-5.5 {tcltest::constraintList} \
unixOrWin userInteraction win winCrash winOnly
}]
-test tcltest-5.6 {tcltest::limitConstraints} {
- -setup {
- set keeplc $::tcltest::limitConstraints
- set keepkb [testConstraint knownBug]
- }
- -body {
- set r1 [limitConstraints]
- set r2 [limitConstraints knownBug]
- set r3 [limitConstraints]
- list $r1 $r2 $r3
- }
- -cleanup {
- limitConstraints $keeplc
- testConstraint knownBug $keepkb
- }
- -result {false knownBug knownBug}
-}
+# Removed this broken test. Its usage of [limitConstraints] was not
+# in agreement with the documentation. [limitConstraints] is supposed
+# to take an optional boolean argument, and "knownBug" ain't no boolean!
+#test tcltest-5.6 {tcltest::limitConstraints} {
+# -setup {
+# set keeplc $::tcltest::limitConstraints
+# set keepkb [testConstraint knownBug]
+# }
+# -body {
+# set r1 [limitConstraints]
+# set r2 [limitConstraints knownBug]
+# set r3 [limitConstraints]
+# list $r1 $r2 $r3
+# }
+# -cleanup {
+# limitConstraints $keeplc
+# testConstraint knownBug $keepkb
+# }
+# -result {false knownBug knownBug}
+#}
# -outfile, -errfile, [outputChannel], [outputFile], [errorChannel], [errorFile]
set printerror [makeFile {
generated by cgit v0.12 at 2024-11-23 03:15:35 (GMT)