diff options
author | hershey <hershey> | 1999-03-11 18:49:22 (GMT) |
---|---|---|
committer | hershey <hershey> | 1999-03-11 18:49:22 (GMT) |
commit | 07d6012fb42480a22f42f53b9d73eb838d5c67d7 (patch) | |
tree | 0462404b0b65394e3ef76acdc52cc18966fb9789 | |
parent | 4a327a6afdf45b23c8606d5f3d5a51b2b7876384 (diff) | |
download | tcl-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.
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 + |