summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorhershey <hershey>1999-03-11 18:49:22 (GMT)
committerhershey <hershey>1999-03-11 18:49:22 (GMT)
commit07d6012fb42480a22f42f53b9d73eb838d5c67d7 (patch)
tree0462404b0b65394e3ef76acdc52cc18966fb9789
parent4a327a6afdf45b23c8606d5f3d5a51b2b7876384 (diff)
downloadtcl-07d6012fb42480a22f42f53b9d73eb838d5c67d7.zip
tcl-07d6012fb42480a22f42f53b9d73eb838d5c67d7.tar.gz
tcl-07d6012fb42480a22f42f53b9d73eb838d5c67d7.tar.bz2
Updated the testsuite to use "test" namespace and commandline args
to control verbose level and which tests get run. Tests now work from any working dir.
-rw-r--r--tests/README256
-rw-r--r--tests/all.tcl61
-rw-r--r--tests/append.test11
-rw-r--r--tests/assocd.test12
-rw-r--r--tests/async.test10
-rw-r--r--tests/autoMkindex.test24
-rw-r--r--tests/basic.test11
-rw-r--r--tests/binary.test10
-rw-r--r--tests/case.test10
-rw-r--r--tests/clock.test10
-rw-r--r--tests/cmdAH.test9
-rw-r--r--tests/cmdIL.test20
-rw-r--r--tests/cmdInfo.test11
-rw-r--r--tests/cmdMZ.test10
-rw-r--r--tests/compExpr-old.test10
-rw-r--r--tests/compExpr.test12
-rw-r--r--tests/compile.test10
-rw-r--r--tests/concat.test10
-rw-r--r--tests/dcall.test10
-rw-r--r--tests/defs597
-rw-r--r--tests/defs.tcl810
-rw-r--r--tests/dstring.test11
-rw-r--r--tests/encoding.test11
-rw-r--r--tests/env.test11
-rw-r--r--tests/error.test10
-rw-r--r--tests/eval.test10
-rw-r--r--tests/event.test11
-rw-r--r--tests/exec.test13
-rw-r--r--tests/execute.test10
-rw-r--r--tests/expr-old.test10
-rw-r--r--tests/expr.test11
-rw-r--r--tests/fCmd.test33
-rw-r--r--tests/fileName.test8
-rw-r--r--tests/for-old.test5
-rw-r--r--tests/for.test5
-rw-r--r--tests/foreach.test6
-rw-r--r--tests/format.test6
-rw-r--r--tests/get.test10
-rw-r--r--tests/history.test10
-rw-r--r--tests/http.test19
-rw-r--r--tests/httpold.test20
-rw-r--r--tests/if-old.test10
-rw-r--r--tests/if.test10
-rw-r--r--tests/incr-old.test10
-rw-r--r--tests/incr.test10
-rw-r--r--tests/indexObj.test14
-rw-r--r--tests/info.test10
-rw-r--r--tests/init.test16
-rw-r--r--tests/interp.test10
-rw-r--r--tests/io.test85
-rw-r--r--tests/ioCmd.test23
-rw-r--r--tests/ioUtil.test13
-rw-r--r--tests/join.test11
-rw-r--r--tests/lindex.test10
-rw-r--r--tests/link.test10
-rw-r--r--tests/linsert.test11
-rw-r--r--tests/list.test10
-rw-r--r--tests/listObj.test10
-rw-r--r--tests/llength.test10
-rw-r--r--tests/load.test10
-rw-r--r--tests/lrange.test10
-rw-r--r--tests/lreplace.test11
-rw-r--r--tests/lsearch.test10
-rw-r--r--tests/macFCmd.test19
-rw-r--r--tests/misc.test10
-rw-r--r--tests/msgcat.test23
-rw-r--r--tests/namespace-old.test10
-rw-r--r--tests/namespace.test11
-rw-r--r--tests/obj.test10
-rw-r--r--tests/opt.test11
-rw-r--r--tests/osa.test12
-rw-r--r--tests/parse.test11
-rw-r--r--tests/parseExpr.test10
-rw-r--r--tests/parseOld.test10
-rw-r--r--tests/pid.test12
-rw-r--r--tests/pkg.test17
-rw-r--r--tests/pkgMkIndex.test38
-rw-r--r--tests/platform.test6
-rw-r--r--tests/proc-old.test10
-rw-r--r--tests/proc.test11
-rw-r--r--tests/pwd.test12
-rw-r--r--tests/reg.test19
-rw-r--r--tests/regexp.test10
-rw-r--r--tests/registry.test26
-rw-r--r--tests/rename.test11
-rw-r--r--tests/resource.test13
-rw-r--r--tests/result.test9
-rw-r--r--tests/safe.test10
-rw-r--r--tests/scan.test10
-rw-r--r--tests/security.test18
-rw-r--r--tests/set-old.test12
-rw-r--r--tests/set.test10
-rw-r--r--tests/socket.test70
-rw-r--r--tests/source.test13
-rw-r--r--tests/split.test12
-rw-r--r--tests/stack.test30
-rw-r--r--tests/string.test12
-rw-r--r--tests/stringObj.test11
-rw-r--r--tests/subst.test10
-rw-r--r--tests/switch.test10
-rw-r--r--tests/thread.test14
-rw-r--r--tests/timer.test10
-rw-r--r--tests/trace.test11
-rw-r--r--tests/unixFCmd.test16
-rw-r--r--tests/unixFile.test26
-rw-r--r--tests/unixInit.test15
-rw-r--r--tests/unixNotfy.test14
-rw-r--r--tests/unknown.test10
-rw-r--r--tests/uplevel.test11
-rw-r--r--tests/upvar.test10
-rw-r--r--tests/utf.test12
-rw-r--r--tests/util.test10
-rw-r--r--tests/var.test10
-rw-r--r--tests/while-old.test10
-rw-r--r--tests/while.test10
-rw-r--r--tests/winFCmd.test28
-rw-r--r--tests/winFile.test16
-rw-r--r--tests/winNotify.test14
-rw-r--r--tests/winPipe.test28
119 files changed, 2204 insertions, 1108 deletions
diff --git a/tests/README b/tests/README
index 3bfb3c9..ffb4e02 100644
--- a/tests/README
+++ b/tests/README
@@ -1,7 +1,10 @@
-Tcl Test Suite
---------------
+README -- Tcl test suite design document.
-RCS: @(#) $Id: README,v 1.1.2.1 1998/09/24 23:59:19 stanton Exp $
+RCS: @(#) $Id: README,v 1.1.2.2 1999/03/11 18:49:22 hershey Exp $
+
+
+Introduction:
+-------------
This directory contains a set of validation tests for the Tcl
commands. Each of the files whose name ends in ".test" is
@@ -9,88 +12,227 @@ intended to fully exercise one or a few Tcl commands. The
commands tested by a given file are listed in the first line
of the file.
-You can run the tests in two ways:
+You can run the tests in three ways:
+
(a) type "make test" in ../unix; this will run all of the tests.
- (b) start up tcltest in this directory, then "source" the test
+
+ (b) type "tcltest <testFile> ?<option> <value>?
+
+ (c) start up tcltest in this directory, then "source" the test
file (for example, type "source parse.test"). To run all
- of the tests, type "source all".
-In either case no output will be generated if all goes well, except
-for a listing of the tests.. If there are errors then additional
-messages will appear in the format described below. Note: don't
-run the tests as superuser, since this will cause several of the tests
-to fail.
+ of the tests, type "source all.tcl".
-The rest of this file provides additional information on the
-features of the testing environment.
+In all cases, no output will be generated if all goes well, except for
+a listing of the tests.. If there are errors then additional messages
+will appear in the format described below. Note that some tests will
+be skipped if you run as superuser.
This approach to testing was designed and initially implemented
by Mary Ann May-Pumphrey of Sun Microsystems. Many thanks to
her for donating her work back to the public Tcl release.
+The rest of this file provides additional information on the
+features of the testing environment.
+
+
Definitions file:
-----------------
-The file "defs" defines a collection of procedures and variables
-used to run the tests. It is read in automatically by each of the
-.test files if needed, but once it has been read once it will not
-be read again by the .test files. If you change defs while running
-tests you'll have to "source" it by hand to load its new contents.
+The file "defs.tcl" defines the "test" namespace which contains a
+collection of procedures and variables used to run the tests. It is
+read in automatically by each of the .test files if needed, but once
+it has been read once it will not be read again by the .test files.
+Currently, the following procedures are exported from the "test"
+namespace and automatically imported:
+
+ cleanupTests dotests saveState restoreState normalizeMsg
+ makeFile removeFile makeDirectory removeDirectory viewFile
+ safeFetch bytestring set_iso8859_1_locale restore_locale
+ setTmpDir
+
+Please refer to the defs.tcl file for these procedures' specs.
+
+To keep tests from polluting the current working directory with
+unwanted files, you can specify a temporary directory, which will
+become the current working directory for the tests, by specifying
+-tmpdir on the command line or by calling the ::test::setTmpDir
+procedure (after sourcing the defs.tcl file). The default working dir
+is the directory from which tcltest was called. Please note that when
+you run the test suite by calling "make test", the working dir is
+<tcl8.1>/tests.
+
Test output:
------------
-Normally, output only appears when there are errors. However, if
-the variable VERBOSE is set to 1 then tests will be run in "verbose"
-mode and output will be generated for each test regardless of
-whether it succeeded or failed. Test output consists of the
-following information:
+Foreach test file, the number of tests passed, skipped, and failed is
+printed to stdout. Aside from this statistical information, output
+can be controlled on a per-test basis by the ::test::verbose variable.
+
+::test::verbose can be set to any substring or permutation of "bps".
+The default value of ::test::verbose is "b". If 'b' is present, then
+the entire test is printed for each failed test, otherwise only the
+test's name, desired output, and actual output, are printed for each
+failed test. If 'p' is present, then a line is printed for each
+passed test, otherwise no line is printed for passed tests. If 's' is
+present, then a line (containing the consraints taht cause the test to
+be skipped) is printed for each skipped test, otherwise no line is
+printed for skipped tests.
+
+You can set ::test::verbose either interactively (after the defs.tcl
+file has been sourced) or by the command line argument -verbose, for
+example:
+
+ tcltest socket.test -verbose "psb"
+
+
+Selecting files to be sourced by all.tcl:
+-----------------------------------------
+
+You can specify the files you want all.tcl to source on the command
+line with the -file options. For example, if you call the
+following:
+
+ tcltest all.tcl -file unix*.test
+
+all files in <tcl8.1>/tests that match the pattern unix*.test will be
+sourced by the all.tcl file. Another useful example is if a
+particular test hangs, say "get.test", and you just want to run the
+remaining tests, then you can call the following:
+
+ tcltest all.tcl -file [h-z]*.test
- - the test identifier (which can be used to locate the test code
- in the .test file)
- - a brief description of the test
- - the contents of the test code
- - the actual results produced by the tests
- - a "PASSED" or "FAILED" message
- - the expected results (if the test failed)
+Note that the argument to -file will be substituted relative to the
+directory containing this file.
-You can set VERBOSE either interactively (after the defs file has been
-read in), or you can change the default value in "defs".
-Selecting tests for execution:
-------------------------------
+Selecting tests for execution within a file:
+--------------------------------------------
Normally, all the tests in a file are run whenever the file is
-"source"d. However, you can select a specific set of tests using
-the global variable TESTS. This variable contains a pattern; any
-test whose identifier matches TESTS will be run. For example,
-the following interactive command causes all of the "for" tests in
-groups 2 and 4 to be executed:
+sourced. Each test will be skipped if it doesn't match (using glob
+sytle matching) any element in the ::test::matchingTests variable, if
+it matches (using glob sytle matching) an element in
+::test::skippingTests, or if one of the elements of "constraints"
+turns out not to be true.
- set TESTS {for-[24]*}
+You can set ::test::matchingTests and/or ::test::skippingTests either
+interactively (after the defs.tcl file has been sourced), or by the
+command line arguments -match and -skip, for example:
+
+ tcltest socket.test -match "*2.* *4.*" -skip "*2.33*"
+
+The three constraints: notIfCompiled, knownBug, and nonPortable can be
+overridden either interactively (after the defs.tcl file has been
+sourced) by setting the ::test::testConfig(<constraint>) variable, or
+by using the -constraints command line option with the name of the
+constraint in the argument. The following example shows how to run
+tests that are constrained by the knownBug and nonPortable
+restricions:
+
+ tcltest all.tcl -constraints "knownBug nonPortable"
+
+See the defs.tcl file for information about each of these constraints.
+Other constraints can be added at any time. See the "Writing a new
+test" section below for more details about using built-in constraints
+and adding new ones.
+
+Adding a New Test File:
+-----------------------
+
+If the file matches the tests/*.test pattern (as it should), then it
+will automatically be run by the all.tcl file. Make sure your test
+file can be run from any working dir. Running the following should
+work the same from any cwd:
+
+ tcltest <Tcl8.1>/tests/all.tcl
+
+Make sure no temporary files are left behind by your test file. Your
+test file should call "::test::cleanupTests" before returning. The
+::test::cleanupTests procedure prints statistics about the number of
+tests that passed, skipped, and failed, and removes all files the were
+created using the ::test::makeFile and ::test::makeDirectory
+procedures.
+
+Be sure your tests can run cross-platform in both the build
+environment as well as the installation environment. If your test
+file contains tests that should not be run in or more of those cases,
+please use the constraints mechanism described in the next section to
+skip those tests.
+
+
+Writing a new test:
+-------------------
+
+The following is the spec for the "test" command:
+
+ test <name> <description> ?<constraint>? <script> <answer>
+
+The <name> field should be:
+
+ <target>-<majorNum>.<minorNum>
+
+For white-box (regression) tests, the target should be the name of the
+c function or Tcl procedure being tested. For black-box tests, the
+target should be the name of the feature being tested. Related tests
+should share a major number.
+
+If your test requires that a file be created on the fly, please use
+the ::test::makeFile procedure. If your test requires that a small
+file (<50 lines) be checked in, please consider creating the file on
+the fly using the ::test::makeFile procedure. Files created by the
+::test::makeFile procedure will automatically be removed by the
+::test::cleanupTests call at the end of each test file.
+
+Add appropriate constraints (e.g., unixOnly) to any tests that should
+not always be run. For example, a test that should only be run on
+Unix should look like the following:
+
+ test getAttribute-1.1 {testing file permissions} {unixOnly} {
+ lindex [file attributes foo.tcl] 5
+ } {00644}
+
+See the defs.tcl file for a list of built-in flags. You can add any
+constraints that you need. The following is how the defs.tcl file
+adds the "unixOnly" constraint:
+
+ set ::test::testConfig(unixOnly) [expr {$tcl_platform(platform) == "unix"}]
-TESTS defaults to *, but you can change the default in "defs" if
-you wish.
Saving keystrokes:
------------------
-A convenience procedure named "dotests" is included in file
-"defs". It takes two arguments--the name of the test file (such
+A convenience procedure named "::test::dotests" is included in file
+"defs.tcl". It takes two arguments--the name of the test file (such
as "parse.test"), and a pattern selecting the tests you want to
-execute. It sets TESTS to the second argument, calls "source" on
-the file specified in the first argument, and restores TESTS to
-its pre-call value at the end.
+execute. It sets ::test::matching to the second argument, calls
+"source" on the file specified in the first argument, and restores
+::test::matching to its pre-call value at the end.
+
+
+Incompatibilities with prior Tcl versions:
+------------------------------------------
+
+1) Global variables such as VERBOSE, TESTS, and testConfig are now
+ renamed to use the new "test" namespace.
-Batch vs. interactive execution:
---------------------------------
+ old name new name
+ -------- --------
+ VERBOSE ::test::verbose
+ TESTS ::test::matchingTests
+ testConfig ::test::testConfig
-The tests can be run in either batch or interactive mode. Batch
-mode refers to using I/O redirection from a UNIX shell. For example,
-the following command causes the tests in the file named "parse.test"
-to be executed:
+ The introduction of the "test" namespace is a precursor to using a
+ "test" package. This next step will be part of a future Tcl
+ version.
- tclTest < parse.test > parse.test.results
+2) VERBOSE values are no longer numeric. Please see the section above
+ on "Test output" for the new usage of the ::test::verbose variable.
-Users who want to execute the tests in this fashion need to first
-ensure that the file "defs" has proper values for the global
-variables that control the testing environment (VERBOSE and TESTS).
+3) When you run "make test", the working dir for the test suite is now
+ the one from which you called "make test", rather than the
+ <tcl8.1>/tests directory. This change allows for both unix and
+ windows test suites to be run simultaneously without interference.
+ All tests must now run independently of their working directory.
+ You can also control the working directory from the tcltest command
+ line with the -tmpdir option.
diff --git a/tests/all.tcl b/tests/all.tcl
new file mode 100644
index 0000000..2db3b75
--- /dev/null
+++ b/tests/all.tcl
@@ -0,0 +1,61 @@
+# all.tcl --
+#
+# This file contains a top-level script to run all of the Tcl
+# tests. Execute it by invoking "source all.test" when running tcltest
+# in this directory.
+#
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+#
+# RCS: @(#) $Id: all.tcl,v 1.1.2.1 1999/03/11 18:49:22 hershey Exp $
+
+if {[lsearch ::test [namespace children]] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
+puts stdout "Tcl 8.1 tests running in interp: [info nameofexecutable]"
+puts stdout "Tests running in working dir: $::test::tmpDir"
+if {[llength $::test::skippingTests] > 0} {
+ puts stdout "Skipping tests that match: $::test::skippingTests"
+}
+if {[llength $::test::matchingTests] > 0} {
+ puts stdout "Only running tests that match: $::test::matchingTests"
+}
+
+# Use command line specified glob pattern (specified by -file or -f)
+# if one exists. Otherwise use *.test (or *.tes on win32s). If given,
+# the file pattern should be specified relative to the dir containing
+# this file. If no files are found to match the pattern, print an
+# error message and exit.
+set fileIndex [expr {[lsearch $argv "-file"] + 1}]
+set fIndex [expr {[lsearch $argv "-f"] + 1}]
+if {($fileIndex < 1) || ($fIndex > $fileIndex)} {
+ set fileIndex $fIndex
+}
+if {$fileIndex > 0} {
+ set globPattern [file join $::test::testsDir [lindex $argv $fileIndex]]
+ puts stdout "Sourcing files that match: $globPattern"
+} elseif {$tcl_platform(os) == "Win32s"} {
+ set [file join $::test::testsDir globPattern *.tes]
+} else {
+ set [file join $::test::testsDir globPattern *.test]
+}
+set fileList [glob -nocomplain $globPattern]
+if {[llength $fileList] < 1} {
+ puts "Error: no files found matching $globPattern"
+ exit
+}
+
+set timeCmd {clock format [clock seconds]}
+puts stdout "Tests began at [eval $timeCmd]"
+foreach file [lsort $fileList] {
+ set tail [file tail $file]
+ if {[string match l.*.test $tail]} {
+ # This is an SCCS lockfile; ignore it
+ continue
+ }
+ puts stdout $tail
+ if {[catch {source $file} msg]} {
+ puts stdout $msg
+ }
+}
+puts stdout "\nTests ended at [eval $timeCmd]"
diff --git a/tests/append.test b/tests/append.test
index d25e141..94fa8f3 100644
--- a/tests/append.test
+++ b/tests/append.test
@@ -6,14 +6,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: append.test,v 1.1.2.2 1998/09/24 23:59:19 stanton Exp $
-
-if {[info procs test] != "test"} {source defs}
+# RCS: @(#) $Id: append.test,v 1.1.2.3 1999/03/11 18:49:23 hershey Exp $
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
catch {unset x}
test append-1.1 {append command} {
@@ -175,4 +177,7 @@ catch {unset i x result y}
catch {rename foo ""}
catch {rename check ""}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/assocd.test b/tests/assocd.test
index 839c11f..50b1ec4 100644
--- a/tests/assocd.test
+++ b/tests/assocd.test
@@ -6,13 +6,12 @@
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: assocd.test,v 1.1.2.2 1998/09/24 23:59:19 stanton Exp $
-
-if {[string compare test [info procs test]] == 1} then {source defs}
+# RCS: @(#) $Id: assocd.test,v 1.1.2.3 1999/03/11 18:49:23 hershey Exp $
if {[string compare testsetassocdata [info commands testsetassocdata]] != 0} {
puts "This application hasn't been compiled with the tests for assocData,"
@@ -20,6 +19,10 @@ if {[string compare testsetassocdata [info commands testsetassocdata]] != 0} {
return
}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
+
test assocd-1.1 {testing setting assoc data} {
testsetassocdata a 1
} ""
@@ -56,4 +59,7 @@ test assocd-3.3 {testing deleting assoc data} {
list [catch {testdelassocdata nonexistent} msg] $msg
} {0 {}}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/async.test b/tests/async.test
index 1b3ef90..709c669 100644
--- a/tests/async.test
+++ b/tests/async.test
@@ -6,11 +6,12 @@
#
# Copyright (c) 1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: async.test,v 1.1.2.2 1998/09/24 23:59:19 stanton Exp $
+# RCS: @(#) $Id: async.test,v 1.1.2.3 1999/03/11 18:49:23 hershey Exp $
if {[info commands testasync] == {}} {
puts "This application hasn't been compiled with the \"testasync\""
@@ -18,7 +19,9 @@ if {[info commands testasync] == {}} {
return
}
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
proc async1 {result code} {
global aresult acode
@@ -128,5 +131,8 @@ test async-3.1 {deleting handlers} {
list [catch {testasync mark $hm2 "foobar" 5} msg] $msg $x
} {3 del2 {0 0 0 del1 del2}}
+# cleanup
testasync delete
+::test::cleanupTests
return
+
diff --git a/tests/autoMkindex.test b/tests/autoMkindex.test
index 50a654f..345bac3 100644
--- a/tests/autoMkindex.test
+++ b/tests/autoMkindex.test
@@ -4,13 +4,23 @@
# the autoloading index.
#
# Copyright (c) 1998 Lucent Technologies, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: autoMkindex.test,v 1.1.2.2 1998/11/11 04:08:28 stanton Exp $
+# RCS: @(#) $Id: autoMkindex.test,v 1.1.2.3 1999/03/11 18:49:24 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
+
+# temporarily copy the autoMkindex.tcl file from testsDir to tmpDir
+set origMkindexFile [file join $::test::testsDir autoMkindex.tcl]
+set newMkindexFile [file join $::test::tmpDir autoMkindex.tcl]
+if {![catch {file copy $origMkindexFile $newMkindexFile}]} {
+ set removeAutoMkindex 1
+}
test autoMkindex-1.1 {remove any existing tclIndex file} {
file delete tclIndex
@@ -54,8 +64,10 @@ test autoMkindex-2.1 {commands on the autoload path can be imported} {
set final
} "0 {} pub_one ::buried::pub_one pub_two ::buried::pub_two"
-#
-# Clean up.
-#
+# cleanup
+if {[info exists removeAutoMkindex]} {
+ catch {file delete $newMkindexFile}
+}
+catch {file delete -force tclIndex}
+::test::cleanupTests
-catch {file delete tclIndex}
diff --git a/tests/basic.test b/tests/basic.test
index a339768..11087a4 100644
--- a/tests/basic.test
+++ b/tests/basic.test
@@ -10,14 +10,17 @@
# errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: basic.test,v 1.1.2.2 1998/09/24 23:59:20 stanton Exp $
+# RCS: @(#) $Id: basic.test,v 1.1.2.3 1999/03/11 18:49:24 hershey Exp $
#
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
catch {namespace delete test_ns_basic}
catch {interp delete test_interp}
@@ -517,6 +520,7 @@ test basic-45.1 {Tcl_SetRecursionLimit: see interp.test} {
test basic-46.1 {Tcl_AllowExceptions} {
} {}
+# cleanup
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {namespace delete george}
catch {interp delete test_interp}
@@ -525,5 +529,6 @@ catch {rename q ""}
catch {rename cmd ""}
catch {rename value:at: ""}
catch {unset x}
-
+::test::cleanupTests
return
+
diff --git a/tests/binary.test b/tests/binary.test
index f978147..1c6da83 100644
--- a/tests/binary.test
+++ b/tests/binary.test
@@ -5,13 +5,16 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: binary.test,v 1.1.2.2 1998/09/24 23:59:20 stanton Exp $
+# RCS: @(#) $Id: binary.test,v 1.1.2.3 1999/03/11 18:49:25 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test binary-1.1 {Tcl_BinaryObjCmd: bad args} {
list [catch {binary} msg] $msg
@@ -1442,4 +1445,7 @@ test binary-41.8 {ScanNumber: word alignment} {nonPortable pcOnly} {
list [binary scan \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f c1d1 arg1 arg2] $arg1 $arg2
} {2 1 1.6}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/case.test b/tests/case.test
index 4eb3624..f1b5f8f 100644
--- a/tests/case.test
+++ b/tests/case.test
@@ -6,13 +6,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: case.test,v 1.1.2.2 1998/09/24 23:59:20 stanton Exp $
+# RCS: @(#) $Id: case.test,v 1.1.2.3 1999/03/11 18:49:25 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test case-1.1 {simple pattern} {
case a in a {format 1} b {format 2} c {format 3} default {format 4}
@@ -82,4 +85,7 @@ test case-3.3 {single-argument form for pattern/command pairs} {
list [catch {case z in {a 2 b}} msg] $msg
} {1 {extra case pattern with no body}}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/clock.test b/tests/clock.test
index 0a5e1ca..04956ee 100644
--- a/tests/clock.test
+++ b/tests/clock.test
@@ -5,13 +5,16 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995-1998 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: clock.test,v 1.1.2.2 1998/09/24 23:59:20 stanton Exp $
+# RCS: @(#) $Id: clock.test,v 1.1.2.3 1999/03/11 18:49:26 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test clock-1.1 {clock tests} {
list [catch {clock} msg] $msg
@@ -205,4 +208,7 @@ test clock-6.11 {clock roll over dates} {
clock format $time -format %j -gmt true
} {060}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/cmdAH.test b/tests/cmdAH.test
index 7a8e8e4..bef3620 100644
--- a/tests/cmdAH.test
+++ b/tests/cmdAH.test
@@ -10,9 +10,11 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: cmdAH.test,v 1.1.2.6 1999/02/10 23:31:22 stanton Exp $
+# RCS: @(#) $Id: cmdAH.test,v 1.1.2.7 1999/03/11 18:49:26 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
global env
set cmdAHwd [pwd]
@@ -1455,6 +1457,7 @@ test cmdAH-30.8 {error conditions} {
list [catch {file dirname ~woohgy} msg] $msg
} {1 {user "woohgy" doesn't exist}}
+# cleanup
catch {testsetplatform $platform}
catch {unset platform}
@@ -1465,5 +1468,7 @@ file delete link.file
cd $cmdAHwd
+::test::cleanupTests
return
+
diff --git a/tests/cmdIL.test b/tests/cmdIL.test
index 3b38f84..005a29e 100644
--- a/tests/cmdIL.test
+++ b/tests/cmdIL.test
@@ -3,14 +3,16 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
-# Copyright (c) 1998 by Scriptics Corporation.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: cmdIL.test,v 1.1.2.3 1998/11/11 04:08:28 stanton Exp $
+# RCS: @(#) $Id: cmdIL.test,v 1.1.2.4 1999/03/11 18:49:27 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test cmdIL-1.1 {Tcl_LsortObjCmd procedure} {
list [catch {lsort} msg] $msg
@@ -256,15 +258,15 @@ test cmdIL-4.23 {DictionaryCompare procedure, case} {
lsort -dictionary {ABcd AbCd}
} {ABcd AbCd}
test cmdIL-4.24 {DictionaryCompare procedure, international characters} {hasIsoLocale} {
- set_iso8859_1_locale
+ ::test::set_iso8859_1_locale
set result [lsort -dictionary "a b c A B C \xe3 \xc4"]
- restore_locale
+ ::test::restore_locale
set result
} "A a B b C c \xe3 \xc4"
test cmdIL-4.25 {DictionaryCompare procedure, international characters} {hasIsoLocale} {
- set_iso8859_1_locale
+ ::test::set_iso8859_1_locale
set result [lsort -dictionary "a23\xe3 a23\xc5 a23\xe4"]
- restore_locale
+ ::test::restore_locale
set result
} "a23\xe3 a23\xe4 a23\xc5"
test cmdIL-4.26 {DefaultCompare procedure, signed characters} {
@@ -305,4 +307,8 @@ test cmdIL-4.27 {DictionaryCompare procedure, signed characters} {
}
set viewlist
} [list "abc" "abc\\200"]
+
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/cmdInfo.test b/tests/cmdInfo.test
index ffc9c61..62cbb5a 100644
--- a/tests/cmdInfo.test
+++ b/tests/cmdInfo.test
@@ -8,11 +8,12 @@
#
# Copyright (c) 1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: cmdInfo.test,v 1.1.2.2 1998/09/24 23:59:21 stanton Exp $
+# RCS: @(#) $Id: cmdInfo.test,v 1.1.2.3 1999/03/11 18:49:27 hershey Exp $
if {[info commands testcmdinfo] == {}} {
puts "This application hasn't been compiled with the \"testcmdinfo\""
@@ -20,7 +21,9 @@ if {[info commands testcmdinfo] == {}} {
return
}
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test cmdinfo-1.1 {command procedure and clientData} {
testcmdinfo create x1
@@ -93,7 +96,9 @@ test cmdinfo-6.1 {Names for commands created when outside namespaces} {
eval lappend y [testcmdtoken name $x]
} {testCmd ::cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2 ::newTestCmd2}
+# cleanup
catch {namespace delete cmdInfoNs1::cmdInfoNs2 cmdInfoNs1}
catch {rename x1 ""}
-
+::test::cleanupTests
return
+
diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test
index 6559ce6..4a67321 100644
--- a/tests/cmdMZ.test
+++ b/tests/cmdMZ.test
@@ -6,13 +6,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) cmdMZ.test 1.20 98/01/08 18:23:43
+# RCS: @(#) $Id: cmdMZ.test,v 1.1.2.3 1999/03/11 18:49:28 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
# Tcl_PwdObjCmd
@@ -560,5 +563,8 @@ test cmdMZ-20.12 {Tcl_StringObjCmd: string wordstart, unicode} {
# The tests for Tcl_TraceObjCmd and TraceVarProc are in trace.test
# The tests for Tcl_WhileObjCmd are in while.test
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test
index 848a59e..f201982 100644
--- a/tests/compExpr-old.test
+++ b/tests/compExpr-old.test
@@ -7,13 +7,16 @@
# output for errors. No output means no errors were found.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) compExpr-old.test 1.47 97/12/19 11:57:15
+# RCS: @(#) $Id: compExpr-old.test,v 1.1.2.2 1999/03/11 18:49:28 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
set gotT1 0
@@ -666,5 +669,8 @@ test expr-19.1 {expr and interpreter result object resetting} {
p
} 3
+# cleanup
unset a
+::test::cleanupTests
return
+
diff --git a/tests/compExpr.test b/tests/compExpr.test
index ec07592..d7960a4 100644
--- a/tests/compExpr.test
+++ b/tests/compExpr.test
@@ -3,13 +3,16 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) compExpr.test 1.1 97/12/09 18:23:41
+# RCS: @(#) $Id: compExpr.test,v 1.1.2.2 1999/03/11 18:49:29 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
set gotT1 0
@@ -318,6 +321,9 @@ test compExpr-6.1 {LogSyntaxError procedure, error in expr longer than 60 chars}
list [catch {expr {(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)/} -1 foo 3} msg] $msg
} {1 {syntax error in expression "(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+012"}}
+# cleanup
catch {unset a}
catch {unset b}
-concat {}
+::test::cleanupTests
+return
+
diff --git a/tests/compile.test b/tests/compile.test
index 537fdac..822cac8 100644
--- a/tests/compile.test
+++ b/tests/compile.test
@@ -10,9 +10,11 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: compile.test,v 1.1.2.3 1999/02/10 23:31:23 stanton Exp $
+# RCS: @(#) $Id: compile.test,v 1.1.2.4 1999/03/11 18:49:29 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
# The following tests are very incomplete, although the rest of the
# test suite covers this file fairly well.
@@ -189,11 +191,13 @@ test compile-10.1 {BLACKBOX: exception stack overflow} {
+# cleanup
catch {rename p ""}
catch {namespace delete test_ns_compile}
catch {unset x}
catch {unset y}
catch {unset a}
-
+::test::cleanupTests
return
+
diff --git a/tests/concat.test b/tests/concat.test
index 60ce0b3..d94267f 100644
--- a/tests/concat.test
+++ b/tests/concat.test
@@ -6,13 +6,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: concat.test,v 1.1.2.2 1998/09/24 23:59:21 stanton Exp $
+# RCS: @(#) $Id: concat.test,v 1.1.2.3 1999/03/11 18:49:29 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test concat-1.1 {simple concatenation} {
concat a b c d e f g
@@ -45,4 +48,7 @@ test concat-4.3 {pruning off extra white space sets length correctly} {
llength [concat { {{a}} }]
} 1
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/dcall.test b/tests/dcall.test
index 91dd757..cd16728 100644
--- a/tests/dcall.test
+++ b/tests/dcall.test
@@ -6,11 +6,12 @@
#
# Copyright (c) 1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: dcall.test,v 1.1.2.2 1998/09/24 23:59:22 stanton Exp $
+# RCS: @(#) $Id: dcall.test,v 1.1.2.3 1999/03/11 18:49:30 hershey Exp $
if {[info commands testdcall] == {}} {
puts "This application hasn't been compiled with the \"testdcall\""
@@ -18,7 +19,9 @@ if {[info commands testdcall] == {}} {
return
}
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test dcall-1.1 {deletion callbacks} {
lsort -increasing [testdcall 1 2 3]
@@ -39,4 +42,7 @@ test dcall-1.6 {deletion callbacks} {
lsort -increasing [testdcall 20 21 22 -21 -22 -20]
} {}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/defs b/tests/defs
deleted file mode 100644
index ca63089..0000000
--- a/tests/defs
+++ /dev/null
@@ -1,597 +0,0 @@
-# This file contains support code for the Tcl test suite. It is
-# normally sourced by the individual files in the test suite before
-# they run their tests. This improved approach to testing was designed
-# and initially implemented by Mary Ann May-Pumphrey of Sun Microsystems.
-#
-# Copyright (c) 1990-1994 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998 by Scriptics Corporation
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: defs,v 1.1.2.6 1998/12/11 21:44:59 stanton Exp $
-
-if {![info exists VERBOSE]} {
- set VERBOSE 0
-}
-if {![info exists TESTS]} {
- set TESTS {}
-}
-
-# Ensure that we have a minimal auto_path so we don't pick up extra
-# junk.
-
-set auto_path [list [info library]]
-
-# If there is no "memory" command (because memory debugging isn't
-# enabled), generate a dummy command that does nothing.
-
-if {[info commands memory] == ""} {
- proc memory args {}
-}
-
-# Check configuration information that will determine which tests
-# to run. To do this, create an array testConfig. Each element
-# has a 0 or 1 value, and the following elements are defined:
-# unixOnly - 1 means this is a UNIX platform, so it's OK
-# to run tests that only work under UNIX.
-# macOnly - 1 means this is a Mac platform, so it's OK
-# to run tests that only work on Macs.
-# pcOnly - 1 means this is a PC platform, so it's OK to
-# run tests that only work on PCs.
-# unixOrPc - 1 means this is a UNIX or PC platform.
-# macOrPc - 1 means this is a Mac or PC platform.
-# macOrUnix - 1 means this is a Mac or UNIX platform.
-# nonPortable - 1 means this the tests are being running in
-# the master Tcl/Tk development environment;
-# Some tests are inherently non-portable because
-# they depend on things like word length, file system
-# configuration, window manager, etc. These tests
-# are only run in the main Tcl development directory
-# where the configuration is well known. The presence
-# of the file "doAllTests" in this directory indicates
-# that it is safe to run non-portable tests.
-# knownBug - The test is known to fail and the bug is not yet
-# fixed. The test will be run only if the file
-# "doBuggyTests" exists (intended for Tcl dev. group
-# internal use only).
-# tempNotPc - The inverse of pcOnly. This flag is used to
-# temporarily disable a test.
-# tempNotMac - The inverse of macOnly. This flag is used to
-# temporarily disable a test.
-# nonBlockFiles - 1 means this platform supports setting files into
-# nonblocking mode.
-# asyncPipeClose- 1 means this platform supports async flush and
-# async close on a pipe.
-# unixExecs - 1 means this machine has commands such as 'cat',
-# 'echo' etc available.
-# notIfCompiled - 1 means this that it is safe to run tests that
-# might fail if the bytecode compiler is used. This
-# element is set 1 if the file "doAllTests" exists in
-# this directory. Normally, this element is 0 so that
-# tests that fail with the bytecode compiler are
-# skipped. As of 11/2/96 these are the history tests
-# since they depend on accurate source location
-# information.
-# hasIsoLocale - 1 means the tests that need to switch to an iso
-# locale can be run.
-#
-
-catch {unset testConfig}
-
-# The following trace procedure makes it so that we can safely refer to
-# non-existent members of the testConfig array without causing an error.
-# Instead, reading a non-existent member will return 0. This is necessary
-# because tests are allowed to use constraint "X" without ensuring that
-# testConfig("X") is defined.
-
-trace variable testConfig r safeFetch
-
-proc safeFetch {n1 n2 op} {
- global testConfig
-
- if {($n2 != {}) && ([info exists testConfig($n2)] == 0)} {
- set testConfig($n2) 0
- }
-}
-
-# Some of the tests don't work on some system configurations due to
-# differences in word length, file system configuration, etc. In order
-# to prevent false alarms, these tests are generally only run in the
-# master development directory for Tcl. The presence of a file
-# "doAllTests" in this directory is used to indicate that the non-portable
-# tests should be run.
-
-set testConfig(nonPortable) [file exists doAllTests]
-set testConfig(notIfCompiled) [file exists doAllCompilerTests]
-set testConfig(knownBug) [file exists doBuggyTests]
-
-if {$testConfig(nonPortable) == 0} {
- puts "(will skip non-portable tests)"
-}
-
-set testConfig(unixOnly) [expr {$tcl_platform(platform) == "unix"}]
-set testConfig(macOnly) [expr {$tcl_platform(platform) == "macintosh"}]
-set testConfig(pcOnly) [expr {$tcl_platform(platform) == "windows"}]
-
-set testConfig(unix) $testConfig(unixOnly)
-set testConfig(mac) $testConfig(macOnly)
-set testConfig(pc) $testConfig(pcOnly)
-
-set testConfig(unixOrPc) [expr {$testConfig(unix) || $testConfig(pc)}]
-set testConfig(macOrPc) [expr {$testConfig(mac) || $testConfig(pc)}]
-set testConfig(macOrUnix) [expr {$testConfig(mac) || $testConfig(unix)}]
-
-set testConfig(nt) [expr {$tcl_platform(os) == "Windows NT"}]
-set testConfig(95) [expr {$tcl_platform(os) == "Windows 95"}]
-set testConfig(win32s) [expr {$tcl_platform(os) == "Win32s"}]
-
-# The following config 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.
-
-set testConfig(tempNotPc) [expr !$testConfig(pc)]
-set testConfig(tempNotMac) [expr !$testConfig(mac)]
-set testConfig(tempNotUnix) [expr !$testConfig(unix)]
-
-# The following config switches are used to mark tests that crash on
-# certain platforms, so that they can be reactivated again when the
-# underlying problem is fixed.
-
-set testConfig(pcCrash) [expr !$testConfig(pc)]
-set testConfig(macCrash) [expr !$testConfig(mac)]
-set testConfig(unixCrash) [expr !$testConfig(unix)]
-
-if {[catch {set f [open defs r]}]} {
- set testConfig(nonBlockFiles) 1
-} else {
- if {[catch {fconfigure $f -blocking off}] == 0} {
- set testConfig(nonBlockFiles) 1
- } else {
- set testConfig(nonBlockFiles) 0
- }
- close $f
-}
-
-# If tests are being run as root, issue a warning message and set a
-# variable to prevent some tests from running at all.
-
-set user {}
-if {$tcl_platform(platform) == "unix"} {
- catch {set user [exec whoami]}
- if {$user == ""} {
- catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
- }
- if {$user == ""} {set user root}
- if {$user == "root"} {
- puts stdout "Warning: you're executing as root. I'll have to"
- puts stdout "skip some of the tests, since they'll fail as root."
- set testConfig(root) 1
- }
-}
-
-# Test for SCO Unix - cannot run async flushing tests because a potential
-# problem with select is apparently interfering. (Mark Diekhans).
-
-if {$tcl_platform(platform) == "unix"} {
- if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} {
- set testConfig(asyncPipeClose) 0
- } else {
- set testConfig(asyncPipeClose) 1
- }
-} else {
- set testConfig(asyncPipeClose) 1
-}
-
-# Test to see if we have a broken version of sprintf with respect to the
-# "e" format of floating-point numbers.
-
-set testConfig(eformat) 1
-if {[string compare "[format %g 5e-5]" "5e-05"] != 0} {
- set testConfig(eformat) 0
- puts stdout "(will skip tests that depend on the \"e\" format of floating-point numbers)"
-}
-
-# Test to see if execed commands such as cat, echo, rm and so forth are
-# present on this machine.
-
-set testConfig(unixExecs) 1
-if {$tcl_platform(platform) == "macintosh"} {
- set testConfig(unixExecs) 0
-}
-if {($testConfig(unixExecs) == 1) && ($tcl_platform(platform) == "windows")} {
- if {[catch {exec cat defs}] == 1} {
- set testConfig(unixExecs) 0
- }
- if {($testConfig(unixExecs) == 1) && ([catch {exec echo hello}] == 1)} {
- set testConfig(unixExecs) 0
- }
- if {($testConfig(unixExecs) == 1) && \
- ([catch {exec sh -c echo hello}] == 1)} {
- set testConfig(unixExecs) 0
- }
- if {($testConfig(unixExecs) == 1) && ([catch {exec wc defs}] == 1)} {
- set testConfig(unixExecs) 0
- }
- if {$testConfig(unixExecs) == 1} {
- exec echo hello > removeMe
- if {[catch {exec rm removeMe}] == 1} {
- set testConfig(unixExecs) 0
- }
- }
- if {($testConfig(unixExecs) == 1) && ([catch {exec sleep 1}] == 1)} {
- set testConfig(unixExecs) 0
- }
- if {($testConfig(unixExecs) == 1) && \
- ([catch {exec fgrep unixExecs defs}] == 1)} {
- set testConfig(unixExecs) 0
- }
- if {($testConfig(unixExecs) == 1) && ([catch {exec ps}] == 1)} {
- set testConfig(unixExecs) 0
- }
- if {($testConfig(unixExecs) == 1) && \
- ([catch {exec echo abc > removeMe}] == 0) && \
- ([catch {exec chmod 644 removeMe}] == 1) && \
- ([catch {exec rm removeMe}] == 0)} {
- set testConfig(unixExecs) 0
- } else {
- catch {exec rm -f removeMe}
- }
- if {($testConfig(unixExecs) == 1) && \
- ([catch {exec mkdir removeMe}] == 1)} {
- set testConfig(unixExecs) 0
- } else {
- catch {exec rm -r removeMe}
- }
- if {$testConfig(unixExecs) == 0} {
- puts "(will skip tests that depend on Unix-style executables)"
- }
-}
-
-proc print_verbose {name description constraints script code answer} {
- puts stdout "\n"
- if {[string length $constraints]} {
- puts stdout "==== $name $description\t--- ($constraints) ---"
- } else {
- puts stdout "==== $name $description"
- }
- puts stdout "==== Contents of test case:"
- puts stdout "$script"
- if {$code != 0} {
- if {$code == 1} {
- puts stdout "==== Test generated error:"
- puts stdout $answer
- } elseif {$code == 2} {
- puts stdout "==== Test generated return exception; result was:"
- puts stdout $answer
- } elseif {$code == 3} {
- puts stdout "==== Test generated break exception"
- } elseif {$code == 4} {
- puts stdout "==== Test generated continue exception"
- } else {
- puts stdout "==== Test generated exception $code; message was:"
- puts stdout $answer
- }
- } else {
- puts stdout "==== Result was:"
- puts stdout "$answer"
- }
-}
-
-# test --
-# This procedure runs a test and prints an error message if the
-# test fails. If VERBOSE has been set, it also prints a message
-# even if the test succeeds. The test will be skipped if it
-# doesn't match the TESTS variable, or if one of the elements
-# of "constraints" turns out not to be true.
-#
-# Arguments:
-# name - Name of test, in the form foo-1.2.
-# description - Short textual description of the test, to
-# help humans understand what it does.
-# constraints - A list of one or more keywords, each of
-# which must be the name of an element in
-# the array "testConfig". If any of these
-# elements is zero, the test is skipped.
-# This argument may be omitted.
-# script - Script to run to carry out the test. It must
-# return a result that can be checked for
-# correctness.
-# answer - Expected result from script.
-
-proc test {name description script answer args} {
- global VERBOSE TESTS testConfig
-
- if {[string compare $TESTS ""] != 0} {
- set ok 0
- foreach test $TESTS {
- if {[string match $test $name]} {
- set ok 1
- break
- }
- }
- if {!$ok} {
- return
- }
- }
- set i [llength $args]
- if {$i == 0} {
- set constraints {}
- } elseif {$i == 1} {
- # "constraints" argument exists; shuffle arguments down, then
- # make sure that the constraints are satisfied.
-
- set constraints $script
- set script $answer
- set answer [lindex $args 0]
- set doTest 0
- if {[string match {*[$\[]*} $constraints] != 0} {
- # full expression, e.g. {$foo > [info tclversion]}
-
- catch {set doTest [uplevel #0 expr [list $constraints]]} msg
- } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} {
- # something like {a || b} should be turned into
- # $testConfig(a) || $testConfig(b).
-
- regsub -all {[.a-zA-Z0-9]+} $constraints {$testConfig(&)} c
- catch {set doTest [eval expr $c]}
- } else {
- # just simple constraints such as {unixOnly fonts}.
-
- set doTest 1
- foreach constraint $constraints {
- if {![info exists testConfig($constraint)]
- || !$testConfig($constraint)} {
- set doTest 0
- break
- }
- }
- }
- if {$doTest == 0} {
- if {$VERBOSE} {
- puts stdout "++++ $name SKIPPED: $constraints"
- }
- return
- }
- } else {
- error "wrong # args: must be \"test name description ?constraints? script answer\""
- }
- memory tag $name
- set open [openfiles]
- set code [catch {uplevel $script} result]
- if {[leakfiles $open] != ""} {
- puts "\n"
- puts "==== $name $description"
- puts "==== Test leaking open files:"
- puts [leakfiles $open]
- }
- if {$code != 0} {
- print_verbose $name $description $constraints $script \
- $code $result
- } elseif {[string compare $result $answer] == 0} {
- if {$VERBOSE} {
- if {$VERBOSE > 0} {
- print_verbose $name $description $constraints $script \
- $code $result
- }
- if {$VERBOSE != -2} {
- puts stdout "++++ $name PASSED"
- }
- }
- } else {
- print_verbose $name $description $constraints $script \
- $code $result
- puts stdout "---- Result should have been:"
- puts stdout "$answer"
- puts stdout "---- $name FAILED"
- }
-}
-
-proc dotests {file args} {
- global TESTS
- set savedTests $TESTS
- set TESTS $args
- source $file
- set TESTS $savedTests
-}
-
-proc openfiles {} {
- if {[catch {testchannel open} result]} {
- return {}
- }
- return $result
-}
-
-proc leakfiles {old} {
- if {[catch {testchannel open} new]} {
- return {}
- }
- set leak {}
- foreach p $new {
- if {[lsearch $old $p] < 0} {
- lappend leak $p
- }
- }
- return $leak
-}
-
-set saveState {}
-
-proc saveState {} {
- uplevel #0 {set ::saveState [list [info procs] [info vars]]}
-}
-
-proc restoreState {} {
- foreach p [info procs] {
- if {[lsearch [lindex $::saveState 0] $p] < 0} {
- rename $p {}
- }
- }
- foreach p [uplevel #0 {info vars}] {
- if {[lsearch [lindex $::saveState 1] $p] < 0} {
- uplevel #0 "unset $p"
- }
- }
-}
-
-proc normalizeMsg {msg} {
- regsub "\n$" [string tolower $msg] "" msg
- regsub -all "\n\n" $msg "\n" msg
- regsub -all "\n\}" $msg "\}" msg
- return $msg
-}
-
-proc makeFile {contents name} {
- set fd [open $name w]
- fconfigure $fd -translation lf
- if {[string index $contents [expr {[string length $contents] - 1}]] == "\n"} {
- puts -nonewline $fd $contents
- } else {
- puts $fd $contents
- }
- close $fd
-}
-
-proc removeFile {name} {
- file delete $name
-}
-
-proc makeDirectory {name} {
- file mkdir $name
-}
-
-proc removeDirectory {name} {
- file delete -force $name
-}
-
-proc viewFile {name} {
- global tcl_platform testConfig
- if {($tcl_platform(platform) == "macintosh") || \
- ($testConfig(unixExecs) == 0)} {
- set f [open $name]
- set data [read -nonewline $f]
- close $f
- return $data
- } else {
- exec cat $name
- }
-}
-
-#
-# Construct a string that consists of the requested sequence of bytes,
-# as opposed to a string of properly formed UTF-8 characters.
-# This allows the tester to
-# 1. Create denormalized or improperly formed strings to pass to C procedures
-# that are supposed to accept strings with embedded NULL bytes.
-# 2. Confirm that a string result has a certain pattern of bytes, for instance
-# to confirm that "\xe0\0" in a Tcl script is stored internally in
-# UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80".
-#
-# Generally, it's a bad idea to examine the bytes in a Tcl string or to
-# construct improperly formed strings in this manner, because it involves
-# exposing that Tcl uses UTF-8 internally.
-
-proc bytestring {string} {
- encoding convertfrom identity $string
-}
-
-# Locate tcltest executable
-
-set tcltest [info nameofexecutable]
-
-if {$tcltest == "{}"} {
- set tcltest {}
- puts stdout "Unable to find tcltest executable, multiple process tests will fail."
-}
-
-set testConfig(stdio) 0
-if {$tcl_platform(os) != "Win32s"} {
- # Don't even try running another copy of tcltest under win32s, or you
- # get an error dialog about multiple instances.
-
- catch {
- file delete -force tmp
- set f [open tmp w]
- puts $f {
- exit
- }
- close $f
- set f [open "|[list $tcltest tmp]" r]
- close $f
- set testConfig(stdio) 1
- }
- catch {file delete -force tmp}
-}
-
-if {($tcl_platform(platform) == "windows") && ($testConfig(stdio) == 0)} {
- puts stdout "(will skip tests that redirect stdio of exec'd 32-bit applications)"
-}
-
-catch {socket} msg
-set testConfig(socket) [expr {$msg != "sockets are not available on this system"}]
-
-if {$testConfig(socket) == 0} {
- puts stdout "(will skip tests that use sockets)"
-}
-
-#
-# Internationalization / ISO support procs -- dl
-#
-if {[info commands testlocale]==""} {
- # No testlocale command, no tests...
- # (it could be that we are a sub interp and we could just load
- # the Tcltest package but that would interfere with tests
- # that tests packages/loading in slaves...)
- set testConfig(hasIsoLocale) 0
-} else {
- proc set_iso8859_1_locale {} {
- global previousLocale isoLocale
- set previousLocale [testlocale ctype]
- testlocale ctype $isoLocale
- }
-
- proc restore_locale {} {
- global previousLocale
- testlocale ctype $previousLocale
- }
-
- if {![info exists isoLocale]} {
- set isoLocale fr
- switch $tcl_platform(platform) {
- "unix" {
- # Try some 'known' values for some platforms:
- switch -exact -- $tcl_platform(os) {
- "FreeBSD" {
- set isoLocale fr_FR.ISO_8859-1
- }
- HP-UX {
- set isoLocale fr_FR.iso88591
- }
- Linux -
- IRIX {
- set isoLocale fr
- }
- default {
- # Works on SunOS 4 and Solaris, and maybe others...
- # define it to something else on your system
- #if you want to test those.
- set isoLocale iso_8859_1
- }
- }
- }
- "windows" {
- set isoLocale French
- }
- }
- }
-
- set testConfig(hasIsoLocale) [string length [set_iso8859_1_locale]]
- restore_locale
-
- if {$testConfig(hasIsoLocale) == 0} {
- puts "(will skip tests that need to set an iso8859-1 locale)"
- }
-
-}
-
diff --git a/tests/defs.tcl b/tests/defs.tcl
new file mode 100644
index 0000000..4d8af11
--- /dev/null
+++ b/tests/defs.tcl
@@ -0,0 +1,810 @@
+# defs.tcl --
+#
+# This file contains support code for the Tcl test suite.It is
+# It is normally sourced by the individual files in the test suite
+# before they run their tests. This improved approach to testing
+# was designed and initially implemented by Mary Ann May-Pumphrey
+# of Sun Microsystems.
+#
+# Copyright (c) 1990-1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+#
+# RCS: @(#) $Id: defs.tcl,v 1.1.2.1 1999/03/11 18:49:31 hershey Exp $
+
+# Ensure that we have a minimal auto_path so we don't pick up extra junk.
+set auto_path [list [info library]]
+
+# create the "test" namespace for all testing variables and procedures
+namespace eval test {
+ foreach proc [list test cleanupTests dotests saveState restoreState \
+ normalizeMsg makeFile removeFile makeDirectory removeDirectory \
+ viewFile safeFetch bytestring set_iso8859_1_locale restore_locale \
+ setTmpDir] {
+ namespace export $proc
+ }
+
+ # ::test::verbose defaults to "b"
+ variable verbose "b"
+
+ # matchingTests defaults to the empty list
+ variable matchingTests {}
+
+ # skippingTests defaults to the empty list
+ variable skippingTests {}
+
+ # Tests should not rely on the current working directory.
+ # Files that are part of the test suite should be accessed relative to
+ # ::test::testsDir.
+
+ set originalDir [pwd]
+ set tDir [file join $originalDir [file dirname [info script]]]
+ cd $tDir
+ variable testsDir [pwd]
+ cd $originalDir
+
+ # Tests should remove all files they create. The test suite will
+ # check tmpDir for files created by the tests. ::test::filesMade
+ # keeps track of such files created using the test::makeFile and
+ # test::makeDirectory procedures. ::test::filesExisted stores
+ # the names of pre-existing files.
+
+ variable filesMade {}
+ variable filesExisted {}
+
+ # initialize ::test::numTests array to keep track fo the number of
+ # tests that pass, fial, and are skipped.
+ array set numTests [list Total 0 Passed 0 Skipped 0 Failed 0]
+ #array set originalEnv [array get env]
+
+}
+
+# If there is no "memory" command (because memory debugging isn't
+# enabled), generate a dummy command that does nothing.
+
+if {[info commands memory] == ""} {
+ proc memory args {}
+}
+
+# ::test::setTmpDir --
+#
+# Set the ::test::tmpDir to the specified value. If the path
+# is relative, make it absolute. If the file exists but is not
+# a dir, then return an error. If the dir does not already
+# exist, create it. If you cannot create it, then return an error.
+#
+# Arguments:
+# value the new value of ::test::tmpDir
+#
+# Results:
+# ::test::tmpDir is set to <value> and created if it didn't already
+# exist. The working dir is changed to ::test::tmpDir.
+
+proc ::test::setTmpDir {value} {
+
+ set ::test::tmpDir $value
+
+ if {[string compare [file pathtype $::test::tmpDir] absolute] != 0} {
+ set ::test::tmpDir [file join [pwd] $::test::tmpDir]
+ }
+ if {[file exists $::test::tmpDir]} {
+ if {![file isdir $::test::tmpDir]} {
+ puts stderr "Error: bad argument \"$value\" to -tmpdir:"
+ puts stderr " \"$::test::tmpDir\""
+ puts stderr " is not a directory"
+ exit
+ }
+ } else {
+ file mkdir $::test::tmpDir
+ }
+
+ # change the working dir to tmpDir and add the existing files in
+ # tmpDir to the filesExisted list.
+ cd $::test::tmpDir
+ foreach file [glob -nocomplain [file join [pwd] *]] {
+ lappend ::test::filesExisted $file
+ }
+}
+
+# ::test::processCmdLineArgs --
+#
+# Use command line args to set the tmpDir, verbose, skippingTests, and
+# matchingTests variables.
+#
+# Arguments:
+# none
+#
+# Results:
+# ::test::verbose is set to <value>
+
+proc ::test::processCmdLineArgs {} {
+ global argv
+
+ # The "argv" var doesn't exist in some cases, so use {}
+ # The "argv" var doesn't exist in some cases.
+ if {(![info exists argv]) || ([llength $argv] < 2)} {
+ set flagArray {}
+ } else {
+ set flagArray $argv
+ }
+
+ if {[catch {array set flag $flagArray}]} {
+ puts stderr "Error: odd number of command line args specified:"
+ puts stderr " $argv"
+ exit
+ }
+
+ # Allow for 1-char abbreviations, where applicable (e.g., -tmpdir == -t).
+ foreach arg {-verbose -match -skip -constraints -tmpdir} {
+ set abbrev [string range $arg 0 1]
+ if {([info exists flag($abbrev)]) && \
+ ([lsearch $flagArray $arg] < [lsearch $flagArray $abbrev])} {
+ set flag($arg) $flag($abbrev)
+ }
+ }
+
+ # Set ::test::tmpDir to the arg of the -tmpdir flag, if given.
+ # ::test::tmpDir defaults to [pwd].
+ # Save the names of files that already exist in ::test::tmpDir.
+ if {[info exists flag(-tmpdir)]} {
+ ::test::setTmpDir $flag(-tmpdir)
+ } else {
+ set ::test::tmpDir [pwd]
+ }
+ foreach file [glob -nocomplain [file join $::test::tmpDir *]] {
+ lappend ::test::filesExisted [file tail $file]
+ }
+
+ # Set ::test::verbose to the arg of the -verbose flag, if given
+ if {[info exists flag(-verbose)]} {
+ set ::test::verbose $flag(-verbose)
+ }
+
+ # Set ::test::matchingTests to the arg of the -match flag, if given
+ if {[info exists flag(-match)]} {
+ set ::test::matchingTests $flag(-match)
+ }
+
+ # Set ::test::skippingTests to the arg of the -skip flag, if given
+ if {[info exists flag(-skip)]} {
+ set ::test::skippingTests $flag(-skip)
+ }
+
+ # Use the -constraints flag, if given, so turn on the following
+ # constraints: notIfCompiled, knownBug, nonPortable
+ if {[info exists flag(-constraints)]} {
+ set constrList $flag(-constraints)
+ } else {
+ set constrList {}
+ }
+ foreach elt [list notIfCompiled knownBug nonPortable] {
+ set ::test::testConfig($elt) [expr {[lsearch $constrList $elt] != -1}]
+ }
+ if {$::test::testConfig(nonPortable) == 0} {
+ puts "(will skip non-portable tests)"
+ }
+}
+test::processCmdLineArgs
+
+
+# Check configuration information that will determine which tests
+# to run. To do this, create an array ::test::testConfig. Each element
+# has a 0 or 1 value, and the following elements are defined:
+# unixOnly - 1 means this is a UNIX platform, so it's OK
+# to run tests that only work under UNIX.
+# macOnly - 1 means this is a Mac platform, so it's OK
+# to run tests that only work on Macs.
+# pcOnly - 1 means this is a PC platform, so it's OK to
+# run tests that only work on PCs.
+# unixOrPc - 1 means this is a UNIX or PC platform.
+# macOrPc - 1 means this is a Mac or PC platform.
+# macOrUnix - 1 means this is a Mac or UNIX platform.
+# notIfCompiled - 1 means this that it is safe to run tests that
+# might fail if the bytecode compiler is used. This
+# element is set to 1 if the -allComp flag was used.
+# Normally, this element is 0 so that tests that
+# fail with the bytecode compiler are skipped.
+# As of 11/2/96 these are the history tests since
+# they depend on accurate source location information.
+# You can run these tests by using the -constraint
+# command line option with "knownBug" in the argument
+# list.
+# knownBug - The test is known to fail and the bug is not yet
+# fixed. The test will be run only if the flag
+# -allBuggy is used (intended for Tcl dev. group
+# internal use only). You can run these tests by
+# using the -constraint command line option with
+# "knownBug" in the argument list.
+# nonPortable - 1 means this the tests are being running in
+# the master Tcl/Tk development environment;
+# Some tests are inherently non-portable because
+# they depend on things like word length, file system
+# configuration, window manager, etc. These tests
+# are only run in the main Tcl development directory
+# where the configuration is well known. You can
+# run these tests by using the -constraint command
+# line option with "nonPortable" in the argument list.
+# tempNotPc - The inverse of pcOnly. This flag is used to
+# temporarily disable a test.
+# tempNotMac - The inverse of macOnly. This flag is used to
+# temporarily disable a test.
+# nonBlockFiles - 1 means this platform supports setting files into
+# nonblocking mode.
+# asyncPipeClose- 1 means this platform supports async flush and
+# async close on a pipe.
+# unixExecs - 1 means this machine has commands such as 'cat',
+# 'echo' etc available.
+# hasIsoLocale - 1 means the tests that need to switch to an iso
+# locale can be run.
+#
+
+catch {unset ::test::testConfig}
+
+# The following trace procedure makes it so that we can safely refer to
+# non-existent members of the ::test::testConfig array without causing an
+# error. Instead, reading a non-existent member will return 0. This is
+# necessary because tests are allowed to use constraint "X" without ensuring
+# that ::test::testConfig("X") is defined.
+
+trace variable ::test::testConfig r ::test::safeFetch
+
+proc ::test::safeFetch {n1 n2 op} {
+ if {($n2 != {}) && ([info exists ::test::testConfig($n2)] == 0)} {
+ set ::test::testConfig($n2) 0
+ }
+}
+
+set ::test::testConfig(unixOnly) [expr {$tcl_platform(platform) == "unix"}]
+set ::test::testConfig(macOnly) [expr {$tcl_platform(platform) == "macintosh"}]
+set ::test::testConfig(pcOnly) [expr {$tcl_platform(platform) == "windows"}]
+
+set ::test::testConfig(unix) $::test::testConfig(unixOnly)
+set ::test::testConfig(mac) $::test::testConfig(macOnly)
+set ::test::testConfig(pc) $::test::testConfig(pcOnly)
+
+set ::test::testConfig(unixOrPc) [expr {$::test::testConfig(unix) || $::test::testConfig(pc)}]
+set ::test::testConfig(macOrPc) [expr {$::test::testConfig(mac) || $::test::testConfig(pc)}]
+set ::test::testConfig(macOrUnix) [expr {$::test::testConfig(mac) || $::test::testConfig(unix)}]
+
+set ::test::testConfig(nt) [expr {$tcl_platform(os) == "Windows NT"}]
+set ::test::testConfig(95) [expr {$tcl_platform(os) == "Windows 95"}]
+set ::test::testConfig(win32s) [expr {$tcl_platform(os) == "Win32s"}]
+
+# The following config 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.
+
+set ::test::testConfig(tempNotPc) [expr {!$::test::testConfig(pc)}]
+set ::test::testConfig(tempNotMac) [expr {!$::test::testConfig(mac)}]
+set ::test::testConfig(tempNotUnix) [expr {!$::test::testConfig(unix)}]
+
+# The following config switches are used to mark tests that crash on
+# certain platforms, so that they can be reactivated again when the
+# underlying problem is fixed.
+
+set ::test::testConfig(pcCrash) [expr {!$::test::testConfig(pc)}]
+set ::test::testConfig(macCrash) [expr {!$::test::testConfig(mac)}]
+set ::test::testConfig(unixCrash) [expr {!$::test::testConfig(unix)}]
+
+if {[catch {set f [open defs r]}]} {
+ set ::test::testConfig(nonBlockFiles) 1
+} else {
+ if {[catch {fconfigure $f -blocking off}] == 0} {
+ set ::test::testConfig(nonBlockFiles) 1
+ } else {
+ set ::test::testConfig(nonBlockFiles) 0
+ }
+ close $f
+}
+
+# If tests are being run as root, issue a warning message and set a
+# variable to prevent some tests from running at all.
+
+set user {}
+if {$tcl_platform(platform) == "unix"} {
+ catch {set user [exec whoami]}
+ if {$user == ""} {
+ catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
+ }
+ if {$user == ""} {set user root}
+ if {$user == "root"} {
+ puts stdout "Warning: you're executing as root. I'll have to"
+ puts stdout "skip some of the tests, since they'll fail as root."
+ set ::test::testConfig(root) 1
+ }
+}
+
+# Test for SCO Unix - cannot run async flushing tests because a potential
+# problem with select is apparently interfering. (Mark Diekhans).
+
+if {$tcl_platform(platform) == "unix"} {
+ if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} {
+ set ::test::testConfig(asyncPipeClose) 0
+ } else {
+ set ::test::testConfig(asyncPipeClose) 1
+ }
+} else {
+ set ::test::testConfig(asyncPipeClose) 1
+}
+
+# Test to see if we have a broken version of sprintf with respect to the
+# "e" format of floating-point numbers.
+
+set ::test::testConfig(eformat) 1
+if {[string compare "[format %g 5e-5]" "5e-05"] != 0} {
+ set ::test::testConfig(eformat) 0
+ puts stdout "(will skip tests that depend on the \"e\" format of floating-point numbers)"
+}
+
+# Test to see if execed commands such as cat, echo, rm and so forth are
+# present on this machine.
+
+set ::test::testConfig(unixExecs) 1
+if {$tcl_platform(platform) == "macintosh"} {
+ set ::test::testConfig(unixExecs) 0
+}
+if {($::test::testConfig(unixExecs) == 1) && ($tcl_platform(platform) == "windows")} {
+ if {[catch {exec cat defs}] == 1} {
+ set ::test::testConfig(unixExecs) 0
+ }
+ if {($::test::testConfig(unixExecs) == 1) && ([catch {exec echo hello}] == 1)} {
+ set ::test::testConfig(unixExecs) 0
+ }
+ if {($::test::testConfig(unixExecs) == 1) && \
+ ([catch {exec sh -c echo hello}] == 1)} {
+ set ::test::testConfig(unixExecs) 0
+ }
+ if {($::test::testConfig(unixExecs) == 1) && ([catch {exec wc defs}] == 1)} {
+ set ::test::testConfig(unixExecs) 0
+ }
+ if {$::test::testConfig(unixExecs) == 1} {
+ exec echo hello > removeMe
+ if {[catch {exec rm removeMe}] == 1} {
+ set ::test::testConfig(unixExecs) 0
+ }
+ }
+ if {($::test::testConfig(unixExecs) == 1) && ([catch {exec sleep 1}] == 1)} {
+ set ::test::testConfig(unixExecs) 0
+ }
+ if {($::test::testConfig(unixExecs) == 1) && \
+ ([catch {exec fgrep unixExecs defs}] == 1)} {
+ set ::test::testConfig(unixExecs) 0
+ }
+ if {($::test::testConfig(unixExecs) == 1) && ([catch {exec ps}] == 1)} {
+ set ::test::testConfig(unixExecs) 0
+ }
+ if {($::test::testConfig(unixExecs) == 1) && \
+ ([catch {exec echo abc > removeMe}] == 0) && \
+ ([catch {exec chmod 644 removeMe}] == 1) && \
+ ([catch {exec rm removeMe}] == 0)} {
+ set ::test::testConfig(unixExecs) 0
+ } else {
+ catch {exec rm -f removeMe}
+ }
+ if {($::test::testConfig(unixExecs) == 1) && \
+ ([catch {exec mkdir removeMe}] == 1)} {
+ set ::test::testConfig(unixExecs) 0
+ } else {
+ catch {exec rm -r removeMe}
+ }
+ if {$::test::testConfig(unixExecs) == 0} {
+ puts "(will skip tests that depend on Unix-style executables)"
+ }
+}
+
+# ::test::cleanupTests --
+#
+# Print the number tests (total, passed, failed, and skipped) since the
+# last time this procedure was invoked.
+#
+# Remove files and dirs created using the makeFile and makeDirectory
+# commands since the last time this proc was invoked.
+#
+# Print the names of the files created without the makeFile command
+# since the last time this proc was invoked.
+#
+
+proc ::test::cleanupTests {} {
+ # print stats
+ puts -nonewline stdout "[file tail [info script]]:"
+ foreach index [list "Total" "Passed" "Skipped" "Failed"] {
+ puts -nonewline stdout "\t$index\t$::test::numTests($index)"
+ }
+ puts stdout ""
+
+ # remove files and directories created by the tests
+ foreach file $::test::filesMade {
+ if {[file exists $file]} {
+ catch {file delete -force $file}
+ }
+ }
+
+ # report the names of files in ::test::tmpDir that were not pre-existing.
+ set currentFiles {}
+ foreach file [glob -nocomplain [file join $::test::tmpDir *]] {
+ lappend currentFiles [file tail $file]
+ }
+ set filesNew {}
+ foreach file $currentFiles {
+ if {[lsearch $::test::filesExisted $file] == -1} {
+ lappend filesNew $file
+ }
+ }
+ if {[llength $filesNew] > 0} {
+ puts stdout "\t\tFiles created:\t$filesNew"
+ }
+
+ # reset filesMade, filesExisted, and numTests
+ foreach index [list "Total" "Passed" "Skipped" "Failed"] {
+ set ::test::numTests($index) 0
+ }
+ set ::test::filesMade {}
+ set ::test::filesExisted $currentFiles
+}
+
+
+# test --
+#
+# This procedure runs a test and prints an error message if the test fails.
+# If ::test::verbose has been set, it also prints a message even if the
+# test succeeds. The test will be skipped if it doesn't match the
+# ::test::matchingTests variable, if it matches an element in
+# ::test::skippingTests, or if one of the elements of "constraints" turns
+# out not to be true.
+#
+# Arguments:
+# name - Name of test, in the form foo-1.2.
+# description - Short textual description of the test, to
+# help humans understand what it does.
+# constraints - A list of one or more keywords, each of
+# which must be the name of an element in
+# the array "::test::testConfig". If any of these
+# elements is zero, the test is skipped.
+# This argument may be omitted.
+# script - Script to run to carry out the test. It must
+# return a result that can be checked for
+# correctness.
+# expectedAnswer - Expected result from script.
+
+proc ::test::test {name description script expectedAnswer args} {
+ incr ::test::numTests(Total)
+
+ # skip the test if it's name matches an element of skippingTests
+ foreach pattern $::test::skippingTests {
+ if {[string match $pattern $name]} {
+ incr ::test::numTests(Skipped)
+ return
+ }
+ }
+ # skip the test if it's name doesn't match any element of matchingTests
+ if {[llength $::test::matchingTests] > 0} {
+ set ok 0
+ foreach pattern $::test::matchingTests {
+ if {[string match $pattern $name]} {
+ set ok 1
+ break
+ }
+ }
+ if {!$ok} {
+ incr ::test::numTests(Skipped)
+ return
+ }
+ }
+ set i [llength $args]
+ if {$i == 0} {
+ set constraints {}
+ } elseif {$i == 1} {
+ # "constraints" argument exists; shuffle arguments down, then
+ # make sure that the constraints are satisfied.
+
+ set constraints $script
+ set script $expectedAnswer
+ set expectedAnswer [lindex $args 0]
+ set doTest 0
+ if {[string match {*[$\[]*} $constraints] != 0} {
+ # full expression, e.g. {$foo > [info tclversion]}
+
+ catch {set doTest [uplevel #0 expr $constraints]}
+ } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} {
+ # something like {a || b} should be turned into
+ # $::test::testConfig(a) || $::test::testConfig(b).
+
+ regsub -all {[.a-zA-Z0-9]+} $constraints {$::test::testConfig(&)} c
+ catch {set doTest [eval expr $c]}
+ } else {
+ # just simple constraints such as {unixOnly fonts}.
+
+ set doTest 1
+ foreach constraint $constraints {
+ if {![info exists ::test::testConfig($constraint)]
+ || !$::test::testConfig($constraint)} {
+ set doTest 0
+ break
+ }
+ }
+ }
+ if {$doTest == 0} {
+ incr ::test::numTests(Skipped)
+ if {[string first s $::test::verbose] != -1} {
+ puts stdout "++++ $name SKIPPED: $constraints"
+ }
+ return
+ }
+ } else {
+ error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\""
+ }
+ memory tag $name
+ set code [catch {uplevel $script} actualAnswer]
+ if {$code != 0 || [string compare $actualAnswer $expectedAnswer] != 0} {
+ incr ::test::numTests(Failed)
+ if {[string first b $::test::verbose] == -1} {
+ set script ""
+ }
+ puts stdout "\n==== $name $description FAILED"
+ if {$script != ""} {
+ puts stdout "==== Contents of test case:"
+ puts stdout $script
+ }
+ if {$code != 0} {
+ if {$code == 1} {
+ puts stdout "==== Test generated error:"
+ puts stdout $actualAnswer
+ } elseif {$code == 2} {
+ puts stdout "==== Test generated return exception; result was:"
+ puts stdout $actualAnswer
+ } elseif {$code == 3} {
+ puts stdout "==== Test generated break exception"
+ } elseif {$code == 4} {
+ puts stdout "==== Test generated continue exception"
+ } else {
+ puts stdout "==== Test generated exception $code; message was:"
+ puts stdout $actualAnswer
+ }
+ } else {
+ puts stdout "---- Result was:\n$actualAnswer"
+ }
+ puts stdout "---- Result should have been:\n$expectedAnswer"
+ puts stdout "==== $name FAILED\n"
+ } else {
+ incr ::test::numTests(Passed)
+ if {[string first p $::test::verbose] != -1} {
+ puts stdout "++++ $name PASSED"
+ }
+ }
+}
+
+proc ::test::dotests {file args} {
+ set savedTests $::test::matchingTests
+ set ::test::matchingTests $args
+ source $file
+ set ::test::matchingTests $savedTests
+}
+
+proc ::test::openfiles {} {
+ if {[catch {testchannel open} result]} {
+ return {}
+ }
+ return $result
+}
+
+proc ::test::leakfiles {old} {
+ if {[catch {testchannel open} new]} {
+ return {}
+ }
+ set leak {}
+ foreach p $new {
+ if {[lsearch $old $p] < 0} {
+ lappend leak $p
+ }
+ }
+ return $leak
+}
+
+set ::test::saveState {}
+
+proc ::test::saveState {} {
+ uplevel #0 {set ::test::saveState [list [info procs] [info vars]]}
+}
+
+proc ::test::restoreState {} {
+ foreach p [info procs] {
+ if {[lsearch [lindex $::test::saveState 0] $p] < 0} {
+ rename $p {}
+ }
+ }
+ foreach p [uplevel #0 {info vars}] {
+ if {[lsearch [lindex $::test::saveState 1] $p] < 0} {
+ uplevel #0 "unset $p"
+ }
+ }
+}
+
+proc ::test::normalizeMsg {msg} {
+ regsub "\n$" [string tolower $msg] "" msg
+ regsub -all "\n\n" $msg "\n" msg
+ regsub -all "\n\}" $msg "\}" msg
+ return $msg
+}
+
+# makeFile --
+#
+# Create a new file with the name <name>, and write <contents> to it.
+#
+# If this file hasn't been created via makeFile since the last time
+# cleanupTests was called, add it to the $filesMade list, so it will
+# be removed by the next call to cleanupTests.
+#
+proc ::test::makeFile {contents name} {
+ set fd [open $name w]
+ fconfigure $fd -translation lf
+ if {[string index $contents [expr {[string length $contents] - 1}]] == "\n"} {
+ puts -nonewline $fd $contents
+ } else {
+ puts $fd $contents
+ }
+ close $fd
+
+ set fullName [file join [pwd] $name]
+ if {[lsearch $::test::filesMade $fullName] == -1} {
+ lappend ::test::filesMade $fullName
+ }
+}
+
+proc ::test::removeFile {name} {
+ file delete $name
+}
+
+# makeDirectory --
+#
+# Create a new dir with the name <name>.
+#
+# If this dir hasn't been created via makeDirectory since the last time
+# cleanupTests was called, add it to the $directoriesMade list, so it will
+# be removed by the next call to cleanupTests.
+#
+proc ::test::makeDirectory {name} {
+ file mkdir $name
+
+ set fullName [file join [pwd] $name]
+ if {[lsearch $::test::filesMade $fullName] == -1} {
+ lappend ::test::filesMade $fullName
+ }
+}
+
+proc ::test::removeDirectory {name} {
+ file delete -force $name
+}
+
+proc ::test::viewFile {name} {
+ global tcl_platform
+ if {($tcl_platform(platform) == "macintosh") || \
+ ($::test::testConfig(unixExecs) == 0)} {
+ set f [open $name]
+ set data [read -nonewline $f]
+ close $f
+ return $data
+ } else {
+ exec cat $name
+ }
+}
+
+#
+# Construct a string that consists of the requested sequence of bytes,
+# as opposed to a string of properly formed UTF-8 characters.
+# This allows the tester to
+# 1. Create denormalized or improperly formed strings to pass to C procedures
+# that are supposed to accept strings with embedded NULL bytes.
+# 2. Confirm that a string result has a certain pattern of bytes, for instance
+# to confirm that "\xe0\0" in a Tcl script is stored internally in
+# UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80".
+#
+# Generally, it's a bad idea to examine the bytes in a Tcl string or to
+# construct improperly formed strings in this manner, because it involves
+# exposing that Tcl uses UTF-8 internally.
+
+proc ::test::bytestring {string} {
+ encoding convertfrom identity $string
+}
+
+# Locate tcltest executable
+
+set tcltest [info nameofexecutable]
+
+if {$tcltest == "{}"} {
+ set tcltest {}
+ puts stdout "Unable to find tcltest executable, multiple process tests will fail."
+}
+
+set ::test::testConfig(stdio) 0
+if {$tcl_platform(os) != "Win32s"} {
+ # Don't even try running another copy of tcltest under win32s, or you
+ # get an error dialog about multiple instances.
+
+ catch {
+ file delete -force tmp
+ set f [open tmp w]
+ puts $f {
+ exit
+ }
+ close $f
+ set f [open "|[list $tcltest tmp]" r]
+ close $f
+ set ::test::testConfig(stdio) 1
+ }
+ catch {file delete -force tmp}
+}
+
+if {($tcl_platform(platform) == "windows") && ($::test::testConfig(stdio) == 0)} {
+ puts stdout "(will skip tests that redirect stdio of exec'd 32-bit applications)"
+}
+
+catch {socket} msg
+set ::test::testConfig(socket) [expr {$msg != "sockets are not available on this system"}]
+
+if {$::test::testConfig(socket) == 0} {
+ puts stdout "(will skip tests that use sockets)"
+}
+
+#
+# Internationalization / ISO support procs -- dl
+#
+if {[info commands testlocale]==""} {
+ # No testlocale command, no tests...
+ # (it could be that we are a sub interp and we could just load
+ # the Tcltest package but that would interfere with tests
+ # that tests packages/loading in slaves...)
+ set ::test::testConfig(hasIsoLocale) 0
+} else {
+ proc ::test::set_iso8859_1_locale {} {
+ set ::test::previousLocale [testlocale ctype]
+ testlocale ctype $::test::isoLocale
+ }
+
+ proc ::test::restore_locale {} {
+ testlocale ctype $::test::previousLocale
+ }
+
+ if {![info exists ::test::isoLocale]} {
+ set ::test::isoLocale fr
+ switch $tcl_platform(platform) {
+ "unix" {
+ # Try some 'known' values for some platforms:
+ switch -exact -- $tcl_platform(os) {
+ "FreeBSD" {
+ set ::test::isoLocale fr_FR.ISO_8859-1
+ }
+ HP-UX {
+ set ::test::isoLocale fr_FR.iso88591
+ }
+ Linux -
+ IRIX {
+ set ::test::isoLocale fr
+ }
+ default {
+ # Works on SunOS 4 and Solaris, and maybe others...
+ # define it to something else on your system
+ #if you want to test those.
+ set ::test::isoLocale iso_8859_1
+ }
+ }
+ }
+ "windows" {
+ set ::test::isoLocale French
+ }
+ }
+ }
+
+ set ::test::testConfig(hasIsoLocale) \
+ [string length [::test::set_iso8859_1_locale]]
+ ::test::restore_locale
+
+ if {$::test::testConfig(hasIsoLocale) == 0} {
+ puts "(will skip tests that need to set an iso8859-1 locale)"
+ }
+
+}
+
+# Need to catch the import because it fails if defs.tcl is sourced
+# more than once.
+catch {namespace import ::test::*}
diff --git a/tests/dstring.test b/tests/dstring.test
index 3c591e2..25d4947 100644
--- a/tests/dstring.test
+++ b/tests/dstring.test
@@ -6,11 +6,12 @@
#
# Copyright (c) 1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: dstring.test,v 1.1.2.2 1998/09/24 23:59:22 stanton Exp $
+# RCS: @(#) $Id: dstring.test,v 1.1.2.3 1999/03/11 18:49:31 hershey Exp $
if {[info commands testdstring] == {}} {
puts "This application hasn't been compiled with the \"testdstring\""
@@ -18,7 +19,9 @@ if {[info commands testdstring] == {}} {
return
}
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test dstring-1.1 {appending and retrieving} {
testdstring free
@@ -245,6 +248,8 @@ test dstring-6.5 {Tcl_DStringGetResult} {
lappend result [testdstring get]
} {{} {This is a specially-allocated stringz}}
+# cleanup
testdstring free
-
+::test::cleanupTests
return
+
diff --git a/tests/encoding.test b/tests/encoding.test
index 70ef976..d200a72 100644
--- a/tests/encoding.test
+++ b/tests/encoding.test
@@ -3,15 +3,15 @@
# errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) encoding.test 1.11 97/12/16 13:03:49
-#
+# RCS: @(#) $Id: encoding.test,v 1.1.2.4 1999/03/11 18:49:32 hershey Exp $
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
proc toutf {args} {
@@ -295,6 +295,9 @@ test encoding-22.1 {EscapeFromUtfProc} {
# EscapeFreeProc, GetTableEncoding, unilen
# are fully tested by the rest of this file
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/env.test b/tests/env.test
index 8b11360..8a450e9 100644
--- a/tests/env.test
+++ b/tests/env.test
@@ -6,13 +6,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: env.test,v 1.1.2.3 1998/10/06 02:59:05 stanton Exp $
+# RCS: @(#) $Id: env.test,v 1.1.2.4 1999/03/11 18:49:32 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
#
# These tests will run on any platform (and indeed crashed
@@ -178,6 +181,8 @@ foreach name [array names env2] {
set env($name) $env2($name)
}
+# cleanup
file delete printenv
-
+::test::cleanupTests
return
+
diff --git a/tests/error.test b/tests/error.test
index 512a15c..7a480de 100644
--- a/tests/error.test
+++ b/tests/error.test
@@ -6,13 +6,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: error.test,v 1.1.2.2 1998/09/24 23:59:22 stanton Exp $
+# RCS: @(#) $Id: error.test,v 1.1.2.3 1999/03/11 18:49:33 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
proc foo {} {
global errorInfo
@@ -171,5 +174,8 @@ test error-6.1 {catch must reset error state} {
list $errorCode $errorInfo
} {NONE 1}
+# cleanup
catch {rename p ""}
+::test::cleanupTests
return
+
diff --git a/tests/eval.test b/tests/eval.test
index d523f85..67a74fa 100644
--- a/tests/eval.test
+++ b/tests/eval.test
@@ -6,13 +6,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: eval.test,v 1.1.2.2 1998/09/24 23:59:23 stanton Exp $
+# RCS: @(#) $Id: eval.test,v 1.1.2.3 1999/03/11 18:49:33 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test eval-1.1 {single argument} {
eval {format 22}
@@ -54,4 +57,7 @@ test eval-2.5 {error in eval'ed command: setting errorInfo} {
error \"test error\"
}\""
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/event.test b/tests/event.test
index a4e9c95..1fcad7f 100644
--- a/tests/event.test
+++ b/tests/event.test
@@ -4,13 +4,16 @@
# output for errors. No output means no errors were found.
#
# Copyright (c) 1995-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: event.test,v 1.1.2.2 1998/09/24 23:59:23 stanton Exp $
+# RCS: @(#) $Id: event.test,v 1.1.2.3 1999/03/11 18:49:34 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
if {[catch {testfilehandler create 0 off off}] == 0 } {
test event-1.1 {Tcl_CreateFileHandler, reading} {
@@ -562,8 +565,10 @@ if {[info commands testfilewait] != ""} {
} {{} readable}
}
+# cleanup
foreach i [after info] {
after cancel $i
}
-
+::test::cleanupTests
return
+
diff --git a/tests/exec.test b/tests/exec.test
index a5095f7..207e7c0 100644
--- a/tests/exec.test
+++ b/tests/exec.test
@@ -6,13 +6,16 @@
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: exec.test,v 1.1.2.2 1998/09/24 23:59:23 stanton Exp $
+# RCS: @(#) $Id: exec.test,v 1.1.2.3 1999/03/11 18:49:34 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
# If exec is not defined just return with no error
# Some platforms like the Macintosh do not have the exec command
@@ -20,7 +23,7 @@ if {[info commands exec] == ""} {
puts "exec not implemented for this machine"
return
}
-if {$testConfig(stdio) == 0} {
+if {$::test::testConfig(stdio) == 0} {
return
}
@@ -569,8 +572,10 @@ test exec-17.1 { inheriting standard I/O } {
} {{foobar
}}
+# cleanup
file delete script gorp.file gorp.file2
file delete echo cat wc sh sleep exit
file delete err
-
+::test::cleanupTests
return
+
diff --git a/tests/execute.test b/tests/execute.test
index 7459b5b..32ca0fe 100644
--- a/tests/execute.test
+++ b/tests/execute.test
@@ -9,13 +9,16 @@
# errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: execute.test,v 1.1.2.2 1998/09/24 23:59:23 stanton Exp $
+# RCS: @(#) $Id: execute.test,v 1.1.2.3 1999/03/11 18:49:35 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename foo ""}
@@ -103,6 +106,7 @@ test execute-3.1 {UpdateStringOfCmdName: called for duplicate of empty cmdName o
p
} {}
+# cleanup
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename foo ""}
catch {rename p ""}
@@ -111,4 +115,6 @@ catch {rename { } ""}
catch {unset x}
catch {unset y}
catch {unset msg}
+::test::cleanupTests
return
+
diff --git a/tests/expr-old.test b/tests/expr-old.test
index 2d0c8a2..d3f80d5 100644
--- a/tests/expr-old.test
+++ b/tests/expr-old.test
@@ -8,13 +8,16 @@
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: expr-old.test,v 1.1.2.2 1998/09/24 23:59:24 stanton Exp $
+# RCS: @(#) $Id: expr-old.test,v 1.1.2.3 1999/03/11 18:49:35 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
set gotT1 0
@@ -928,4 +931,7 @@ if {(4195835.0 - (4195835.0/3145727.0)*3145727.0) == 256.0} {
puts "to request a replacement processor."
}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/expr.test b/tests/expr.test
index d20c78f..7d022f0 100644
--- a/tests/expr.test
+++ b/tests/expr.test
@@ -5,13 +5,16 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: expr.test,v 1.1.2.2 1998/11/11 04:54:21 stanton Exp $
+# RCS: @(#) $Id: expr.test,v 1.1.2.3 1999/03/11 18:49:36 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
set gotT1 0
@@ -664,4 +667,8 @@ test expr-19.1 {expr and interpreter result object resetting} {
p
} 3
+# cleanup
unset a
+::test::cleanupTests
+return
+
diff --git a/tests/fCmd.test b/tests/fCmd.test
index 46ae37f..bb72144 100644
--- a/tests/fCmd.test
+++ b/tests/fCmd.test
@@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: fCmd.test,v 1.1.2.4 1998/12/11 00:12:08 stanton Exp $
+# RCS: @(#) $Id: fCmd.test,v 1.1.2.5 1999/03/11 18:49:36 hershey Exp $
#
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -91,35 +91,35 @@ proc contents {file} {
set r
}
-set testConfig(NT) 0
-set testConfig(95) 0
+set ::test::testConfig(NT) 0
+set ::test::testConfig(95) 0
switch $tcl_platform(os) {
- "Windows NT" {set testConfig(NT) 1}
- "Windows 95" {set testConfig(95) 1}
+ "Windows NT" {set ::test::testConfig(NT) 1}
+ "Windows 95" {set ::test::testConfig(95) 1}
}
-set testConfig(fileSharing) 0
-set testConfig(notFileSharing) 1
+set ::test::testConfig(fileSharing) 0
+set ::test::testConfig(notFileSharing) 1
if {$tcl_platform(platform) == "macintosh"} {
catch {file delete -force foo.dir}
file mkdir foo.dir
if {[catch {file attributes foo.dir -readonly 1}] == 0} {
- set testConfig(fileSharing) 1
- set testConfig(notFileSharing) 0
+ set ::test::testConfig(fileSharing) 1
+ set ::test::testConfig(notFileSharing) 0
}
file delete -force foo.dir
}
-set testConfig(xdev) 0
+set ::test::testConfig(xdev) 0
if {$tcl_platform(platform) == "unix"} {
if {[catch {set m1 [exec df .]; set m2 [exec df /tmp]}] == 0} {
set m1 [string range $m1 0 [expr [string first " " $m1]-1]]
set m2 [string range $m2 0 [expr [string first " " $m2]-1]]
if {$m1 != "" && $m2 != "" && $m1 != $m2 && [file exists $m1] && [file exists $m2]} {
- set testConfig(xdev) 1
+ set ::test::testConfig(xdev) 1
}
}
}
@@ -479,7 +479,7 @@ test fCmd-6.16 {CopyRenameOneFile: TclpCopyRenameOneFile fails} {
file mkdir td2
list [catch {file rename -force td2 td1} msg] $msg
} [subst {1 {error renaming "td2" to "[file join td1 td2]": file already exists}}]
-test fCmd-6.17 {CopyRenameOneFile: errno == EINVAL} {!$testConfig(win32s) || ($root == "C:/")} {
+test fCmd-6.17 {CopyRenameOneFile: errno == EINVAL} {!$::test::testConfig(win32s) || ($root == "C:/")} {
# Don't run this test under Win32s on a drive mounted from an NT
# machine; it causes the NT machine to die.
@@ -2077,13 +2077,13 @@ test fCmd-27.4 {TclFileAttrsCmd - getting one option} {
list [catch {eval file attributes foo.tmp [lindex $attrs 0]}] [file delete -force -- foo.tmp]
} {0 {}}
-set testConfig(tclGroup) 0
+set ::test::testConfig(tclGroup) 0
if {($tcl_platform(platform) == "macintosh") \
|| ($tcl_platform(platform) == "windows")} {
- set testConfig(tclGroup) 1
+ set ::test::testConfig(tclGroup) 1
} elseif {[catch {exec {groups}} groupList] == 0} {
if {[lsearch $groupList tcl] != -1} {
- set testConfig(tclGroup) 1
+ set ::test::testConfig(tclGroup) 1
}
}
@@ -2100,5 +2100,8 @@ test fCmd-27.6 {TclFileAttrsCmd - setting more than one option} {tclGroup} {
list [catch {eval file attributes foo.tmp [lrange $attrs 0 3]} msg] $msg [file delete -force -- foo.tmp]
} {0 {} {}}
+# cleanup
cleanup
+::test::cleanupTests
return
+
diff --git a/tests/fileName.test b/tests/fileName.test
index 3ffe4da..2702eb7 100644
--- a/tests/fileName.test
+++ b/tests/fileName.test
@@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: fileName.test,v 1.1.2.2 1998/09/24 23:59:24 stanton Exp $
+# RCS: @(#) $Id: fileName.test,v 1.1.2.3 1999/03/11 18:49:37 hershey Exp $
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -1420,7 +1420,7 @@ if {$tcl_platform(platform) == "windows"} {
removeDirectory globTest
- if {($testConfig(nonPortable) != 0) && [catch {cd //gaspode/d}] == 0} {
+ if {($::test::testConfig(nonPortable) != 0) && [catch {cd //gaspode/d}] == 0} {
removeDirectory globTest
makeDirectory globTest
@@ -1441,9 +1441,11 @@ if {$tcl_platform(platform) == "windows"} {
cd $temp
}
+# cleanup
removeDirectory globTest
set env(HOME) $oldhome
-
testsetplatform $platform
catch {unset oldhome platform temp result}
+::test::cleanupTests
return
+
diff --git a/tests/for-old.test b/tests/for-old.test
index 3367d34..9c6a9be 100644
--- a/tests/for-old.test
+++ b/tests/for-old.test
@@ -12,7 +12,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: for-old.test,v 1.1.2.2 1998/09/24 23:59:25 stanton Exp $
+# RCS: @(#) $Id: for-old.test,v 1.1.2.3 1999/03/11 18:49:38 hershey Exp $
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -65,4 +65,7 @@ test for-old-1.9 {for tests} {
set a
} {1 2 3}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/for.test b/tests/for.test
index ceb70c2..285dbdf 100644
--- a/tests/for.test
+++ b/tests/for.test
@@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: for.test,v 1.1.2.2 1998/09/24 23:59:25 stanton Exp $
+# RCS: @(#) $Id: for.test,v 1.1.2.3 1999/03/11 18:49:38 hershey Exp $
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -713,4 +713,7 @@ test for-5.15 {for cmd with computed command names: for command result} {
set a
} {}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/foreach.test b/tests/foreach.test
index 8032ea1..69036e8 100644
--- a/tests/foreach.test
+++ b/tests/foreach.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: foreach.test,v 1.1.2.2 1998/09/24 23:59:25 stanton Exp $
+# RCS: @(#) $Id: foreach.test,v 1.1.2.3 1999/03/11 18:49:39 hershey Exp $
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -208,7 +208,9 @@ test foreach-5.4 {break tests} {
set msg
} {wrong # args: should be "break"}
+# cleanup
catch {unset a}
catch {unset x}
-
+::test::cleanupTests
return
+
diff --git a/tests/format.test b/tests/format.test
index 1a3e9b8..ced8dff 100644
--- a/tests/format.test
+++ b/tests/format.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: format.test,v 1.1.2.3 1998/11/10 02:40:59 stanton Exp $
+# RCS: @(#) $Id: format.test,v 1.1.2.4 1999/03/11 18:49:39 hershey Exp $
if {[info commands test] != "test"} {
source defs
@@ -478,9 +478,11 @@ for {set i 290} {$i < 400} {incr i} {
append b "x"
}
-
+# cleanup
catch {unset a}
catch {unset b}
catch {unset c}
catch {unset d}
+::test::cleanupTests
return
+
diff --git a/tests/get.test b/tests/get.test
index b198a1f..462b935 100644
--- a/tests/get.test
+++ b/tests/get.test
@@ -5,13 +5,16 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: get.test,v 1.1.2.2 1998/09/24 23:59:25 stanton Exp $
+# RCS: @(#) $Id: get.test,v 1.1.2.3 1999/03/11 18:49:40 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test get-1.1 {Tcl_GetInt procedure} {
set x 44
@@ -90,4 +93,7 @@ test get-2.4 {Tcl_GetInt procedure} {nonPortable} {
list [catch {format %g .000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001} msg] $msg $errorCode
} {1 {floating-point value too small to represent} {ARITH UNDERFLOW {floating-point value too small to represent}}}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/history.test b/tests/history.test
index d878d0a..c7dd335 100644
--- a/tests/history.test
+++ b/tests/history.test
@@ -6,11 +6,12 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: history.test,v 1.1.2.2 1998/09/24 23:59:25 stanton Exp $
+# RCS: @(#) $Id: history.test,v 1.1.2.3 1999/03/11 18:49:40 hershey Exp $
if {[catch {history}]} {
puts stdout "This version of Tcl was built without the history command;\n"
@@ -18,7 +19,9 @@ if {[catch {history}]} {
return
}
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
set num [history nextid]
history keep 3
@@ -209,4 +212,7 @@ test history-9.2 {miscellaneous} {
set msg
} {bad option "gorp": must be add, change, clear, event, info, keep, nextid, or redo}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/http.test b/tests/http.test
index e5afd9a..26478dd 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -6,21 +6,24 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#
-# RCS: @(#) $Id: http.test,v 1.1.2.3 1998/11/11 04:08:28 stanton Exp $
+# RCS: @(#) $Id: http.test,v 1.1.2.4 1999/03/11 18:49:41 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
if {[catch {package require http 2.0}]} {
if {[info exist http2]} {
- catch {puts stderr "Cannot load http 2.0 package"}
+ catch {puts "Cannot load http 2.0 package"}
return
} else {
- catch {puts stderr "Running http 2.0 tests in slave interp"}
+ catch {puts "Running http 2.0 tests in slave interp"}
set interp [interp create http2]
$interp eval [list set http2 "running"]
$interp eval [list source [info script]]
@@ -44,13 +47,13 @@ if {[info commands testthread] == "testthread" && [file exists httpd]} {
puts "Running httpd in thread $httpthread"
} else {
if ![file exists httpd] {
- puts stderr "Cannot read httpd script, http test skipped"
+ puts "Cannot read httpd script, http test skipped"
unset port
return
}
source httpd
if [catch {httpd_init $port} listen] {
- puts stderr "Cannot start http server, http test skipped"
+ puts "Cannot start http server, http test skipped"
unset port
return
}
@@ -285,6 +288,7 @@ test http-6.1 {http::ProxyRequired} {
<h2>GET http://$url</h2>
</body></html>"
+# cleanup
unset url
unset port
if {[info exists httpthread]} {
@@ -294,3 +298,6 @@ if {[info exists httpthread]} {
} else {
close $listen
}
+::test::cleanupTests
+return
+
diff --git a/tests/httpold.test b/tests/httpold.test
index 138574a..6780f6e 100644
--- a/tests/httpold.test
+++ b/tests/httpold.test
@@ -6,21 +6,23 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: httpold.test,v 1.1.2.2 1998/11/11 04:08:28 stanton Exp $
-
-if {[string compare test [info procs test]] == 1} then {source defs}
+# RCS: @(#) $Id: httpold.test,v 1.1.2.3 1999/03/11 18:49:41 hershey Exp $
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
if {[catch {package require http 1.0}]} {
if {[info exist httpold]} {
- catch {puts stderr "Cannot load http 1.0 package"}
+ catch {puts "Cannot load http 1.0 package"}
return
} else {
- catch {puts stderr "Running http 1.0 tests in slave interp"}
+ catch {puts "Running http 1.0 tests in slave interp"}
set interp [interp create httpold]
$interp eval [list set httpold "running"]
$interp eval [list source [info script]]
@@ -36,7 +38,7 @@ proc httpd_init {{port 8015}} {
proc httpd_log {args} {
global httpLog
if {[info exists httpLog] && $httpLog} {
- puts stderr "httpd: [join $args { }]"
+ puts "httpd: [join $args { }]"
}
}
array set httpdErrors {
@@ -179,7 +181,7 @@ proc httpdRespond { sock } {
set port 8010
if [catch {httpd_init $port} listen] {
- puts stderr "Cannot start http server, http test skipped"
+ puts "Cannot start http server, http test skipped"
unset port
return
}
@@ -414,6 +416,10 @@ test http-6.1 {httpProxyRequired} {
<h2>GET http://$url</h2>
</body></html>"
+# cleanup
unset url
unset port
close $listen
+::test::cleanupTests
+return
+
diff --git a/tests/if-old.test b/tests/if-old.test
index 59974cd..ed107b4 100644
--- a/tests/if-old.test
+++ b/tests/if-old.test
@@ -8,13 +8,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: if-old.test,v 1.1.2.2 1998/09/24 23:59:26 stanton Exp $
+# RCS: @(#) $Id: if-old.test,v 1.1.2.3 1999/03/11 18:49:42 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test if-old-1.1 {taking proper branch} {
set a {}
@@ -155,4 +158,7 @@ test if-old-4.11 {error conditions} {
list [catch {if 0 then foo elseif 0 bar else {[error "error in else clause"]}} msg] $msg
} {1 {error in else clause}}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/if.test b/tests/if.test
index a7af9e6..79d0478 100644
--- a/tests/if.test
+++ b/tests/if.test
@@ -5,13 +5,16 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: if.test,v 1.1.2.3 1998/10/06 20:27:21 stanton Exp $
+# RCS: @(#) $Id: if.test,v 1.1.2.4 1999/03/11 18:49:42 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
# Basic "if" operation.
@@ -1006,4 +1009,7 @@ test if-9.1 {if cmd with namespace qualifiers} {
::if {1} {set x 4}
} 4
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/incr-old.test b/tests/incr-old.test
index 570aae7..6b50958 100644
--- a/tests/incr-old.test
+++ b/tests/incr-old.test
@@ -8,13 +8,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: incr-old.test,v 1.1.2.2 1998/09/24 23:59:26 stanton Exp $
+# RCS: @(#) $Id: incr-old.test,v 1.1.2.3 1999/03/11 18:49:43 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
catch {unset x}
@@ -86,4 +89,7 @@ test incr-old-2.10 {incr errors} {
list [catch {incr x 1} msg] $msg
} {1 {expected integer but got "20 x"}}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/incr.test b/tests/incr.test
index fabbd6c..7b225e5 100644
--- a/tests/incr.test
+++ b/tests/incr.test
@@ -5,13 +5,16 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: incr.test,v 1.1.2.2 1998/09/24 23:59:26 stanton Exp $
+# RCS: @(#) $Id: incr.test,v 1.1.2.3 1999/03/11 18:49:43 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
# Basic "incr" operation.
@@ -493,4 +496,7 @@ test incr-2.29 {incr command (not compiled): runtime error, bad variable value}
list [catch {$z x 1} msg] $msg
} {1 {expected integer but got " - "}}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/indexObj.test b/tests/indexObj.test
index f06c0c5..dc18044 100644
--- a/tests/indexObj.test
+++ b/tests/indexObj.test
@@ -3,15 +3,12 @@
# are organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: indexObj.test,v 1.1.2.2 1998/09/24 23:59:26 stanton Exp $
-
-if {[info procs test] != "test"} {
- source defs
-}
+# RCS: @(#) $Id: indexObj.test,v 1.1.2.3 1999/03/11 18:49:44 hershey Exp $
if {[info commands testindexobj] == {}} {
puts "This application hasn't been compiled with the \"testindexobj\""
@@ -19,6 +16,10 @@ if {[info commands testindexobj] == {}} {
return
}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
+
test indexObj-1.1 {exact match} {
testindexobj 1 1 xyz abc def xyz alm
} {2}
@@ -67,4 +68,7 @@ test indexObj-4.1 {free old internal representation} {
testindexobj 1 1 $x abc def {a b} zzz
} {2}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/info.test b/tests/info.test
index d45d44c..f464df6 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -6,13 +6,16 @@
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: info.test,v 1.1.2.2 1998/09/24 23:59:26 stanton Exp $
+# RCS: @(#) $Id: info.test,v 1.1.2.3 1999/03/11 18:49:45 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
# Set up namespaces needed to test operation of "info args", "info body",
# "info default", and "info procs" with imported procedures.
@@ -498,5 +501,8 @@ test info-20.5 {miscellaneous error conditions} {
list [catch {info s} msg] $msg
} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
+# cleanup
catch {namespace delete test_ns_info1 test_ns_info2}
+::test::cleanupTests
return
+
diff --git a/tests/init.test b/tests/init.test
index f2504bd..e19a070 100644
--- a/tests/init.test
+++ b/tests/init.test
@@ -5,14 +5,16 @@
# errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: init.test,v 1.1.2.2 1998/09/24 23:59:27 stanton Exp $
+# RCS: @(#) $Id: init.test,v 1.1.2.3 1999/03/11 18:49:45 hershey Exp $
-
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
# Clear out any namespaces called test_ns_*
catch {eval namespace delete [namespace children :: test_ns_*]}
@@ -58,8 +60,8 @@ test init-1.8 {auto_qualify - multiple colons 2} {
# places where auto_loading occur (before loading the indexes files and after)
set testInterp [interp create]
-interp eval $testInterp [list set VERBOSE $VERBOSE]
-interp eval $testInterp [list set TESTS $TESTS]
+interp eval $testInterp [list set argv $argv]
+interp eval $testInterp [list source [file join $::test::testsDir defs.tcl]]
interp eval $testInterp {
@@ -145,6 +147,8 @@ test init-3.0 {random stuff in the auto_index, should still work} {
}
+# cleanup
interp delete $testInterp
-
+::test::cleanupTests
return
+
diff --git a/tests/interp.test b/tests/interp.test
index 2e372c5..1d01d5a 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -10,9 +10,11 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: interp.test,v 1.1.2.5 1999/02/10 23:31:23 stanton Exp $
+# RCS: @(#) $Id: interp.test,v 1.1.2.6 1999/03/11 18:49:46 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
# The set of hidden commands is platform dependent:
@@ -2327,8 +2329,10 @@ test interp-30.1 {deletion of aliases inside namespaces} {
$i alias ns::cmd {}
} {}
+# cleanup
foreach i [interp slaves] {
interp delete $i
}
-
+::test::cleanupTests
return
+
diff --git a/tests/io.test b/tests/io.test
index dcee6c8..2f643a8 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -7,13 +7,16 @@
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: io.test,v 1.1.2.7 1998/12/10 18:27:07 stanton Exp $
+# RCS: @(#) $Id: io.test,v 1.1.2.8 1999/03/11 18:49:46 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
if {"[info commands testchannel]" != "testchannel"} {
puts "Skipping io tests. This application does not seem to have the"
@@ -21,7 +24,7 @@ if {"[info commands testchannel]" != "testchannel"} {
return
}
-saveState
+::test::saveState
removeFile test1
removeFile pipe
@@ -56,6 +59,8 @@ makeFile {
vwait forever
} cat
+set thisScript [file join $::test::testsDir [info script]]
+
# These tests are disabled until we decide what to do with "unsupported0".
#
#test io-1.1 {unsupported0 command} {
@@ -65,7 +70,7 @@ makeFile {
# unsupported0 $f1 $f2
# close $f1
# catch {close $f2}
-# set s1 [file size [info script]]
+# set s1 [file size $thisScript]
# set s2 [file size test1]
# set x ok
# if {"$s1" != "$s2"} {
@@ -75,7 +80,7 @@ makeFile {
#} ok
#test io-1.2 {unsupported0 command} {
# removeFile test1
-# set f1 [open [info script]]
+# set f1 [open $thisScript]
# set f2 [open test1 w]
# unsupported0 $f1 $f2 40
# close $f1
@@ -84,13 +89,13 @@ makeFile {
#} 40
#test io-1.3 {unsupported0 command} {
# removeFile test1
-# set f1 [open [info script]]
+# set f1 [open $thisScript]
# set f2 [open test1 w]
# unsupported0 $f1 $f2 -1
# close $f1
# close $f2
# set x ok
-# set s1 [file size [info script]]
+# set s1 [file size $thisScript]
# set s2 [file size test1]
# if {$s1 != $s2} {
# set x broken
@@ -103,7 +108,7 @@ makeFile {
# set f1 [open pipe w]
# puts $f1 {puts ready}
# puts $f1 {gets stdin}
-# puts $f1 {set f1 [open [info script] r]}
+# puts $f1 {set f1 [open $thisScript r]}
# puts $f1 {puts [read $f1 100]}
# puts $f1 {close $f1}
# close $f1
@@ -5084,7 +5089,7 @@ test io-40.2 {POSIX open access modes: CREAT} {unixOnly} {
close $f
set x
} {0600 {line 1}}
-test io-40.3 {POSIX open access modes: CREAT} {$testConfig(unix) && ([exec umask] == 2)} {
+test io-40.3 {POSIX open access modes: CREAT} {$::test::testConfig(unix) && ([exec umask] == 2)} {
# This test only works if your umask is 2, like ouster's.
removeFile test3
set f [open test3 {WRONLY CREAT}]
@@ -5282,7 +5287,7 @@ test io-42.3 {Tcl_FileeventCmd: replacing, with NULL chars in script} {
# Test fileevent on a pipe
#
-if {$testConfig(stdio) && $testConfig(unixExecs)} {
+if {$::test::testConfig(stdio) && $::test::testConfig(unixExecs)} {
catch {set f2 [open "|[list cat -u]" r+]}
catch {set f3 [open "|[list cat -u]" r+]}
@@ -5382,7 +5387,7 @@ catch {close $f3}
}
# Closes if {($platform(platform) != "macintosh") && \
- # ($testConfig(unixExecs) == 1)} clause
+ # ($::test::testConfig(unixExecs) == 1)} clause
close $f
makeFile "foo bar" foo
@@ -6295,7 +6300,7 @@ test io-51.1 {Test old socket deletion on Macintosh} {socket} {
test io-52.1 {TclCopyChannel} {
removeFile test1
- set f1 [open [info script]]
+ set f1 [open $thisScript]
set f2 [open test1 w]
fcopy $f1 $f2 -command { # }
catch { fcopy $f1 $f2 } msg
@@ -6305,9 +6310,9 @@ test io-52.1 {TclCopyChannel} {
} {0}
test io-52.2 {TclCopyChannel} {
removeFile test1
- set f1 [open [info script]]
+ set f1 [open $thisScript]
set f2 [open test1 w]
- set f3 [open [info script]]
+ set f3 [open $thisScript]
fcopy $f1 $f2 -command { # }
catch { fcopy $f3 $f2 } msg
close $f1
@@ -6317,7 +6322,7 @@ test io-52.2 {TclCopyChannel} {
} {0}
test io-52.3 {TclCopyChannel} {
removeFile test1
- set f1 [open [info script]]
+ set f1 [open $thisScript]
set f2 [open test1 w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation cr -blocking 0
@@ -6325,7 +6330,7 @@ test io-52.3 {TclCopyChannel} {
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
- set s1 [file size [info script]]
+ set s1 [file size $thisScript]
set s2 [file size test1]
if {("$s1" == "$s2") && ($s0 == $s1)} {
lappend result ok
@@ -6334,7 +6339,7 @@ test io-52.3 {TclCopyChannel} {
} {0 0 ok}
test io-52.4 {TclCopyChannel} {
removeFile test1
- set f1 [open [info script]]
+ set f1 [open $thisScript]
set f2 [open test1 w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation cr -blocking 0
@@ -6346,7 +6351,7 @@ test io-52.4 {TclCopyChannel} {
} {0 0 40}
test io-52.5 {TclCopyChannel} {
removeFile test1
- set f1 [open [info script]]
+ set f1 [open $thisScript]
set f2 [open test1 w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation lf -blocking 0
@@ -6354,7 +6359,7 @@ test io-52.5 {TclCopyChannel} {
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
- set s1 [file size [info script]]
+ set s1 [file size $thisScript]
set s2 [file size test1]
if {"$s1" == "$s2"} {
lappend result ok
@@ -6363,15 +6368,15 @@ test io-52.5 {TclCopyChannel} {
} {0 0 ok}
test io-52.6 {TclCopyChannel} {
removeFile test1
- set f1 [open [info script]]
+ set f1 [open $thisScript]
set f2 [open test1 w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation lf -blocking 0
- set s0 [fcopy $f1 $f2 -size [expr [file size [info script]] + 5]]
+ set s0 [fcopy $f1 $f2 -size [expr [file size $thisScript] + 5]]
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
- set s1 [file size [info script]]
+ set s1 [file size $thisScript]
set s2 [file size test1]
if {("$s1" == "$s2") && ($s0 == $s1)} {
lappend result ok
@@ -6380,13 +6385,13 @@ test io-52.6 {TclCopyChannel} {
} {0 0 ok}
test io-52.7 {TclCopyChannel} {
removeFile test1
- set f1 [open [info script]]
+ set f1 [open $thisScript]
set f2 [open test1 w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation lf -blocking 0
fcopy $f1 $f2
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
- set s1 [file size [info script]]
+ set s1 [file size $thisScript]
set s2 [file size test1]
close $f1
close $f2
@@ -6403,7 +6408,7 @@ test io-52.8 {TclCopyChannel} {stdio} {
puts $f1 {
puts ready
gets stdin
- set f1 [open [info script] r]
+ set f1 [open $thisScript r]
fconfigure $f1 -translation lf
puts [read $f1 100]
close $f1
@@ -6424,7 +6429,7 @@ test io-52.8 {TclCopyChannel} {stdio} {
test io-53.1 {CopyData} {
removeFile test1
- set f1 [open [info script]]
+ set f1 [open $thisScript]
set f2 [open test1 w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation cr -blocking 0
@@ -6436,7 +6441,7 @@ test io-53.1 {CopyData} {
} {0 0 0}
test io-53.2 {CopyData} {
removeFile test1
- set f1 [open [info script]]
+ set f1 [open $thisScript]
set f2 [open test1 w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation cr -blocking 0
@@ -6445,7 +6450,7 @@ test io-53.2 {CopyData} {
vwait s0
close $f1
close $f2
- set s1 [file size [info script]]
+ set s1 [file size $thisScript]
set s2 [file size test1]
if {("$s1" == "$s2") && ($s0 == $s1)} {
lappend result ok
@@ -6534,7 +6539,7 @@ proc FcopyTestDone {bytes {error {}}} {
test io-53.5 {CopyData: error during fcopy} {socket} {
set listen [socket -server FcopyTestAccept 2828]
- set in [open [info script]] ;# 126 K
+ set in [open $thisScript] ;# 126 K
set out [socket 127.0.0.1 2828]
catch {unset fcopyTestDone}
close $listen ;# This means the socket open never really succeeds
@@ -6775,21 +6780,13 @@ test io-58.1 {Tcl_NotifyChannel and error when closing} {unixOrPc} {
list $x $result
} {1 {gets {normal message from pipe} gets {} catch {error message from pipe}}}
-
-removeFile fooBar
-removeFile longfile
-removeFile script
-removeFile output
-removeFile test1
-removeFile pipe
-removeFile my_script
-removeFile foo
-removeFile bar
-removeFile test2
-removeFile test3
-
-file delete cat
-
+# cleanup
+foreach file [list fooBar longfile script output test1 pipe my_script foo \
+ bar test2 test3 cat stdout] {
+ ::test::removeFile $file
+}
restoreState
+::test::cleanupTests
return
+
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index 067133a..0cfd8d4 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -7,13 +7,16 @@
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: ioCmd.test,v 1.1.2.3 1998/12/10 18:27:09 stanton Exp $
+# RCS: @(#) $Id: ioCmd.test,v 1.1.2.4 1999/03/11 18:49:47 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
removeFile test1
removeFile pipe
@@ -501,13 +504,15 @@ test iocmd-15.12 {Tcl_FcopyObjCmd} {
close $rfile
close $wfile
-removeFile test1
-removeFile test2
-removeFile test3
-removeFile test4
+# cleanup
+foreach file [list test1 test2 test3 test4] {
+ ::test::removeFile $file
+}
# delay long enough for background processes to finish
after 500
-removeFile test5
-removeFile pipe
-removeFile output
+foreach file [list test5 pipe output] {
+ ::test::removeFile $file
+}
+::test::cleanupTests
return
+
diff --git a/tests/ioUtil.test b/tests/ioUtil.test
index 8f5801b..60fefac 100644
--- a/tests/ioUtil.test
+++ b/tests/ioUtil.test
@@ -3,14 +3,16 @@
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
-# Copyright (c) 1998 by Scriptics Corporation.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: ioUtil.test,v 1.1.2.3 1998/12/10 18:27:09 stanton Exp $
+# RCS: @(#) $Id: ioUtil.test,v 1.1.2.4 1999/03/11 18:49:48 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
set unsetScript {
catch {unset testStat1(size)}
@@ -298,3 +300,8 @@ test ioUtil-3.8 {TclOpenFileChannelDeleteProc: Verify that all procs have been d
list $err9 $err10 $err11
} {{"TestOpenFileChannelProc1": could not be deleteed} {"TestOpenFileChannelProc2": could not be deleteed} {"TestOpenFileChannelProc3": could not be deleteed}}
}
+
+# cleanup
+::test::cleanupTests
+return
+
diff --git a/tests/join.test b/tests/join.test
index 0553f43..09bf886 100644
--- a/tests/join.test
+++ b/tests/join.test
@@ -6,13 +6,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: join.test,v 1.1.2.2 1998/09/24 23:59:28 stanton Exp $
+# RCS: @(#) $Id: join.test,v 1.1.2.3 1999/03/11 18:49:48 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test join-1.1 {basic join commands} {
join {a b c} xyz
@@ -45,5 +48,7 @@ test join-3.2 {join is binary ok} {
string length [join "a\0b a\0b a\0b"]
} 11
-
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/lindex.test b/tests/lindex.test
index 45d5f70..765e915 100644
--- a/tests/lindex.test
+++ b/tests/lindex.test
@@ -6,13 +6,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: lindex.test,v 1.1.2.2 1998/09/24 23:59:28 stanton Exp $
+# RCS: @(#) $Id: lindex.test,v 1.1.2.3 1999/03/11 18:49:49 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test lindex-1.1 {basic tests} {
lindex {a b c} 0} a
@@ -73,4 +76,7 @@ test lindex-3.4 {quoted elements} {
lindex {a b {c d "e} {f g"}} 2
} {c d "e}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/link.test b/tests/link.test
index df788cd..a9a59a1 100644
--- a/tests/link.test
+++ b/tests/link.test
@@ -6,11 +6,12 @@
#
# Copyright (c) 1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: link.test,v 1.1.2.2 1998/09/24 23:59:28 stanton Exp $
+# RCS: @(#) $Id: link.test,v 1.1.2.3 1999/03/11 18:49:49 hershey Exp $
if {[info commands testlink] == {}} {
puts "This application hasn't been compiled with the \"testlink\""
@@ -18,7 +19,9 @@ if {[info commands testlink] == {}} {
return
}
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
foreach i {int real bool string} {
catch {unset $i}
@@ -234,4 +237,7 @@ foreach i {int real bool string} {
catch {unset $i}
}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/linsert.test b/tests/linsert.test
index 3fe65d4..1d6df44 100644
--- a/tests/linsert.test
+++ b/tests/linsert.test
@@ -6,13 +6,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: linsert.test,v 1.1.2.2 1998/09/24 23:59:28 stanton Exp $
+# RCS: @(#) $Id: linsert.test,v 1.1.2.3 1999/03/11 18:49:50 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
catch {unset lis}
catch {rename p ""}
@@ -101,7 +104,9 @@ test linsert-3.2 {linsert won't modify shared argument objects} {
linsert $lis 0 [string length $lis]
} "7 a b c"
+# cleanup
catch {unset lis}
catch {rename p ""}
-
+::test::cleanupTests
return
+
diff --git a/tests/list.test b/tests/list.test
index 64819fb..d1b9313 100644
--- a/tests/list.test
+++ b/tests/list.test
@@ -6,13 +6,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: list.test,v 1.1.2.2 1998/09/24 23:59:29 stanton Exp $
+# RCS: @(#) $Id: list.test,v 1.1.2.3 1999/03/11 18:49:51 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
# First, a bunch of individual tests
@@ -106,4 +109,7 @@ test list-3.1 {SetListFromAny and lrange/concat results} {
slowsort {fred julie alex carol bill annie}
} {alex annie bill carol fred julie}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/listObj.test b/tests/listObj.test
index e9c3e0c..54a4290 100644
--- a/tests/listObj.test
+++ b/tests/listObj.test
@@ -6,11 +6,12 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: listObj.test,v 1.1.2.2 1998/09/24 23:59:29 stanton Exp $
+# RCS: @(#) $Id: listObj.test,v 1.1.2.3 1999/03/11 18:49:51 hershey Exp $
if {[info commands testobj] == {}} {
puts "This application hasn't been compiled with the \"testobj\""
@@ -18,7 +19,9 @@ if {[info commands testobj] == {}} {
return
}
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
catch {unset x}
test listobj-1.1 {Tcl_GetListObjType} {
@@ -178,4 +181,7 @@ test listobj-9.1 {UpdateStringOfList} {
string length [list foo\x00help]
} 8
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/llength.test b/tests/llength.test
index 27b1197..da5a8df 100644
--- a/tests/llength.test
+++ b/tests/llength.test
@@ -6,13 +6,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: llength.test,v 1.1.2.2 1998/09/24 23:59:29 stanton Exp $
+# RCS: @(#) $Id: llength.test,v 1.1.2.3 1999/03/11 18:49:52 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test llength-1.1 {length of list} {
llength {a b c d}
@@ -34,4 +37,7 @@ test llength-2.3 {error conditions} {
list [catch {llength "a b c \{"} msg] $msg
} {1 {unmatched open brace in list}}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/load.test b/tests/load.test
index 9336f63..e5e77ab 100644
--- a/tests/load.test
+++ b/tests/load.test
@@ -5,13 +5,16 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: load.test,v 1.1.2.3 1998/12/02 20:08:08 welch Exp $
+# RCS: @(#) $Id: load.test,v 1.1.2.4 1999/03/11 18:49:52 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
# Figure out what extension is used for shared libraries on this
# platform.
@@ -163,4 +166,7 @@ if {[info command teststaticpkg] != ""} {
interp delete child
}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/lrange.test b/tests/lrange.test
index b2beb53..4fb4715 100644
--- a/tests/lrange.test
+++ b/tests/lrange.test
@@ -6,13 +6,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: lrange.test,v 1.1.2.2 1998/09/24 23:59:29 stanton Exp $
+# RCS: @(#) $Id: lrange.test,v 1.1.2.3 1999/03/11 18:49:53 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test lrange-1.1 {range of list elements} {
lrange {a b c d} 1 2
@@ -82,4 +85,7 @@ test lrange-2.6 {error conditions} {
list [catch {lrange "a b c \{ d e" 1 4} msg] $msg
} {1 {unmatched open brace in list}}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/lreplace.test b/tests/lreplace.test
index 6fe4a00..6e57f5e 100644
--- a/tests/lreplace.test
+++ b/tests/lreplace.test
@@ -6,13 +6,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: lreplace.test,v 1.1.2.2 1998/09/24 23:59:29 stanton Exp $
+# RCS: @(#) $Id: lreplace.test,v 1.1.2.3 1999/03/11 18:49:54 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test lreplace-1.1 {lreplace command} {
lreplace {1 2 3 4 5} 0 0 a
@@ -128,6 +131,8 @@ test lreplace-3.1 {lreplace won't modify shared argument objects} {
p
} "a b c"
+# cleanup
catch {unset foo}
-
+::test::cleanupTests
return
+
diff --git a/tests/lsearch.test b/tests/lsearch.test
index b081566..a7dfae6 100644
--- a/tests/lsearch.test
+++ b/tests/lsearch.test
@@ -6,13 +6,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: lsearch.test,v 1.1.2.3 1998/12/02 21:46:05 stanton Exp $
+# RCS: @(#) $Id: lsearch.test,v 1.1.2.4 1999/03/11 18:49:54 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
set x {abcd bbcd 123 234 345}
test lsearch-1.1 {lsearch command} {
@@ -85,4 +88,7 @@ test lsearch-4.2 {binary data} {
lsearch -exact [list foo one\000two bar] $x
} 1
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/macFCmd.test b/tests/macFCmd.test
index 5edc69e..8a73df3 100644
--- a/tests/macFCmd.test
+++ b/tests/macFCmd.test
@@ -5,27 +5,31 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: macFCmd.test,v 1.1.2.2 1998/09/24 23:59:29 stanton Exp $
+# RCS: @(#) $Id: macFCmd.test,v 1.1.2.3 1999/03/11 18:49:54 hershey Exp $
#
if {$tcl_platform(platform) != "macintosh"} {
+ puts "skipping: Mac only tests..."
return
}
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
catch {file delete -force foo.dir}
file mkdir foo.dir
if {[catch {file attributes foo.dir -readonly 1}]} {
- set testConfig(fileSharing) 0
- set testConfig(notFileSharing) 1
+ set ::test::testConfig(fileSharing) 0
+ set ::test::testConfig(notFileSharing) 1
} else {
- set testConfig(fileSharing) 1
- set testConfig(notFileSharing) 0
+ set ::test::testConfig(fileSharing) 1
+ set ::test::testConfig(notFileSharing) 0
}
file delete -force foo.dir
@@ -167,4 +171,7 @@ test macFCmd-4.7 {SetFileReadOnly - directory readonly} {notFileSharing} {
list [catch {file attributes foo.dir -readonly 1} msg] $msg [file delete -force foo.dir]
} {1 {cannot set a directory to read-only when File Sharing is turned off} {}}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/misc.test b/tests/misc.test
index d13a28f..fe04e35 100644
--- a/tests/misc.test
+++ b/tests/misc.test
@@ -7,13 +7,16 @@
#
# Copyright (c) 1992-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: misc.test,v 1.1.2.2 1998/09/24 23:59:30 stanton Exp $
+# RCS: @(#) $Id: misc.test,v 1.1.2.3 1999/03/11 18:49:55 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test misc-1.1 {error in variable ref. in command in array reference} {
proc tstProc {} {
@@ -55,4 +58,7 @@ test misc-1.2 {error in variable ref. in command in array reference} {
invoked from within
"tstProc"}}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/msgcat.test b/tests/msgcat.test
index dbffd97..c1663fc 100644
--- a/tests/msgcat.test
+++ b/tests/msgcat.test
@@ -7,21 +7,23 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1998 Mark Harrison.
-# Copyright (c) 1998 by Scriptics Corporation.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: msgcat.test,v 1.1.2.3 1998/12/10 01:40:56 stanton Exp $
+# RCS: @(#) $Id: msgcat.test,v 1.1.2.4 1999/03/11 18:49:55 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
if {[catch {package require msgcat 1.0}]} {
if {[info exist msgcat1]} {
- catch {puts stderr "Cannot load msgcat 1.0 package"}
+ catch {puts "Cannot load msgcat 1.0 package"}
return
} else {
- catch {puts stderr "Running msgcat 1.0 tests in slave interp"}
+ catch {puts "Running msgcat 1.0 tests in slave interp"}
set interp [interp create msgcat1]
$interp eval [list set msgcat1 "running"]
$interp eval [list source [info script]]
@@ -291,16 +293,15 @@ test msgcat-5.9 {::msgcat::mcload} {
set result
} {unknown:no_fi_notexist:abc}
-#
-# Clean up the test files
-#
-
+# cleanup
foreach l $locales {
file delete [string tolower [file join msgdir $l.msg]]
}
# Clean out the msg catalogs
-
-
::msgcat::mclocale $oldlocale
file delete msgdir
+
+::test::cleanupTests
+return
+
diff --git a/tests/namespace-old.test b/tests/namespace-old.test
index cd6a379..9ca00bb 100644
--- a/tests/namespace-old.test
+++ b/tests/namespace-old.test
@@ -9,13 +9,16 @@
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1997 Lucent Technologies
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: namespace-old.test,v 1.1.2.2 1998/09/24 23:59:30 stanton Exp $
+# RCS: @(#) $Id: namespace-old.test,v 1.1.2.3 1999/03/11 18:49:56 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
# Clear out any namespaces called test_ns_*
catch {eval namespace delete [namespace children :: test_ns_*]}
@@ -843,4 +846,7 @@ catch {unset test_ns_var_global}
catch {unset cmd}
eval namespace delete [namespace children :: test_ns_*]
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/namespace.test b/tests/namespace.test
index 2d1f501..a266243 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -6,13 +6,16 @@
# errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: namespace.test,v 1.1.2.2 1998/09/24 23:59:31 stanton Exp $
+# RCS: @(#) $Id: namespace.test,v 1.1.2.3 1999/03/11 18:49:56 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
# Clear out any namespaces called test_ns_*
catch {eval namespace delete [namespace children :: test_ns_*]}
@@ -1090,10 +1093,12 @@ test namespace-38.1 {UpdateStringOfNsName} {
[namespace eval {} {namespace current}]
} {:: ::}
+# cleanup
catch {rename cmd1 {}}
catch {unset l}
catch {unset msg}
catch {unset trigger}
eval namespace delete [namespace children :: test_ns_*]
-
+::test::cleanupTests
return
+
diff --git a/tests/obj.test b/tests/obj.test
index 5557150..ab27703 100644
--- a/tests/obj.test
+++ b/tests/obj.test
@@ -6,11 +6,12 @@
# errors. No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: obj.test,v 1.1.2.2 1998/09/24 23:59:32 stanton Exp $
+# RCS: @(#) $Id: obj.test,v 1.1.2.3 1999/03/11 18:49:57 hershey Exp $
if {[info commands testobj] == {}} {
puts "This application hasn't been compiled with the \"testobj\""
@@ -18,7 +19,9 @@ if {[info commands testobj] == {}} {
return
}
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} {
set r 1
@@ -525,4 +528,7 @@ test obj-30.1 {Ref counting and object deletion, simple types} {
testobj freeallvars
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/opt.test b/tests/opt.test
index e669718..f4045ac 100644
--- a/tests/opt.test
+++ b/tests/opt.test
@@ -6,13 +6,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: opt.test,v 1.1.2.2 1998/09/24 23:59:32 stanton Exp $
+# RCS: @(#) $Id: opt.test,v 1.1.2.3 1999/03/11 18:49:58 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
# the package we are going to test
package require opt 0.4.1
@@ -270,5 +273,7 @@ test opt-11.2 {default value for args} {
set args
} {a b c}
-
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/osa.test b/tests/osa.test
index c2e16bb..4bb054f 100644
--- a/tests/osa.test
+++ b/tests/osa.test
@@ -5,13 +5,12 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: osa.test,v 1.1.2.2 1998/09/24 23:59:32 stanton Exp $
-
-if {[string compare test [info procs test]] == 1} then {source defs}
+# RCS: @(#) $Id: osa.test,v 1.1.2.3 1999/03/11 18:49:58 hershey Exp $
# This command only runs on the Macintosh, only run the test if we
# can load the command
@@ -24,6 +23,10 @@ if {[info commands AppleScript] == ""} {
return
}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
+
test osa-1.1 {Tcl_OSAComponentCmd} {
list [catch AppleScript msg] $msg
} {1 {wrong # args: should be "AppleScript option ?arg ...?"}}
@@ -35,4 +38,7 @@ test osa-1.3 {TclOSACompileCmd} {
list [catch {AppleScript compile} msg] $msg
} {1 {wrong # args: should be "AppleScript compile ?options? code"}}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/parse.test b/tests/parse.test
index 70fb5bb..0c0df8e 100644
--- a/tests/parse.test
+++ b/tests/parse.test
@@ -3,11 +3,12 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: parse.test,v 1.1.2.7 1999/02/01 21:30:38 stanton Exp $
+# RCS: @(#) $Id: parse.test,v 1.1.2.8 1999/03/11 18:49:58 hershey Exp $
if {[info commands testparser] == {}} {
puts "This application hasn't been compiled with the \"testparser\""
@@ -15,7 +16,9 @@ if {[info commands testparser] == {}} {
return
}
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test parse-1.1 {Tcl_ParseCommand procedure, computing string length} {
testparser [bytestring "foo\0 bar"] -1
@@ -713,7 +716,9 @@ test parse-15.57 {CommandComplete procedure} {
info complete "# Comment should be complete command"
} 1
-
+# cleanup
catch {unset a}
+::test::cleanupTests
return
+
diff --git a/tests/parseExpr.test b/tests/parseExpr.test
index 7f02d12..32bb367 100644
--- a/tests/parseExpr.test
+++ b/tests/parseExpr.test
@@ -3,11 +3,12 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) parseExpr.test 1.8 98/01/09 09:48:03
+# RCS: @(#) $Id: parseExpr.test,v 1.1.2.2 1999/03/11 18:49:59 hershey Exp $
# Note that the Tcl expression parser (tclParseExpr.c) does not check
# the semantic validity of the expressions it parses. It does not check,
@@ -20,7 +21,9 @@ if {[info commands testexprparser] == {}} {
return
}
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test parseExpr-1.1 {Tcl_ParseExpr procedure, computing string length} {
testexprparser [bytestring "1+2\0 +3"] -1
@@ -616,4 +619,7 @@ test parse-16.1 {LogSyntaxError procedure, error in expr longer than 60 chars} {
list [catch {testexprparser {(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)/} -1} msg] $msg
} {1 {syntax error in expression "(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+012"}}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/parseOld.test b/tests/parseOld.test
index 47dc1a6..5e27972 100644
--- a/tests/parseOld.test
+++ b/tests/parseOld.test
@@ -8,13 +8,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) parseOld.test 1.52 98/02/11 19:01:03
+# RCS: @(#) $Id: parseOld.test,v 1.1.2.2 1999/03/11 18:50:00 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
proc fourArgs {a b c d} {
global arg1 arg2 arg3 arg4
@@ -526,4 +529,7 @@ test parseOld-15.5 {TclScriptEnd procedure} {
info complete "xyz \[abc"
} {0}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/pid.test b/tests/pid.test
index 323b12a..2d024fc 100644
--- a/tests/pid.test
+++ b/tests/pid.test
@@ -6,11 +6,12 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1995 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: pid.test,v 1.1.2.2 1998/09/24 23:59:33 stanton Exp $
+# RCS: @(#) $Id: pid.test,v 1.1.2.3 1999/03/11 18:50:00 hershey Exp $
# If pid is not defined just return with no error
# Some platforms may not have the pid command implemented
@@ -19,7 +20,9 @@ if {[info commands pid] == ""} {
return
}
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
catch {removeFile test1}
@@ -48,5 +51,8 @@ test pid-1.5 {pid command} {
list [catch {pid gorp} msg] $msg
} {1 {can not find channel named "gorp"}}
-catch {removeFile test1}
+# cleanup
+catch {::test::removeFile test1}
+::test::cleanupTests
return
+
diff --git a/tests/pkg.test b/tests/pkg.test
index c3847386..ed6d49f 100644
--- a/tests/pkg.test
+++ b/tests/pkg.test
@@ -5,23 +5,24 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: pkg.test,v 1.1.2.3 1999/03/10 06:49:25 stanton Exp $
+# RCS: @(#) $Id: pkg.test,v 1.1.2.4 1999/03/11 18:50:00 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
# Do all this in a slave interp to avoid garbaging the
# package list
set i [interp create]
-interp eval $i [list set VERBOSE $VERBOSE]
-interp eval $i [list set TESTS $TESTS]
+interp eval $i [list set argv $argv]
+interp eval $i [list source [file join $::test::testsDir defs.tcl]]
interp eval $i {
-if {[string compare test [info procs test]] == 1} then {source defs}
-
eval package forget [package names]
set oldPkgUnknown [package unknown]
package unknown {}
@@ -629,8 +630,12 @@ test pkg-7.18 {Tcl_PackageCmd procedure, "present" option} {
set auto_path $oldPath
package unknown $oldPkgUnknown
+::test::cleanupTests
concat
}
+
+# cleanup
interp delete $i
return
+
diff --git a/tests/pkgMkIndex.test b/tests/pkgMkIndex.test
index bb2c985..d13a040 100644
--- a/tests/pkgMkIndex.test
+++ b/tests/pkgMkIndex.test
@@ -5,20 +5,31 @@
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
-# Copyright (c) 1998 by Scriptics Corporation.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: pkgMkIndex.test,v 1.4.2.1 1998/12/11 21:44:59 stanton Exp $
+# RCS: @(#) $Id: pkgMkIndex.test,v 1.4.2.2 1999/03/11 18:50:01 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
+
+# temporarily copy the pkg and pkg1 dirs from testsDir to tmpDir
+set origPkgDir [file join $::test::testsDir pkg]
+set newPkgDir [file join $::test::tmpDir pkg]
+if {![catch {file copy $origPkgDir $newPkgDir}]} {
+ set removePkgDir 1
+}
+if {![catch {file copy "${origPkgDir}1" "${newPkgDir}1"}]} {
+ set removePkg1Dir 1
+}
# Add the pkg1 directory to auto_path, so that its packages can be found.
# packages in pkg1 are used to test indexing of packages in pkg.
# Make sure that the path to pkg1 is absolute.
-set scriptDir [file dirname [info script]]
set oldDir [pwd]
-lappend auto_path [file join [pwd] $scriptDir pkg1]
+lappend auto_path [file join $::test::tmpDir pkg1]
namespace eval pkgtest {
# Namespace for procs we can discard
@@ -317,8 +328,7 @@ test pkgMkIndex-9.1 {circular packages} {
} {0 {{circ1:1.0 {tclPkgSetup {circ1.tcl source {::circ1::c1-1 ::circ1::c1-2 ::circ1::c1-3 ::circ1::c1-4}}}} {circ2:1.0 {tclPkgSetup {circ2.tcl source {::circ2::c2-1 ::circ2::c2-2}}}} {circ3:1.0 {tclPkgSetup {circ3.tcl source ::circ3::c3-1}}}}}
# Try to find one of the DLLs in the dltest directory
-set x [file join [pwd] [file dirname [info script]]]
-set x [file join $x ../unix/dltest/pkga[info sharedlibextension]]
+set x [file join $::test::testsDir ../unix/dltest/pkga[info sharedlibextension]]
if {[file exists $x]} {
file copy -force $x pkg
test pkgMkIndex-10.1 {package in DLL and script} {
@@ -331,10 +341,14 @@ if {[file exists $x]} {
puts "Skipping pkgMkIndex-10.1 (index of DLL and script)"
}
-#
# cleanup
-#
-if {![info exist TESTS]} {
- file delete [file join pkg pkgIndex.tcl]
- namespace delete pkgtest
+namespace delete pkgtest
+cd $::test::tmpDir
+if {[info exists removePkgDir]} {
+ catch {file delete -force $newPkgDir}
+}
+if {[info exists removePkg1Dir]} {
+ catch {file delete -force "${newPkgDir}1"}
}
+::test::cleanupTests
+return
diff --git a/tests/platform.test b/tests/platform.test
index e3c78ef..10d87f6 100644
--- a/tests/platform.test
+++ b/tests/platform.test
@@ -11,10 +11,14 @@
#
# RCS: @(#)
-if {[info procs test] != "test"} {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test platform-1.1 {TclpSetVariables: tcl_platform} {
lsort [array names tcl_platform]
} {byteOrder machine os osVersion platform user}
+# cleanup
+::test::cleanupTests
return
diff --git a/tests/proc-old.test b/tests/proc-old.test
index 3a9bd43..b01e091 100644
--- a/tests/proc-old.test
+++ b/tests/proc-old.test
@@ -9,13 +9,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: proc-old.test,v 1.1.2.2 1998/09/24 23:59:34 stanton Exp $
+# RCS: @(#) $Id: proc-old.test,v 1.1.2.3 1999/03/11 18:50:02 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
catch {rename t1 ""}
catch {rename foo ""}
@@ -501,6 +504,9 @@ test proc-old-10.1 {ByteCode epoch change during recursive proc execution} {
t1 1
} 20
+# cleanup
catch {rename t1 ""}
catch {rename foo ""}
+::test::cleanupTests
return
+
diff --git a/tests/proc.test b/tests/proc.test
index a5d6408..f26b9c2 100644
--- a/tests/proc.test
+++ b/tests/proc.test
@@ -8,13 +8,16 @@
# errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: proc.test,v 1.1.2.3 1998/10/06 02:59:05 stanton Exp $
+# RCS: @(#) $Id: proc.test,v 1.1.2.4 1999/03/11 18:50:02 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
@@ -289,5 +292,9 @@ test proc-4.7 {TclCreateProc, procbody obj, inconsitent arg default value} {
set result
} {procedure "t": formal parameter "z" has default value inconsistent with precompiled body}
+# cleanup
catch {rename p ""}
catch {rename t ""}
+::test::cleanupTests
+return
+
diff --git a/tests/pwd.test b/tests/pwd.test
index 8a11910..67e286a 100644
--- a/tests/pwd.test
+++ b/tests/pwd.test
@@ -6,13 +6,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: pwd.test,v 1.1.2.1 1998/09/24 23:59:34 stanton Exp $
+# RCS: @(#) $Id: pwd.test,v 1.1.2.2 1999/03/11 18:50:03 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test pwd-1.1 {simple pwd} {
catch pwd
@@ -20,3 +23,8 @@ test pwd-1.1 {simple pwd} {
test pwd-1.2 {simple pwd} {
expr [string length pwd]>0
} 1
+
+# cleanup
+::test::cleanupTests
+return
+
diff --git a/tests/reg.test b/tests/reg.test
index 32b8dde..d12c2a3 100644
--- a/tests/reg.test
+++ b/tests/reg.test
@@ -1,6 +1,17 @@
-# regexp tests
+# reg.test --
+#
+# This file contains a collection of tests for one or more of the Tcl
+# built-in commands. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+#
+# RCS: @(#) $Id: reg.test,v 1.1.2.3 1999/03/11 18:50:03 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
# This file uses some custom procedures, defined below, for regexp regression
# testing. The name of the procedure indicates the general nature of the
@@ -879,4 +890,8 @@ m 5 & ^a*b aaaab aaaab
doing 0 "flush" ;# to flush any leftover complaints
+
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/regexp.test b/tests/regexp.test
index b35efe7..b6e1fce 100644
--- a/tests/regexp.test
+++ b/tests/regexp.test
@@ -6,13 +6,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1998 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: regexp.test,v 1.1.2.6 1998/12/08 04:29:49 stanton Exp $
+# RCS: @(#) $Id: regexp.test,v 1.1.2.7 1999/03/11 18:50:03 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
catch {unset foo}
test regexp-1.1 {basic regexp operation} {
@@ -358,4 +361,7 @@ test regexp-12.1 {regsub of a very large string} {
set x done
} {done}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/registry.test b/tests/registry.test
index 736d4ae..4c85b26 100644
--- a/tests/registry.test
+++ b/tests/registry.test
@@ -10,13 +10,21 @@
# Copyright (c) 1997 by Sun Microsystems, Inc. All rights reserved.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
-# RCS: @(#) $Id: registry.test,v 1.1.2.4 1999/02/10 23:31:24 stanton Exp $
+# RCS: @(#) $Id: registry.test,v 1.1.2.5 1999/03/11 18:50:04 hershey Exp $
if {$tcl_platform(platform) != "windows"} {
+ puts "skipping: Windows only tests..."
return
}
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
+
+if {$::test::testConfig(win32s)} {
+ puts "Skipping registry tests under Win32s"
+ return
+}
set lib [lindex [glob [file join [pwd] [file dirname \
[info nameofexecutable]] tclreg*.dll]] 0]
@@ -26,14 +34,9 @@ if [catch {load $lib registry}] {
return
}
-if {$testConfig(win32s)} {
- puts "Skipping registry tests under Win32s"
- return
-}
-
switch $tcl_platform(os) {
- "Windows NT" {set testConfig(NT) 1}
- "Windows 95" {set testConfig(95) 1}
+ "Windows NT" {set ::test::testConfig(NT) 1}
+ "Windows 95" {set ::test::testConfig(95) 1}
}
# determine the current locale
@@ -41,7 +44,7 @@ set old [testlocale all]
if {[testlocale all ""] == "English_United States.1252"} {
# error messages from registry package are already localized.
- set testConfig(english) 1
+ set ::test::testConfig(english) 1
}
testlocale all $old
unset old
@@ -523,5 +526,8 @@ test registry-11.3 {SetValue: failure} {nonPortable english} {
} {1 {unable to open key: Access is denied.}}
+# cleanup
unset hostname
+::test::cleanupTests
return
+
diff --git a/tests/rename.test b/tests/rename.test
index 6956cf0..a5d6e9e 100644
--- a/tests/rename.test
+++ b/tests/rename.test
@@ -6,13 +6,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: rename.test,v 1.1.2.2 1998/09/24 23:59:35 stanton Exp $
+# RCS: @(#) $Id: rename.test,v 1.1.2.3 1999/03/11 18:50:05 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
# Must eliminate the "unknown" command while the test is running,
# especially if the test is being run in a program with its
@@ -163,8 +166,10 @@ test rename-6.1 {old code invalidated (epoch incremented) when cmd with compile
set msg
} {called "incr" with too many arguments}
+# cleanup
catch {rename incr {}}
catch {rename incr.old incr}
-
+::test::cleanupTests
return
+
diff --git a/tests/resource.test b/tests/resource.test
index 938ff34..becc9ba 100644
--- a/tests/resource.test
+++ b/tests/resource.test
@@ -5,17 +5,22 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: resource.test,v 1.1.2.2 1998/11/11 04:08:34 stanton Exp $
+# RCS: @(#) $Id: resource.test,v 1.1.2.3 1999/03/11 18:50:05 hershey Exp $
# Only run this test on Macintosh systems
if {$tcl_platform(platform) != "macintosh"} {
+ puts "skipping: Mac only tests..."
return
}
-if {[string compare test [info procs test]] == 1} then {source defs}
+
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test resource-1.1 {resource tests} {
list [catch {resource} msg] $msg
@@ -347,6 +352,8 @@ test resource-9.5 {source command} {
list [catch {source -rsrcid 100 rsrc.file} msg] $msg
} {1 {The resource "ID=100" could not be loaded from rsrc.file.}}
-# Clean up and return
+# cleanup
catch {file delete rsrc.file}
+::test::cleanupTests
return
+
diff --git a/tests/result.test b/tests/result.test
index c511423..ea4b241 100644
--- a/tests/result.test
+++ b/tests/result.test
@@ -5,14 +5,15 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# SCCS: @(#) result.test 1.4 97/12/08 15:07:49
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
test result-1.1 {Tcl_SaveInterpResult} {
@@ -78,4 +79,8 @@ test result-4.5 {Tcl_SetObjErrorCode - five args} {
catch {testsetobjerrorcode 1 2 3 4 5}
list [set errorCode]
} {{1 2 3 4 5}}
+
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/safe.test b/tests/safe.test
index 745b529..6d2814e 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -5,13 +5,16 @@
# and generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: safe.test,v 1.1.2.3 1998/11/11 04:08:35 stanton Exp $
+# RCS: @(#) $Id: safe.test,v 1.1.2.4 1999/03/11 18:50:06 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
foreach i [interp slaves] {
interp delete $i
@@ -435,4 +438,7 @@ test safe-10.4 {testing nested statics loading / -nestedloadok} {
}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/scan.test b/tests/scan.test
index ec7a264..cf878ed 100644
--- a/tests/scan.test
+++ b/tests/scan.test
@@ -6,13 +6,16 @@
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: scan.test,v 1.1.2.4 1998/11/18 04:15:46 stanton Exp $
+# RCS: @(#) $Id: scan.test,v 1.1.2.5 1999/03/11 18:50:06 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test scan-1.1 {BuildCharSet, CharInSet} {
list [scan foo {%[^o]} x] $x
@@ -564,6 +567,9 @@ test scan-11.5 {alignment in results array (TCL_ALIGN)} {
set b
} 13.6
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/security.test b/tests/security.test
index 9f198ba..b898396 100644
--- a/tests/security.test
+++ b/tests/security.test
@@ -1,3 +1,5 @@
+# security.test --
+#
# Functionality covered: this file contains a collection of tests for the
# auto loading and namespaces.
#
@@ -5,14 +7,14 @@
# errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# SCCS: @(#) security.test 1.1 97/11/20 16:38:33
-
+# RCS: @(#) $Id: security.test,v 1.1.2.2 1999/03/11 18:50:07 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
# If this proc becomes invoked, then there is a bug
@@ -34,3 +36,7 @@ test sec-1.1 {tcl_endOfPreviousWord} {
catch {tcl_startOfPreviousWord x {[BUG]}}
CB
} 0
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/set-old.test b/tests/set-old.test
index 78a5005..22b81e5 100644
--- a/tests/set-old.test
+++ b/tests/set-old.test
@@ -8,13 +8,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: set-old.test,v 1.1.2.2 1998/09/24 23:59:35 stanton Exp $
+# RCS: @(#) $Id: set-old.test,v 1.1.2.3 1999/03/11 18:50:07 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
proc ignore args {}
@@ -786,9 +789,12 @@ test set-old-12.2 {cleanup on procedure return} {
# Must delete variables when done, since these arrays get used as
# scalars by other tests.
-
catch {unset a}
catch {unset b}
catch {unset c}
catch {unset aVaRnAmE}
+
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/set.test b/tests/set.test
index 03c1492..55ddb05 100644
--- a/tests/set.test
+++ b/tests/set.test
@@ -5,13 +5,16 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: set.test,v 1.1.2.2 1998/09/24 23:59:36 stanton Exp $
+# RCS: @(#) $Id: set.test,v 1.1.2.3 1999/03/11 18:50:08 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
catch {unset x}
catch {unset i}
@@ -474,9 +477,12 @@ test set-4.6 {set command: runtime error, basic array operations} {
list [catch {$z a} msg] $msg
} {1 {can't read "a": variable is array}}
+# cleanup
catch {unset a}
catch {unset b}
catch {unset i}
catch {unset x}
catch {unset z}
+::test::cleanupTests
return
+
diff --git a/tests/socket.test b/tests/socket.test
index 2483ab5..5c185e3 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -5,10 +5,13 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
+# RCS: @(#) $Id: socket.test,v 1.1.2.5 1999/03/11 18:50:08 hershey Exp $
+
# Running socket tests with a remote server:
# ------------------------------------------
#
@@ -58,12 +61,13 @@
# server (via exec) on platforms that support this, on the local host,
# listening at port 2048. If all fails, a message is printed and the tests
# using the remote server are not performed.
-#
-# RCS: @(#) $Id: socket.test,v 1.1.2.4 1998/12/10 18:27:10 stanton Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
-if {$testConfig(socket) == 0} {
+if {$::test::testConfig(socket) == 0} {
+ puts "skipping: tests require sockets"
return
}
@@ -115,11 +119,12 @@ if {$doTestsWithRemoteServer} {
if {[info commands exec] == ""} {
set noRemoteTestReason "can't exec"
set doTestsWithRemoteServer 0
- } elseif {$testConfig(win32s)} {
+ } elseif {$::test::testConfig(win32s)} {
set noRemoteTestReason "\ncan't run multiple instances of tcltest under win32s."
set doTestsWithRemoteServer 0
} else {
set remoteServerIP 127.0.0.1
+ #set remoteFile [file join $::test::testsDir remote.tcl]
if {[catch {set remoteProcChan \
[open "|[list $tcltest remote.tcl \
-serverIsSilent \
@@ -145,10 +150,12 @@ if {$doTestsWithRemoteServer} {
}
}
+# Some tests are run only if we are doing testing against a remote server.
+set ::test::testConfig(doTestsWithRemoteServer) $doTestsWithRemoteServer
if {$doTestsWithRemoteServer == 0} {
puts "Skipping tests with remote server. See tests/socket.test for"
puts "information on how to run remote server."
- if {[info exists VERBOSE] && ($VERBOSE != 0)} {
+ if {$::test::verbose != ""} {
puts "Reason for not doing remote tests: $noRemoteTestReason"
}
}
@@ -1023,16 +1030,7 @@ test socket-10.1 {testing socket accept callback error handling} {
set goterror
} 1
-#
-# The rest of the tests are run only if we are doing testing against
-# a remote server.
-#
-
-if {$doTestsWithRemoteServer == 0} {
- return
-}
-
-test socket-11.1 {tcp connection} {
+test socket-11.1 {tcp connection} {doTestsWithRemoteServer} {
sendCommand {
set socket9_1_test_server [socket -server accept 2834]
proc accept {s a p} {
@@ -1046,7 +1044,7 @@ test socket-11.1 {tcp connection} {
sendCommand {close $socket9_1_test_server}
set r
} done
-test socket-11.2 {client specifies its port} {
+test socket-11.2 {client specifies its port} {doTestsWithRemoteServer} {
if {[info exists port]} {
incr port
} else {
@@ -1070,7 +1068,7 @@ test socket-11.2 {client specifies its port} {
}
set result
} ok
-test socket-11.3 {trying to connect, no server} {
+test socket-11.3 {trying to connect, no server} {doTestsWithRemoteServer} {
set status ok
if {![catch {set s [socket $remoteServerIp 2836]}]} {
if {![catch {gets $s}]} {
@@ -1080,7 +1078,7 @@ test socket-11.3 {trying to connect, no server} {
}
set status
} ok
-test socket-11.4 {remote echo, one line} {
+test socket-11.4 {remote echo, one line} {doTestsWithRemoteServer} {
sendCommand {
set socket10_6_test_server [socket -server accept 2836]
proc accept {s a p} {
@@ -1104,7 +1102,7 @@ test socket-11.4 {remote echo, one line} {
sendCommand {close $socket10_6_test_server}
set r
} hello
-test socket-11.5 {remote echo, 50 lines} {
+test socket-11.5 {remote echo, 50 lines} {doTestsWithRemoteServer} {
sendCommand {
set socket10_7_test_server [socket -server accept 2836]
proc accept {s a p} {
@@ -1138,7 +1136,7 @@ if {$tcl_platform(platform) == "macintosh"} {
} else {
set conflictResult {1 {couldn't open socket: address already in use}}
}
-test socket-11.6 {socket conflict} {
+test socket-11.6 {socket conflict} {doTestsWithRemoteServer} {
set s1 [socket -server accept 2836]
if {[catch {set s2 [socket -server accept 2836]} msg]} {
set result [list 1 $msg]
@@ -1149,7 +1147,7 @@ test socket-11.6 {socket conflict} {
close $s1
set result
} $conflictResult
-test socket-11.7 {server with several clients} {
+test socket-11.7 {server with several clients} {doTestsWithRemoteServer} {
sendCommand {
set socket10_9_test_server [socket -server accept 2836]
proc accept {s a p} {
@@ -1185,7 +1183,7 @@ test socket-11.7 {server with several clients} {
sendCommand {close $socket10_9_test_server}
set i
} 100
-test socket-11.8 {client with several servers} {
+test socket-11.8 {client with several servers} {doTestsWithRemoteServer} {
sendCommand {
set s1 [socket -server "accept 4003" 4003]
set s2 [socket -server "accept 4004" 4004]
@@ -1211,7 +1209,7 @@ test socket-11.8 {client with several servers} {
}
set l
} {4003 {} 1 4004 {} 1 4005 {} 1}
-test socket-11.9 {accept callback error} {
+test socket-11.9 {accept callback error} {doTestsWithRemoteServer} {
set s [socket -server accept 2836]
proc accept {s a p} {expr 10 / 0}
proc bgerror args {
@@ -1233,7 +1231,7 @@ test socket-11.9 {accept callback error} {
rename bgerror {}
set x
} {{divide by zero}}
-test socket-11.10 {testing socket specific options} {
+test socket-11.10 {testing socket specific options} {doTestsWithRemoteServer} {
sendCommand {
set socket10_12_test_server [socket -server accept 2836]
proc accept {s a p} {close $s}
@@ -1247,7 +1245,7 @@ test socket-11.10 {testing socket specific options} {
sendCommand {close $socket10_12_test_server}
set l
} {2836 3 3}
-test socket-11.11 {testing spurious events} {
+test socket-11.11 {testing spurious events} {doTestsWithRemoteServer} {
sendCommand {
set socket10_13_test_server [socket -server accept 2836]
proc accept {s a p} {
@@ -1286,7 +1284,7 @@ test socket-11.11 {testing spurious events} {
sendCommand {close $socket10_13_test_server}
list $spurious $len
} {0 2690}
-test socket-11.12 {testing EOF stickyness} {
+test socket-11.12 {testing EOF stickyness} {doTestsWithRemoteServer} {
set counter 0
set done 0
proc count_up {s} {
@@ -1319,7 +1317,8 @@ test socket-11.12 {testing EOF stickyness} {
sendCommand {close $socket10_14_test_server}
set done
} {EOF is sticky}
-test socket-11.13 {testing async write, async flush, async close} {
+test socket-11.13 {testing async write, async flush, async close} \
+ {doTestsWithRemoteServer} {
proc readit {s} {
global count done
set l [read $s]
@@ -1372,7 +1371,7 @@ test socket-11.13 {testing async write, async flush, async close} {
set count
} 65566
-test socket-12.1 {testing inheritance of server sockets} {
+test socket-12.1 {testing inheritance of server sockets} {doTestsWithRemoteServer} {
removeFile script1
removeFile script2
@@ -1423,7 +1422,7 @@ test socket-12.1 {testing inheritance of server sockets} {
removeFile script2
set x
} {server socket was not inherited}
-test socket-12.2 {testing inheritance of client sockets} {
+test socket-12.2 {testing inheritance of client sockets} {doTestsWithRemoteServer} {
removeFile script1
removeFile script2
@@ -1508,7 +1507,7 @@ test socket-12.2 {testing inheritance of client sockets} {
removeFile script2
set x
} {client socket was not inherited}
-test socket-12.3 {testing inheritance of accepted sockets} {
+test socket-12.3 {testing inheritance of accepted sockets} {doTestsWithRemoteServer} {
removeFile script1
removeFile script2
@@ -1583,12 +1582,13 @@ test socket-12.3 {testing inheritance of accepted sockets} {
set x
} {accepted socket was not inherited}
-
+# cleanup
+catch {close $commandSocket}
+catch {close $remoteProcChan}
if {[string match sock* $commandSocket] == 1} {
puts $commandSocket exit
flush $commandSocket
}
-catch {close $commandSocket}
-catch {close $remoteProcChan}
+::test::cleanupTests
+flush stdout
-return
diff --git a/tests/source.test b/tests/source.test
index 21c92f2..2f203e77 100644
--- a/tests/source.test
+++ b/tests/source.test
@@ -6,13 +6,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: source.test,v 1.1.2.2 1998/09/24 23:59:36 stanton Exp $
+# RCS: @(#) $Id: source.test,v 1.1.2.3 1999/03/11 18:50:09 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test source-1.1 {source command} {
set x "old x value"
@@ -176,6 +179,8 @@ test source-6.1 {source is binary ok} {
string length $x
} 5
-catch {removeFile source.file}
-
+# cleanup
+catch {::test::removeFile source.file}
+::test::cleanupTests
return
+
diff --git a/tests/split.test b/tests/split.test
index d8a85bf..9238997 100644
--- a/tests/split.test
+++ b/tests/split.test
@@ -6,13 +6,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: split.test,v 1.1.2.1 1998/09/24 23:59:37 stanton Exp $
+# RCS: @(#) $Id: split.test,v 1.1.2.2 1999/03/11 18:50:09 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test split-1.1 {basic split commands} {
split "a\n b\t\r c\n "
@@ -63,3 +66,8 @@ test split-2.1 {split errors} {
test split-2.2 {split errors} {
list [catch {split a b c} msg] $msg $errorCode
} {1 {wrong # args: should be "split string ?splitChars?"} NONE}
+
+# cleanup
+::test::cleanupTests
+return
+
diff --git a/tests/stack.test b/tests/stack.test
new file mode 100644
index 0000000..36f36a1
--- /dev/null
+++ b/tests/stack.test
@@ -0,0 +1,30 @@
+# Tests that the stack size is big enough for the application.
+#
+# This file contains a collection of tests for one or more of the Tcl
+# built-in commands. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: stack.test,v 1.1.2.1 1999/03/11 18:50:10 hershey Exp $
+
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
+
+# Note that a failure in this test results in a crash of the executable.
+
+test stack-1.1 {maxNestingDepth reached on infinite recursion} {
+ proc recurse {} { return [recurse] }
+ catch {recurse} rv
+ rename recurse {}
+ set rv
+} {too many nested calls to Tcl_EvalObj (infinite loop?)}
+
+# cleanup
+::test::cleanupTests
+return
+
diff --git a/tests/string.test b/tests/string.test
index 9461fa6..4ccc5e5 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -6,13 +6,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: string.test,v 1.1.2.2 1998/12/03 23:59:13 stanton Exp $
+# RCS: @(#) $Id: string.test,v 1.1.2.3 1999/03/11 18:50:11 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test string-1.1 {string compare} {
string compare abcde abdef
@@ -382,3 +385,8 @@ test string-15.1 {error conditions} {
test string-15.2 {error conditions} {
list [catch {string} msg] $msg
} {1 {wrong # args: should be "string option arg ?arg ...?"}}
+
+# cleanup
+::test::cleanupTests
+return
+
diff --git a/tests/stringObj.test b/tests/stringObj.test
index 4d1e841..83810132 100644
--- a/tests/stringObj.test
+++ b/tests/stringObj.test
@@ -7,11 +7,12 @@
# errors. No output means no errors were found.
#
# Copyright (c) 1995-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: stringObj.test,v 1.1.2.2 1998/09/24 23:59:38 stanton Exp $
+# RCS: @(#) $Id: stringObj.test,v 1.1.2.3 1999/03/11 18:50:11 hershey Exp $
if {[info commands testobj] == {}} {
puts "This application hasn't been compiled with the \"testobj\""
@@ -19,7 +20,9 @@ if {[info commands testobj] == {}} {
return
}
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test stringObj-1.1 {string type registration} {
set t [testobj types]
@@ -187,4 +190,8 @@ test stringObj-8.1 {DupStringInternalRep procedure} {
} {5 10 5 5 abcde}
testobj freeallvars
+
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/subst.test b/tests/subst.test
index fca58c4..44fabca 100644
--- a/tests/subst.test
+++ b/tests/subst.test
@@ -6,13 +6,16 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: subst.test,v 1.1.2.2 1998/09/24 23:59:38 stanton Exp $
+# RCS: @(#) $Id: subst.test,v 1.1.2.3 1999/03/11 18:50:11 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test subst-1.1 {basics} {
list [catch {subst} msg] $msg
@@ -105,4 +108,7 @@ test subst-7.7 {switches} {
subst -nov -nob -noc {abc $x [expr 1+2] \\\x41}
} {abc $x [expr 1+2] \\\x41}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/switch.test b/tests/switch.test
index a81e5a1..5c0ec0f 100644
--- a/tests/switch.test
+++ b/tests/switch.test
@@ -6,13 +6,16 @@
#
# Copyright (c) 1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: switch.test,v 1.1.2.3 1998/12/03 23:59:13 stanton Exp $
+# RCS: @(#) $Id: switch.test,v 1.1.2.4 1999/03/11 18:50:12 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test switch-1.1 {simple patterns} {
switch a a {format 1} b {format 2} c {format 3} default {format 4}
@@ -178,4 +181,7 @@ test switch-8.1 {empty body} {
}
} {}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/thread.test b/tests/thread.test
index a68f54e..9791668 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -5,18 +5,22 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) thread.test 1.4 98/02/19 11:53:53
-
-if {[string compare test [info procs test]] == 1} then {source defs}
+# RCS: @(#) $Id: thread.test,v 1.1.2.2 1999/03/11 18:50:12 hershey Exp $
if {[info command testthread] == ""} {
+ puts "skipping: tests require the testthread command"
return
}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
+
set mainthread [testthread names]
proc ThreadReap {} {
global mainthread
@@ -215,3 +219,7 @@ test thread-4.4 {TclThreadSend preserve errorCode} {
} {1 ERR CODE}
ThreadReap
+# cleanup
+::test::cleanupTests
+return
+
diff --git a/tests/timer.test b/tests/timer.test
index 0cb4f4d..47349b7 100644
--- a/tests/timer.test
+++ b/tests/timer.test
@@ -8,13 +8,16 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: timer.test,v 1.1.2.2 1998/09/24 23:59:39 stanton Exp $
+# RCS: @(#) $Id: timer.test,v 1.1.2.3 1999/03/11 18:50:13 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test timer-1.1 {Tcl_CreateTimerHandler procedure} {
foreach i [after info] {
@@ -534,4 +537,7 @@ test timer-9.1 {AfterCleanupProc procedure} {
set x
} {before after2 after4}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/trace.test b/tests/trace.test
index 84bb205..d118f47 100644
--- a/tests/trace.test
+++ b/tests/trace.test
@@ -6,13 +6,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: trace.test,v 1.1.2.2 1998/09/24 23:59:39 stanton Exp $
+# RCS: @(#) $Id: trace.test,v 1.1.2.3 1999/03/11 18:50:13 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
proc traceScalar {name1 name2 op} {
global info
@@ -963,4 +966,8 @@ test trace-17.1 {unset traces on procedure returns} {
catch {unset x}
catch {unset y}
+
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test
index ad1c1fc..32c8902 100644
--- a/tests/unixFCmd.test
+++ b/tests/unixFCmd.test
@@ -9,14 +9,17 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: unixFCmd.test,v 1.1.2.3 1998/12/11 00:12:08 stanton Exp $
-
-if {[string compare test [info procs test]] == 1} then {source defs}
+# RCS: @(#) $Id: unixFCmd.test,v 1.1.2.4 1999/03/11 18:50:14 hershey Exp $
if {$tcl_platform(platform) != "unix"} {
+ puts "skipping: Unix only tests..."
return
}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
+
if {$user == "root"} {
puts "Skipping unixFCmd tests. They depend on not being able to write to"
puts "certain directories. It would be too dangerous to run them as root."
@@ -173,10 +176,10 @@ test unixFCmd-10.1 {TraversalDelete not done} {
test unixFCmd-11.1 {CopyFileAttrs not done} {
} {}
-set testConfig(tclGroup) 0
+set ::test::testConfig(tclGroup) 0
if {[catch {exec {groups}} groupList] == 0} {
if {[lsearch $groupList tcl] != -1} {
- set testConfig(tclGroup) 1
+ set ::test::testConfig(tclGroup) 1
}
}
@@ -265,5 +268,8 @@ test unixFCmd-18.1 {Unix pwd} {nonPortable} {
set r
} {1 {error getting working directory name:}}
+# cleanup
cleanup
+::test::cleanupTests
return
+
diff --git a/tests/unixFile.test b/tests/unixFile.test
index e94ed90..f4f46d1 100644
--- a/tests/unixFile.test
+++ b/tests/unixFile.test
@@ -4,15 +4,21 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1998 by Scriptics Corporation.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: unixFile.test,v 1.1.2.1 1998/09/24 23:59:39 stanton Exp $
+# RCS: @(#) $Id: unixFile.test,v 1.1.2.2 1999/03/11 18:50:14 hershey Exp $
-
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {$tcl_platform(platform) != "unix"} {
+ puts "skipping: Unix only tests..."
+ return
+}
+
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
if {[info commands testobj] == {}} {
puts "This application hasn't been compiled with the \"testfindexecutable\""
@@ -20,11 +26,6 @@ if {[info commands testobj] == {}} {
return
}
-if {$tcl_platform(platform) != "unix"} {
- return
-}
-
-
set oldPath $env(PATH)
close [open junk w]
file attributes junk -perm 0777
@@ -59,8 +60,9 @@ test unixFile-1.7 {Tcl_FindExecutable} {
testfindexecutable junk
} $absPath
-
-
-
+# cleanup
set env(PATH) $oldPath
file delete junk
+::test::cleanupTests
+return
+
diff --git a/tests/unixInit.test b/tests/unixInit.test
index afbb794..d2ba1d3 100644
--- a/tests/unixInit.test
+++ b/tests/unixInit.test
@@ -5,20 +5,24 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) unixInit.test 1.4 98/01/13 20:03:07
-
-if {[info procs test] != "test"} {source defs}
+# RCS: @(#) $Id: unixInit.test,v 1.1.2.3 1999/03/11 18:50:14 hershey Exp $
if {$tcl_platform(platform) != "unix"} {
+ puts "skipping: Unix only tests..."
return
}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
+
if {[catch {csh -c "setenv LANG japanese"}] == 0} {
- set testConfig(japanese) 1
+ set ::test::testConfig(japanese) 1
}
catch {set oldlibrary $env(TCL_LIBRARY); unset env(TCL_LIBRARY)}
@@ -150,6 +154,9 @@ test unixInit-5.1 {Tcl_Init} {
test unixInit-6.1 {Tcl_SourceRCFile} {
} {}
+# cleanup
catch {unset env(TCL_LIBRARY); set env(TCL_LIBRARY) $oldlibrary}
catch {unset env(LANG); set env(LANG) $oldlang}
+::test::cleanupTests
return
+
diff --git a/tests/unixNotfy.test b/tests/unixNotfy.test
index da92085..05a70b8 100644
--- a/tests/unixNotfy.test
+++ b/tests/unixNotfy.test
@@ -5,15 +5,15 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: unixNotfy.test,v 1.1.2.2 1998/09/24 23:59:39 stanton Exp $
-
-if {[string compare test [info procs test]] == 1} then {source defs}
+# RCS: @(#) $Id: unixNotfy.test,v 1.1.2.3 1999/03/11 18:50:15 hershey Exp $
if {$tcl_platform(platform) != "unix"} {
+ puts "skipping: Unix only tests..."
return
}
@@ -22,9 +22,14 @@ if {$tcl_platform(platform) != "unix"} {
# the "testthread" command indicates that this is the case.
if {"[info commands testthread]" == "testthread"} {
+ puts "skipping: tests require the testthread command..."
return
}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
+
test unixNotfy-1.1 {Tcl_DeleteFileHandler} {
catch {vwait x}
set f [open foo w]
@@ -46,6 +51,9 @@ test unixNotfy-1.2 {Tcl_DeleteFileHandler} {
list [catch {vwait x} msg] $msg
} {1 {can't wait for variable "x": would wait forever}}
+# cleanup
file delete foo
file delete foo2
+::test::cleanupTests
return
+
diff --git a/tests/unknown.test b/tests/unknown.test
index ba9fc68..2fc57ee 100644
--- a/tests/unknown.test
+++ b/tests/unknown.test
@@ -6,13 +6,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: unknown.test,v 1.1.2.2 1998/09/24 23:59:39 stanton Exp $
+# RCS: @(#) $Id: unknown.test,v 1.1.2.3 1999/03/11 18:50:15 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
catch {unset x}
catch {rename unknown unknown.old}
@@ -56,6 +59,9 @@ test unknown-4.1 {errors in "unknown" procedure} {
list [catch {non-existent a b} msg] $msg $errorCode
} {1 {unknown failed} NONE}
+# cleanup
catch {rename unknown {}}
catch {rename unknown.old unknown}
+::test::cleanupTests
return
+
diff --git a/tests/uplevel.test b/tests/uplevel.test
index f9d11ce..f79951e 100644
--- a/tests/uplevel.test
+++ b/tests/uplevel.test
@@ -6,13 +6,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: uplevel.test,v 1.1.2.2 1998/09/24 23:59:39 stanton Exp $
+# RCS: @(#) $Id: uplevel.test,v 1.1.2.3 1999/03/11 18:50:16 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
proc a {x y} {
newset z [expr $x+$y]
@@ -107,4 +110,8 @@ proc a3 {} {
a2
test uplevel-5.1 {info level} {set x} 1
test uplevel-5.2 {info level} {set y} a3
+
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/upvar.test b/tests/upvar.test
index cc934cd..cd6c82e 100644
--- a/tests/upvar.test
+++ b/tests/upvar.test
@@ -6,13 +6,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: upvar.test,v 1.1.2.2 1998/09/24 23:59:39 stanton Exp $
+# RCS: @(#) $Id: upvar.test,v 1.1.2.3 1999/03/11 18:50:17 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test upvar-1.1 {reading variables with upvar} {
proc p1 {a b} {set c 22; set d 33; p2}
@@ -396,4 +399,7 @@ if {[info commands testupvar] != {}} {
}
catch {unset a}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/utf.test b/tests/utf.test
index 9175ba8..0fadca3 100644
--- a/tests/utf.test
+++ b/tests/utf.test
@@ -3,15 +3,15 @@
# errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) utf.test 1.7 98/01/15 18:41:53
-#
+# RCS: @(#) $Id: utf.test,v 1.1.2.4 1999/03/11 18:50:17 hershey Exp $
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} {
@@ -257,7 +257,7 @@ test utf-23.1 {TclUniCharIsDigit} {
test utf-23.1 {TclUniCharIsSpace} {
} {}
-
+# cleanup
+::test::cleanupTests
return
-
diff --git a/tests/util.test b/tests/util.test
index f21a655..8980f32 100644
--- a/tests/util.test
+++ b/tests/util.test
@@ -2,11 +2,12 @@
# This file is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1995-1998 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: util.test,v 1.1.2.3 1998/12/04 03:01:27 stanton Exp $
+# RCS: @(#) $Id: util.test,v 1.1.2.4 1999/03/11 18:50:18 hershey Exp $
if {[info commands testobj] == {}} {
puts "This application hasn't been compiled with the \"testobj\""
@@ -14,7 +15,9 @@ if {[info commands testobj] == {}} {
return
}
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test util-1.1 {TclFindElement procedure - binary element in middle of list} {
lindex {0 foo\x00help 1} 1
@@ -285,4 +288,7 @@ test util-7.4 {TclPrecTraceProc - write traces, bogus values} {
set tcl_precision 12
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/var.test b/tests/var.test
index e952d6c..ff125f9 100644
--- a/tests/var.test
+++ b/tests/var.test
@@ -9,14 +9,17 @@
# errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: var.test,v 1.1.2.4 1999/02/10 23:31:24 stanton Exp $
+# RCS: @(#) $Id: var.test,v 1.1.2.5 1999/03/11 18:50:18 hershey Exp $
#
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
catch {rename p ""}
catch {namespace delete test_ns_var}
@@ -590,4 +593,7 @@ catch {unset a}
catch {unset xxxxx}
catch {unset aaaaa}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/while-old.test b/tests/while-old.test
index 49d849c..14f66df 100644
--- a/tests/while-old.test
+++ b/tests/while-old.test
@@ -8,13 +8,16 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: while-old.test,v 1.1.2.2 1998/09/24 23:59:40 stanton Exp $
+# RCS: @(#) $Id: while-old.test,v 1.1.2.3 1999/03/11 18:50:19 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
test while-old-1.1 {basic while loops} {
set count 0
@@ -112,4 +115,7 @@ test while-old-5.2 {while return result} {
while {$x} {set x 0}
} {}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/while.test b/tests/while.test
index e9a0ba6..1013fcd 100644
--- a/tests/while.test
+++ b/tests/while.test
@@ -5,13 +5,16 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: while.test,v 1.1.2.2 1998/09/24 23:59:40 stanton Exp $
+# RCS: @(#) $Id: while.test,v 1.1.2.3 1999/03/11 18:50:19 hershey Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
# Basic "while" operation.
@@ -602,4 +605,7 @@ test while-6.5 {continue tests, long command body with computed command names} {
set a
} {1 3}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/winFCmd.test b/tests/winFCmd.test
index 6508524..da27388 100644
--- a/tests/winFCmd.test
+++ b/tests/winFCmd.test
@@ -10,15 +10,18 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: winFCmd.test,v 1.1.2.3 1999/02/10 23:31:24 stanton Exp $
+# RCS: @(#) $Id: winFCmd.test,v 1.1.2.4 1999/03/11 18:50:19 hershey Exp $
#
-if {[string compare test [info procs test]] == 1} then {source defs}
-
if {$tcl_platform(platform) != "windows"} {
+ puts "skipping: Windows only tests..."
return
}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
+
proc createfile {file {string a}} {
set f [open $file w]
puts -nonewline $f $string
@@ -45,8 +48,8 @@ proc cleanup {args} {
}
}
-set testConfig(cdrom) 0
-set testConfig(exdev) 0
+set ::test::testConfig(cdrom) 0
+set ::test::testConfig(exdev) 0
# find a CD-ROM so we can test read-only filesystems.
@@ -89,7 +92,7 @@ if {$cdrom == ""} {
puts "Couldn't find a CD-ROM. Skipping tests that access CD-ROM."
puts "If you have a CD-ROM, insert a data disk and rerun tests."
} else {
- set testConfig(cdrom) 1
+ set ::test::testConfig(cdrom) 1
set cdfile [findfile $cdrom]
}
@@ -97,17 +100,17 @@ if {[file exists c:/] && [file exists d:/]} {
catch {file delete d:/tf1}
if {[catch {close [open d:/tf1 w]}] == 0} {
file delete d:/tf1
- set testConfig(exdev) 1
+ set ::test::testConfig(exdev) 1
}
}
file delete -force -- td1
set foo [catch {open td1 w} testfile]
if {$foo} {
- set testConfig(longFileNames) 0
+ set ::test::testConfig(longFileNames) 0
} else {
close $testfile
- set testConfig(longFileNames) 1
+ set ::test::testConfig(longFileNames) 1
file delete -force -- td1
}
@@ -136,7 +139,7 @@ test winFCmd-1.2 {TclpRenameFile: errno: EEXIST} {
file mkdir td2
list [catch {testfile mv td2 td1/td2} msg] $msg
} {1 EEXIST}
-test winFCmd-1.3 {TclpRenameFile: errno: EINVAL} {!$testConfig(win32s) || ("[lindex [file split [pwd]] end]" == "C:/")} {
+test winFCmd-1.3 {TclpRenameFile: errno: EINVAL} {!$::test::testConfig(win32s) || ("[lindex [file split [pwd]] end]" == "C:/")} {
# Don't run this test under Win32s on a drive mounted from an NT
# machine; it causes the NT machine to die.
@@ -249,7 +252,7 @@ test winFCmd-1.23 {TclpRenameFile: move dir into self} {
file mkdir td1
list [catch {testfile mv [pwd]/td1 td1/td2} msg] $msg
} {1 EINVAL}
-test winFCmd-1.24 {TclpRenameFile: move a root dir} {!$testConfig(win32s) || ("[lindex [file split [pwd]] end]" == "C:/")} {
+test winFCmd-1.24 {TclpRenameFile: move a root dir} {!$::test::testConfig(win32s) || ("[lindex [file split [pwd]] end]" == "C:/")} {
# Don't run this test under Win32s on a drive mounted from an NT
# machine; it causes the NT machine to die! Neat security hole in NT.
@@ -975,4 +978,7 @@ foreach source {tef ted tnf tnd "" nul com1} {
}
}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/winFile.test b/tests/winFile.test
index 10bfd11..34cef25 100644
--- a/tests/winFile.test
+++ b/tests/winFile.test
@@ -5,21 +5,22 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) winFile.test 1.3 97/12/08 15:07:46
-#
-
-if {[info procs test] != "test"} {
- source defs
-}
+# RCS: @(#) $Id: winFile.test,v 1.1.2.3 1999/03/11 18:50:20 hershey Exp $
if {$tcl_platform(platform) != "windows"} {
+ puts "skipping: Windows only tests..."
return
}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
+
test winFile-1.1 {TclpGetUserHome} {
list [catch {glob ~nosuchuser} msg] $msg
} {1 {user "nosuchuser" doesn't exist}}
@@ -51,4 +52,7 @@ test winFile-1.3 {TclpGetUserHome} {nt nonportable} {
catch {glob ~stanton@workgroup}
} {0}
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/winNotify.test b/tests/winNotify.test
index 28429f9..5f86443 100644
--- a/tests/winNotify.test
+++ b/tests/winNotify.test
@@ -5,18 +5,22 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: winNotify.test,v 1.1.2.2 1998/09/24 23:59:40 stanton Exp $
-
-if {[string compare test [info procs test]] == 1} then {source defs}
+# RCS: @(#) $Id: winNotify.test,v 1.1.2.3 1999/03/11 18:50:20 hershey Exp $
if {$tcl_platform(platform) != "windows"} {
+ puts "skipping: Windows only tests..."
return
}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
+
# There is no explicit test for InitNotifier or NotifierExitHandler
test winNotify-1.1 {Tcl_SetTimer: positive timeout} {
@@ -153,4 +157,8 @@ test winNotify-3.8 {NotifierProc: modal idle timer, rescheduled} {
} {1 1}
# Tcl_DoOneEvent is tested by the timer.test, io.test, and event.test files
+
+# cleanup
+::test::cleanupTests
return
+
diff --git a/tests/winPipe.test b/tests/winPipe.test
index 25e4b09..4cdcc55 100644
--- a/tests/winPipe.test
+++ b/tests/winPipe.test
@@ -7,13 +7,24 @@
# errors. No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: winPipe.test,v 1.1.2.4 1999/02/10 23:31:24 stanton Exp $
+# RCS: @(#) $Id: winPipe.test,v 1.1.2.5 1999/03/11 18:50:21 hershey Exp $
-if {($tcl_platform(platform) != "windows") || ($testConfig(stdio) == 0)} {
+if {$tcl_platform(platform) != "windows"} {
+ puts "skipping: Windows only tests..."
+ return
+}
+
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
+
+if {$::test::testConfig(stdio) == 0} {
+ puts "skipping: requires another copy of tcltest under win32s..."
return
}
@@ -21,12 +32,10 @@ set bindir [file join [pwd] [file dirname [info nameofexecutable]]]
set cat16 [file join $bindir cat16.exe]
set cat32 [file join $bindir cat32.exe]
-if {[string compare test [info procs test]] == 1} then {source defs}
-
if [catch {puts console1 ""}] {
- set testConfig(AllocConsole) 1
+ set ::test::testConfig(AllocConsole) 1
} else {
- set testConfig(.console) 1
+ set ::test::testConfig(.console) 1
}
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
@@ -60,7 +69,7 @@ puts $f {
}
close $f
-if {$testConfig(stdio) && [file exists $cat32]} {
+if {$::test::testConfig(stdio) && [file exists $cat32]} {
test winpipe-1.1 {32 bit comprehensive tests: from little file} {
exec $cat32 < little > stdout 2> stderr
list [contents stdout] [contents stderr]
@@ -332,7 +341,7 @@ test winpipe-4.4 {TclpCreateTempFile: TEMP specifies non-existent directory} {
set x {}
} {}
-if {$testConfig(stdio) && [file exists $cat32]} {
+if {$::test::testConfig(stdio) && [file exists $cat32]} {
test winpipe-5.1 {PipeSetupProc & PipeCheckProc: read threads} {
set f [open "|$cat32" r+]
fconfigure $f -blocking 0
@@ -387,5 +396,8 @@ if {[catch {set env(TEMP) $env_temp}]} {
unset env(TEMP)
}
+# cleanup
file delete big little stdout stderr nothing echoArgs.tcl
+::test::cleanupTests
return
+