summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorhershey <hershey>1999-03-11 18:50:35 (GMT)
committerhershey <hershey>1999-03-11 18:50:35 (GMT)
commit95793f0a86f9a589b52f49eee1af88cad60d3815 (patch)
tree7ac15d9a4b9c10b48e56cb919ad0cab43610f7c5
parent69ee2609ee8597545759c164761f5ee1b2dc288a (diff)
downloadtk-95793f0a86f9a589b52f49eee1af88cad60d3815.zip
tk-95793f0a86f9a589b52f49eee1af88cad60d3815.tar.gz
tk-95793f0a86f9a589b52f49eee1af88cad60d3815.tar.bz2
Updated the testsuite to use "test" namespace and commandline args
to control verbose level and which tests get run. Tests now work from any working dir.
-rw-r--r--tests/README268
-rw-r--r--tests/all77
-rw-r--r--tests/all.tcl71
-rw-r--r--tests/bell.test16
-rw-r--r--tests/bgerror.test15
-rw-r--r--tests/bind.test16
-rw-r--r--tests/bitmap.test15
-rw-r--r--tests/border.test15
-rw-r--r--tests/button.test15
-rw-r--r--tests/canvImg.test15
-rw-r--r--tests/canvPs.test17
-rw-r--r--tests/canvRect.test15
-rw-r--r--tests/canvText.test14
-rw-r--r--tests/canvWind.test17
-rw-r--r--tests/canvas.test16
-rw-r--r--tests/clipboard.test15
-rw-r--r--tests/clrpick.test15
-rw-r--r--tests/cmds.test15
-rw-r--r--tests/color.test19
-rw-r--r--tests/config.test14
-rw-r--r--tests/cursor.test15
-rw-r--r--tests/defs392
-rw-r--r--tests/defs.tcl915
-rw-r--r--tests/entry.test16
-rw-r--r--tests/event.test15
-rw-r--r--tests/filebox.test19
-rw-r--r--tests/focus.test16
-rw-r--r--tests/focusTcl.test15
-rw-r--r--tests/font.test18
-rw-r--r--tests/frame.test15
-rw-r--r--tests/geometry.test17
-rw-r--r--tests/get.test15
-rw-r--r--tests/grid.test15
-rw-r--r--tests/id.test15
-rw-r--r--tests/image.test15
-rw-r--r--tests/imgBmap.test15
-rw-r--r--tests/imgPPM.test15
-rw-r--r--tests/imgPhoto.test27
-rw-r--r--tests/listbox.test15
-rw-r--r--tests/macEmbed.test16
-rw-r--r--tests/macFont.test20
-rw-r--r--tests/macMenu.test16
-rw-r--r--tests/macWinMenu.test15
-rw-r--r--tests/macscrollbar.test21
-rw-r--r--tests/main.test17
-rw-r--r--tests/menu.test18
-rw-r--r--tests/menuDraw.test18
-rw-r--r--tests/menubut.test14
-rw-r--r--tests/msgbox.test15
-rw-r--r--tests/obj.test14
-rw-r--r--tests/oldpack.test17
-rw-r--r--tests/option.test29
-rw-r--r--tests/pack.test16
-rw-r--r--tests/place.test16
-rw-r--r--tests/raise.test16
-rw-r--r--tests/safe.test14
-rw-r--r--tests/scale.test15
-rw-r--r--tests/scrollbar.test16
-rw-r--r--tests/select.test34
-rw-r--r--tests/send.test23
-rw-r--r--tests/text.test16
-rw-r--r--tests/textBTree.test17
-rw-r--r--tests/textDisp.test21
-rw-r--r--tests/textImage.test24
-rw-r--r--tests/textIndex.test16
-rw-r--r--tests/textMark.test17
-rw-r--r--tests/textTag.test17
-rw-r--r--tests/textWind.test16
-rw-r--r--tests/tk.test15
-rw-r--r--tests/unixButton.test16
-rw-r--r--tests/unixEmbed.test16
-rw-r--r--tests/unixFont.test15
-rw-r--r--tests/unixMenu.test15
-rw-r--r--tests/unixSend.test25
-rw-r--r--tests/unixWm.test17
-rw-r--r--tests/util.test16
-rw-r--r--tests/visual.test15
-rw-r--r--tests/winButton.test15
-rw-r--r--tests/winClipboard.test15
-rw-r--r--tests/winDialog.test18
-rw-r--r--tests/winFont.test15
-rw-r--r--tests/winMenu.test19
-rw-r--r--tests/winSend.test15
-rw-r--r--tests/winWm.test16
-rw-r--r--tests/window.test15
-rw-r--r--tests/winfo.test15
-rw-r--r--tests/xmfbox.test13
87 files changed, 2036 insertions, 1059 deletions
diff --git a/tests/README b/tests/README
index 5aaea27..4f75cdb 100644
--- a/tests/README
+++ b/tests/README
@@ -1,30 +1,238 @@
-Tk Test Suite
---------------
-
-RCS: @(#) $Id: README,v 1.1.4.1 1998/09/30 02:18:21 stanton Exp $
-
-This directory contains a set of validation tests for Tk.
-Each of the files whose name ends in ".test" is intended to
-fully exercise one or a few Tk features. The features
-tested by a given file are listed in the first line of the
-file. The test suite is nowhere near complete yet. Contributions
-of additional tests would be most welcome.
-
-You can run the tests in two ways:
- (a) type "make test" in the directory ../unix; this will run all of
- the tests.
- (b) start up tktest in this directory, then "source" the test
- file (for example, type "source pack.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.
-
-For more details on the testing environment, see the README
-file in the Tcl test directory.
-
-You can also run a set of visual tests, which create various screens
-that you can verify visually for appropriate behavior. The visual
-tests are available through the "visual" script: if you invoke this
-script, it creates a main window with a bunch of menus. Each menu
-runs a particular test.
+README -- Tk test suite design document.
+
+RCS: @(#) $Id: README,v 1.1.4.2 1999/03/11 18:50:35 hershey Exp $
+
+
+Introduction:
+-------------
+
+This directory contains a set of validation tests for the Tk
+commands. Each of the files whose name ends in ".test" is
+intended to fully exercise one or a few Tk commands. The
+commands tested by a given file are listed in the first line
+of the file.
+
+You can run the tests in three ways:
+
+ (a) type "make test" in ../unix; this will run all of the tests.
+
+ (b) type "tktest <testFile> ?<option> <value>?
+
+ (c) start up tktest in this directory, then "source" the test
+ file (for example, type "source parse.test"). To run all
+ of the tests, type "source all.tcl".
+
+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.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 setupbg dobg bgReady cleanupbg fixfocus
+
+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 tktest was called. Please note that when
+you run the test suite by calling "make test", the working dir is
+<tk8.1>/tests.
+
+
+Test output:
+------------
+
+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:
+
+ tktest select.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:
+
+ tktest all.tcl -file canv*.test
+
+all files in <tk8.1>/tests that match the pattern canv*.test will be
+sourced by the all.tcl file. Another useful example is if a
+particular test hangs, say "grid.test", and you just want to run the
+remaining tests, then you can call the following:
+
+ tktest all.tcl -file [h-z]*.test
+
+Note that the argument to -file will be substituted relative to the
+directory containing this file.
+
+
+Selecting tests for execution within a file:
+--------------------------------------------
+
+Normally, all the tests in a file are run whenever the file is
+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.
+
+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:
+
+ tktest select.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:
+
+ tktest 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:
+
+ tktest <Tk8.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 Tk 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"}]
+
+
+Saving keystrokes:
+------------------
+
+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 ::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 Tk versions:
+------------------------------------------
+
+1) Global variables such as VERBOSE, TESTS, and testConfig are now
+ renamed to use the new "test" namespace.
+
+ old name new name
+ -------- --------
+ VERBOSE ::test::verbose
+ TESTS ::test::matchingTests
+ testConfig ::test::testConfig
+
+ The introduction of the "test" namespace is a precursor to using a
+ "test" package. This next step will be part of a future Tk
+ version.
+
+2) VERBOSE values are no longer numeric. Please see the section above
+ on "Test output" for the new usage of the ::test::verbose variable.
+
+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
+ <tk8.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 tktest command
+ line with the -tmpdir option.
diff --git a/tests/all b/tests/all
deleted file mode 100644
index 6ca20b5..0000000
--- a/tests/all
+++ /dev/null
@@ -1,77 +0,0 @@
-# This file contains a top-level script to run all of the Tcl
-# tests. Execute it by invoking "source all" when running tclTest
-# in this directory.
-#
-# RCS: @(#) $Id: all,v 1.1.4.3 1998/12/10 03:43:54 stanton Exp $
-
-set TESTS_DIR [file join [pwd] [file dirname [info script]]]
-source [file join $TESTS_DIR defs]
-set currentDir [pwd]
-
-catch {array set flag $argv}
-set requiredSourceFiles [list arc.tcl bugs.tcl butGeom2.tcl \
- canvPsBmap.tcl canvPsText.tcl bevel.tcl butGeom.tcl \
- canvPsArc.tcl canvPsGrph.tcl cmap.tcl filebox.test \
- option.file1 option.file2 visual README defs]
-
-#
-# Set the TMP_DIR to pwd or the arg of -tmpdir, if given.
-#
-
-if {[info exists flag(-tmpdir)]} {
- set TMP_DIR $flag(-tmpdir)
- if {![file exists $TMP_DIR]} {
- if {[catch {file mkdir $TMP_DIR} msg]} {
- error "bad argument \"$flag(-tmpdir)\" to -tmpdir:\n$msg"
- }
- file mkdir $TMP_DIR
- } elseif {![file isdir $TMP_DIR]} {
- error "bad argument \"$flag(-tmpdir)\" to -tmpdir:\n$TMP_DIR is not a directory"
- }
- if {[string compare [file pathtype $TMP_DIR] absolute] != 0} {
- set TMP_DIR [file join [pwd] $TMP_DIR]
- }
- cd $TMP_DIR
-}
-
-#
-# copy each required source file to the current dir (if it's not already there).
-#
-
-if {[string compare $TESTS_DIR [pwd]] != 0} {
-
- foreach file $requiredSourceFiles {
- if {![file exists $file]} {
- catch {file copy [file join $TESTS_DIR $file] .}
- }
- }
-}
-
-if {$tcl_platform(os) == "Win32s"} {
- set globPattern [file join $TESTS_DIR *.tes]
-} else {
- set globPattern [file join $TESTS_DIR *.test]
-}
-
-foreach file [lsort [glob $globPattern]] {
- 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
- }
-}
-
-# remove the required source files from the current dir.
-if {[info exists TMP_DIR]} {
- foreach file $requiredSourceFiles {
- catch {file delete -force $file}
- }
- cd $currentDir
-}
-
-catch {destroy .}
-exit
diff --git a/tests/all.tcl b/tests/all.tcl
new file mode 100644
index 0000000..600be5b
--- /dev/null
+++ b/tests/all.tcl
@@ -0,0 +1,71 @@
+# all.tcl --
+#
+# This file contains a top-level script to run all of the Tk
+# tests. Execute it by invoking "source all.tcl" when running tktest
+# 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:50:36 hershey Exp $
+
+# extra files: arc.tcl bugs.tcl butGeom2.tcl \
+# canvPsBmap.tcl canvPsText.tcl bevel.tcl butGeom.tcl \
+# canvPsArc.tcl canvPsGrph.tcl cmap.tcl filebox.test \
+# visual
+
+# trouble files: unixWm.test filebox.test
+
+if {[lsearch ::test [namespace children]] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
+puts stdout "Tk 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]"
+
+catch {destroy .}
+exit
diff --git a/tests/bell.test b/tests/bell.test
index 1bf62c6..9fc3ede 100644
--- a/tests/bell.test
+++ b/tests/bell.test
@@ -2,15 +2,13 @@
# It is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 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.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: bell.test,v 1.1.4.1 1998/09/30 02:18:22 stanton Exp $
+# RCS: @(#) $Id: bell.test,v 1.1.4.2 1999/03/11 18:50:36 hershey Exp $
-if {[string compare test [info procs test]] == 1} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
test bell-1.1 {bell command} {
@@ -32,3 +30,7 @@ test bell-1.4 {bell command} {
after 200
bell
} {}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/bgerror.test b/tests/bgerror.test
index c99f216..dff98f5 100644
--- a/tests/bgerror.test
+++ b/tests/bgerror.test
@@ -2,17 +2,15 @@
# It is organized in the standard fashion for Tcl tests.
#
# 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.
-#
-# RCS: @(#) $Id: bgerror.test,v 1.1.4.1 1998/09/30 02:18:23 stanton Exp $
+# RCS: @(#) $Id: bgerror.test,v 1.1.4.2 1999/03/11 18:50:36 hershey Exp $
-if {[info commands test] == ""} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
-
test bgerror-1.1 {bgerror / tkerror compat} {
set errRes {}
proc tkerror {err} {
@@ -57,3 +55,6 @@ catch {rename tkerror {}}
# would be needed too, but that's not easy at all
# to emulate.
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/bind.test b/tests/bind.test
index 581abac..48e39d5 100644
--- a/tests/bind.test
+++ b/tests/bind.test
@@ -4,15 +4,13 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-1995 Sun Microsystems, Inc.
-# Copyright (c) 1998 by Scriptics Corporation.
+# 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.
-#
-# RCS: @(#) $Id: bind.test,v 1.1.4.3 1998/11/25 21:16:39 stanton Exp $
+# RCS: @(#) $Id: bind.test,v 1.1.4.4 1999/03/11 18:50:37 hershey Exp $
-if {[string compare test [info procs test]] != 0} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
catch {destroy .b}
@@ -2569,3 +2567,7 @@ test bind-31.2 {MouseWheel events} {
destroy .b
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/bitmap.test b/tests/bitmap.test
index 6975f86..af4e542 100644
--- a/tests/bitmap.test
+++ b/tests/bitmap.test
@@ -3,14 +3,13 @@
# Tcl tests.
#
# Copyright (c) 1998 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.
-#
-# RCS: @(#) $Id: bitmap.test,v 1.1.2.2 1998/09/30 02:18:24 stanton Exp $
+# RCS: @(#) $Id: bitmap.test,v 1.1.2.3 1999/03/11 18:50:37 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]
}
if {[info commands testbitmap] != "testbitmap"} {
@@ -97,3 +96,7 @@ test bitmap-4.1 {FreeBitmapObjProc} {
} {{{1 3}} {{1 2}} {{1 1}} {}}
destroy .t
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/border.test b/tests/border.test
index 835a807..a299392 100644
--- a/tests/border.test
+++ b/tests/border.test
@@ -2,14 +2,13 @@
# tkBorder.c. It is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1998 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.
-#
-# RCS: @(#) $Id: border.test,v 1.1.2.2 1998/09/30 02:18:25 stanton Exp $
+# RCS: @(#) $Id: border.test,v 1.1.2.3 1999/03/11 18:50:38 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]
}
if {[info commands testborder] != "testborder"} {
@@ -174,3 +173,7 @@ test get-2.4 {Tk_GetReliefFromObj - error} {
} {1 {bad relief "upanddown": must be flat, groove, raised, ridge, solid, or sunken}}
destroy .t
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/button.test b/tests/button.test
index 0f3c494..24d6111 100644
--- a/tests/button.test
+++ b/tests/button.test
@@ -4,11 +4,10 @@
#
# Copyright (c) 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.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: button.test,v 1.1.4.2 1998/09/30 02:18:26 stanton Exp $
+# RCS: @(#) $Id: button.test,v 1.1.4.3 1999/03/11 18:50:38 hershey Exp $
if {[lsearch [image types] test] < 0} {
puts "This application hasn't been compiled with the \"test\""
@@ -17,8 +16,8 @@ if {[lsearch [image types] test] < 0} {
return
}
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
foreach i [winfo children .] {
@@ -779,3 +778,7 @@ test button-13.1 {button widget vs hidden commands} {
eval destroy [winfo children .]
option clear
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/canvImg.test b/tests/canvImg.test
index dbd9031..61cffc0 100644
--- a/tests/canvImg.test
+++ b/tests/canvImg.test
@@ -4,11 +4,10 @@
#
# Copyright (c) 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.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: canvImg.test,v 1.1.4.1 1998/09/30 02:18:27 stanton Exp $
+# RCS: @(#) $Id: canvImg.test,v 1.1.4.2 1999/03/11 18:50:39 hershey Exp $
if {[lsearch [image types] test] < 0} {
puts "This application hasn't been compiled with the \"test\" image"
@@ -17,8 +16,8 @@ if {[lsearch [image types] test] < 0} {
return
}
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
foreach i [winfo children .] {
@@ -395,3 +394,7 @@ test canvImg-11.3 {ImageChangedProc procedure} {
update
set y
} {{foo2 display 0 0 20 40 50 40}}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/canvPs.test b/tests/canvPs.test
index 2087a31..a4da7f7 100644
--- a/tests/canvPs.test
+++ b/tests/canvPs.test
@@ -3,14 +3,13 @@
# TkCanvPostscriptCmd in generic/tkCanvPs.c
#
# Copyright (c) 1995 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.
-#
-# RCS: @(#) $Id: canvPs.test,v 1.1.4.1 1998/09/30 02:18:27 stanton Exp $
+# RCS: @(#) $Id: canvPs.test,v 1.1.4.2 1999/03/11 18:50:40 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]
}
foreach i [winfo children .] {
@@ -95,11 +94,11 @@ test canvPs-2.4 {test writing to channel and file, same output} {pcOnly} {
set status
} ok
-# Clean-up
-
+# cleanup
removeFile foo.ps
removeFile bar.ps
-
foreach i [winfo children .] {
destroy $i
}
+::test::cleanupTests
+return
diff --git a/tests/canvRect.test b/tests/canvRect.test
index d6d050f..5a2a34f 100644
--- a/tests/canvRect.test
+++ b/tests/canvRect.test
@@ -3,14 +3,13 @@
# in the standard fashion for Tcl tests.
#
# Copyright (c) 1994-1996 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.
-#
-# RCS: @(#) $Id: canvRect.test,v 1.1.4.1 1998/09/30 02:18:29 stanton Exp $
+# RCS: @(#) $Id: canvRect.test,v 1.1.4.2 1999/03/11 18:50:40 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]
}
foreach i [winfo children .] {
@@ -327,3 +326,7 @@ restore showpage
end
%%EOF
}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/canvText.test b/tests/canvText.test
index 3de8813..38de088 100644
--- a/tests/canvText.test
+++ b/tests/canvText.test
@@ -3,14 +3,13 @@
# fashion for Tcl tests.
#
# Copyright (c) 1996-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.
-#
-# RCS: @(#) $Id: canvText.test,v 1.1.4.3 1998/11/25 21:16:40 stanton Exp $
+# RCS: @(#) $Id: canvText.test,v 1.1.4.4 1999/03/11 18:50:41 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]
}
foreach i [winfo children .] {
@@ -491,3 +490,6 @@ restore showpage
end
%%EOF
"
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/canvWind.test b/tests/canvWind.test
index 0791998..0038dac 100644
--- a/tests/canvWind.test
+++ b/tests/canvWind.test
@@ -3,14 +3,13 @@
# fashion for Tcl tests.
#
# 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.
-#
-# RCS: @(#) $Id: canvWind.test,v 1.1.4.2 1999/02/16 11:39:35 lfb Exp $
+# RCS: @(#) $Id: canvWind.test,v 1.1.4.3 1999/03/11 18:50:41 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]
}
foreach i [winfo children .] {
@@ -131,4 +130,8 @@ test canvWind-1.4 {DisplayWinItem, windows off-screen horizontally} {
update
lappend x [list [winfo ismapped $f] [winfo x $f]]
} {{1 3} {1 -79} {0 -79} {1 255} {0 255}}
-catch {destroy .t} \ No newline at end of file
+catch {destroy .t}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/canvas.test b/tests/canvas.test
index 5807b52..7eb96c6 100644
--- a/tests/canvas.test
+++ b/tests/canvas.test
@@ -3,15 +3,13 @@
# standard fashion for Tcl tests.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998 by Scriptics Corporation.
+# 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.
-#
-# RCS: @(#) $Id: canvas.test,v 1.1.4.3 1998/11/25 21:16:40 stanton Exp $
+# RCS: @(#) $Id: canvas.test,v 1.1.4.4 1999/03/11 18:50:42 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]
}
foreach i [winfo children .] {
@@ -245,3 +243,7 @@ test canvas-9.1 {canvas id creation and deletion} {
set x ""
} {}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/clipboard.test b/tests/clipboard.test
index b2f19d4..08e3f1e 100644
--- a/tests/clipboard.test
+++ b/tests/clipboard.test
@@ -3,19 +3,18 @@
# fashion for Tcl tests.
#
# Copyright (c) 1994 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.
-#
-# RCS: @(#) $Id: clipboard.test,v 1.1.4.1 1998/09/30 02:18:31 stanton Exp $
+# RCS: @(#) $Id: clipboard.test,v 1.1.4.2 1999/03/11 18:50:42 hershey Exp $
#
# Note: Multiple display clipboard handling will only be tested if the
# environment variable TK_ALT_DISPLAY is set to an alternate display.
#
-if {[string compare test [info procs test]] == 1} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
eval destroy [winfo child .]
@@ -232,3 +231,7 @@ test clipboard-7.13 {Tk_ClipboardCmd procedure} {
test clipboard-7.14 {Tk_ClipboardCmd procedure} {
list [catch {clipboard error} msg] $msg
} {1 {bad option "error": must be clear or append}}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/clrpick.test b/tests/clrpick.test
index 133b333..7f2ca75 100644
--- a/tests/clrpick.test
+++ b/tests/clrpick.test
@@ -2,15 +2,14 @@
# It is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1996 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.
-#
-# RCS: @(#) $Id: clrpick.test,v 1.1.4.2 1998/09/30 02:18:31 stanton Exp $
+# RCS: @(#) $Id: clrpick.test,v 1.1.4.3 1999/03/11 18:50:43 hershey Exp $
#
-if {[string compare test [info procs test]] == 1} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
test clrpick-1.1 {tk_chooseColor command} {
@@ -213,3 +212,7 @@ test clrpick-3.2 {tk_chooseColor: background events} {
ToPressButton $parent cancel
tk_chooseColor -parent $parent -title "Press Cancel"
} ""
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/cmds.test b/tests/cmds.test
index 578b06b..8c5e932 100644
--- a/tests/cmds.test
+++ b/tests/cmds.test
@@ -2,14 +2,13 @@
# tkCmds.c. It is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1996 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.
-#
-# RCS: @(#) $Id: cmds.test,v 1.1.4.1 1998/09/30 02:18:32 stanton Exp $
+# RCS: @(#) $Id: cmds.test,v 1.1.4.2 1999/03/11 18:50:43 hershey Exp $
-if {[string compare test [info procs test]] == 1} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
eval destroy [winfo child .]
@@ -41,3 +40,7 @@ test cmds-1.5 {tkwait visibility, window gets deleted} {
after 100 {set x deleted; destroy .f}
list [catch {tkwait visibility .f.b} msg] $msg $x
} {1 {window ".f.b" was deleted before its visibility changed} deleted}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/color.test b/tests/color.test
index 528c1de..876632d 100644
--- a/tests/color.test
+++ b/tests/color.test
@@ -2,21 +2,20 @@
# tkColor.c. It is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1995-1998 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.
-#
-# RCS: @(#) $Id: color.test,v 1.1.4.2 1998/09/30 02:18:32 stanton Exp $
-
-if {[info procs test] != "test"} {
- source defs
-}
+# RCS: @(#) $Id: color.test,v 1.1.4.3 1999/03/11 18:50:44 hershey Exp $
if {[info commands testcolor] != "testcolor"} {
puts "testcolor command not available; skipping tests"
return
}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
+
eval destroy [winfo children .]
wm geometry . {}
raise .
@@ -276,3 +275,7 @@ test color-4.1 {FreeColorObjProc} {
} {{{1 3}} {{1 2}} {{1 1}} {}}
destroy .t
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/config.test b/tests/config.test
index eec6634..724f0e3 100644
--- a/tests/config.test
+++ b/tests/config.test
@@ -3,11 +3,10 @@
# organized in the standard "white-box" fashion for Tcl tests.
#
# 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.
-#
-# RCS: @(#) $Id: config.test,v 1.1.2.2 1998/09/30 02:18:33 stanton Exp $
+# RCS: @(#) $Id: config.test,v 1.1.2.3 1999/03/11 18:50:45 hershey Exp $
if {[info command testobjconfig] != "testobjconfig"} {
puts "This application hasn't been compiled with the \"testobjconfig\""
@@ -16,8 +15,8 @@ if {[info command testobjconfig] != "testobjconfig"} {
return
}
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
proc killTables {} {
@@ -819,5 +818,8 @@ test config-12.16 {GetObjectForOption - null values} {
[.a cget -cursor] [.a cget -window]
} {{} {} {} {} {} {} {} {}}
+# cleanup
eval destroy [winfo children .]
killTables
+::test::cleanupTests
+return
diff --git a/tests/cursor.test b/tests/cursor.test
index 8f5af68..84c9f29 100644
--- a/tests/cursor.test
+++ b/tests/cursor.test
@@ -3,14 +3,13 @@
# Tcl tests.
#
# Copyright (c) 1998 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.
-#
-# RCS: @(#) $Id: cursor.test,v 1.1.2.2 1998/09/30 02:18:33 stanton Exp $
+# RCS: @(#) $Id: cursor.test,v 1.1.2.3 1999/03/11 18:50:45 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]
}
if {[info commands testcursor] != "testcursor"} {
@@ -97,3 +96,7 @@ test cursor-4.1 {FreeCursorObjProc} {
} {{{1 3}} {{1 2}} {{1 1}} {}}
destroy .t
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/defs b/tests/defs
deleted file mode 100644
index 8d4efda..0000000
--- a/tests/defs
+++ /dev/null
@@ -1,392 +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) 1994-1997 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.4.3 1998/12/10 03:43:54 stanton Exp $
-
-if {![info exists VERBOSE]} {
- set VERBOSE 0
-}
-if {![info exists TESTS]} {
- set TESTS {}
-}
-
-tk appname tktest
-wm title . tktest
-
-# 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).
-# fonts - 1 means that this platform uses fonts with
-# well-know geometries, so it is safe to run
-# tests that depend on particular font sizes.
-
-catch {unset testConfig}
-
-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(unixOnly) || $testConfig(pcOnly)}]
-set testConfig(macOrPc) [expr {$testConfig(macOnly) || $testConfig(pcOnly)}]
-set testConfig(macOrUnix) [expr {$testConfig(macOnly) || $testConfig(unixOnly)}]
-
-set testConfig(knownBug) [expr {[file exists doBuggyTests] || [file exists doBuggyT]}]
-set testConfig(nonPortable) [expr {[file exists doAllTests] || [file exists DOALLT~1]}]
-
-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.
-
-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(win32sCrash) [expr {!$testConfig(win32s)}]
-set testConfig(macCrash) [expr {!$testConfig(mac)}]
-set testConfig(unixCrash) [expr {!$testConfig(unix)}]
-
-set testConfig(fonts) 1
-catch {destroy .e}
-entry .e -width 0 -font {Helvetica -12} -bd 1
-.e insert end "a.bcd"
-if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} {
- set testConfig(fonts) 0
-}
-destroy .e
-catch {destroy .t}
-text .t -width 80 -height 20 -font {Times -14} -bd 1
-pack .t
-.t insert end "This is\na dot."
-update
-set x [list [.t bbox 1.3] [.t bbox 2.5]]
-destroy .t
-if {[string match {{22 3 6 15} {31 18 [34] 15}} $x] == 0} {
- set testConfig(fonts) 0
-}
-
-if {$testConfig(nonPortable) == 0} {
- puts stdout "(will skip non-portable tests)"
-}
-if {$testConfig(fonts) == 0} {
- puts stdout "(will skip font-sensitive tests: this system has unexpected font geometries)"
-}
-
-trace variable testConfig r safeFetch
-
-proc safeFetch {n1 n2 op} {
- global testConfig
-
- if {($n2 != {}) && ([info exists testConfig($n2)] == 0)} {
- set testConfig($n2) 0
- }
-}
-
-# 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 {}
-}
-
-proc print_verbose {name description script code answer} {
- puts stdout "\n"
- 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} {
- # Empty body
- } 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 $constraints]}
- } 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 code [catch {uplevel $script} result]
- if {$code != 0} {
- print_verbose $name $description $script $code $result
- } elseif {[string compare $result $answer] == 0} {
- if {$VERBOSE} {
- if {$VERBOSE > 0} {
- print_verbose $name $description $script $code $result
- }
- if {$VERBOSE != -2} {
- puts stdout "++++ $name PASSED"
- }
- }
- } else {
- print_verbose $name $description $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
-}
-
-# If the main window isn't already mapped (e.g. because the tests are
-# being run automatically) , specify a precise size for it so that the
-# user won't have to position it manually.
-
-if {![winfo ismapped .]} {
- wm geometry . +0+0
- update
-}
-
-# The following code can be used to perform tests involving a second
-# process running in the background.
-
-# Locate tktest executable
-
-set tktest [info nameofexecutable]
-if {$tktest == "{}"} {
- set tktest {}
- puts stdout "Unable to find tktest executable, skipping multiple process tests."
-}
-
-# Create background process
-
-proc setupbg args {
- global tktest fd bgData
- if {$tktest == ""} {
- error "you're not running tktest so setupbg should not have been called"
- }
- if {[info exists fd] && ($fd != "")} {
- cleanupbg
- }
- set fd [open "|[list $tktest -geometry +0+0 -name tktest] $args" r+]
- puts $fd "puts foo; flush stdout"
- flush $fd
- if {[gets $fd data] < 0} {
- error "unexpected EOF from \"$tktest\""
- }
- if {[string compare $data foo]} {
- error "unexpected output from background process \"$data\""
- }
- fileevent $fd readable bgReady
-}
-
-# Send a command to the background process, catching errors and
-# flushing I/O channels
-proc dobg {command} {
- global fd bgData bgDone
- puts $fd "catch [list $command] msg; update; puts \$msg; puts **DONE**; flush stdout"
- flush $fd
- set bgDone 0
- set bgData {}
- tkwait variable bgDone
- set bgData
-}
-
-# Data arrived from background process. Check for special marker
-# indicating end of data for this command, and make data available
-# to dobg procedure.
-proc bgReady {} {
- global fd bgData bgDone
- set x [gets $fd]
- if {[eof $fd]} {
- fileevent $fd readable {}
- set bgDone 1
- } elseif {$x == "**DONE**"} {
- set bgDone 1
- } else {
- append bgData $x
- }
-}
-
-# Exit the background process, and close the pipes
-proc cleanupbg {} {
- global fd
- catch {
- puts $fd "exit"
- close $fd
- }
- set fd ""
-}
-
-# Clean up focus after using generate event, which
-# can leave the window manager with the wrong impression
-# about who thinks they have the focus. (BW)
-
-proc fixfocus {} {
- catch {destroy .focus}
- toplevel .focus
- wm geometry .focus +0+0
- entry .focus.e
- .focus.e insert 0 "fixfocus"
- pack .focus.e
- update
- focus -force .focus.e
- destroy .focus
-}
-
-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
-}
-
-#
-# 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} {
- testencoding toutf $string identity
-}
diff --git a/tests/defs.tcl b/tests/defs.tcl
new file mode 100644
index 0000000..68b5f2c
--- /dev/null
+++ b/tests/defs.tcl
@@ -0,0 +1,915 @@
+# defs.tcl --
+#
+# This file contains support code for the Tk 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:50:47 hershey Exp $
+
+tk appname tktest
+wm title . tktest
+
+# 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 setupbg dobg bgReady cleanupbg fixfocus] {
+ 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).
+ # Note that -verbose cannot be abbreviated to -v because it conflicts
+ # with the wish option -visual.
+ foreach arg {-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.
+
+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
+}
+
+# set the "fonts" constraint
+
+set ::test::testConfig(fonts) 1
+catch {destroy .e}
+entry .e -width 0 -font {Helvetica -12} -bd 1
+.e insert end "a.bcd"
+if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} {
+ set ::test::testConfig(fonts) 0
+}
+destroy .e
+catch {destroy .t}
+text .t -width 80 -height 20 -font {Times -14} -bd 1
+pack .t
+.t insert end "This is\na dot."
+update
+set x [list [.t bbox 1.3] [.t bbox 2.5]]
+destroy .t
+if {[string match {{22 3 6 15} {31 18 [34] 15}} $x] == 0} {
+ set ::test::testConfig(fonts) 0
+}
+if {$::test::testConfig(fonts) == 0} {
+ puts stdout "(will skip font-sensitive tests: this system has unexpected font geometries)"
+}
+
+# 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)"
+ }
+
+}
+
+# If the main window isn't already mapped (e.g. because the tests are
+# being run automatically) , specify a precise size for it so that the
+# user won't have to position it manually.
+
+if {![winfo ismapped .]} {
+ wm geometry . +0+0
+ update
+}
+
+# The following code can be used to perform tests involving a second
+# process running in the background.
+
+# Locate tktest executable
+
+set ::test::tktest [info nameofexecutable]
+if {$::test::tktest == "{}"} {
+ set ::test::tktest {}
+ puts stdout "Unable to find tktest executable, skipping multiple process tests."
+}
+
+# Create background process
+
+proc ::test::setupbg args {
+ if {$::test::tktest == ""} {
+ error "you're not running tktest so setupbg should not have been called"
+ }
+ if {[info exists ::test::fd] && ($::test::fd != "")} {
+ cleanupbg
+ }
+ set ::test::fd [open "|[list $::test::tktest -geometry +0+0 -name tktest] $args" r+]
+ puts $::test::fd "puts foo; flush stdout"
+ flush $::test::fd
+ if {[gets $::test::fd data] < 0} {
+ error "unexpected EOF from \"$::test::tktest\""
+ }
+ if {[string compare $data foo]} {
+ error "unexpected output from background process \"$data\""
+ }
+ fileevent $::test::fd readable bgReady
+}
+
+# Send a command to the background process, catching errors and
+# flushing I/O channels
+proc ::test::dobg {command} {
+ puts $::test::fd "catch [list $command] msg; update; puts \$msg; puts **DONE**; flush stdout"
+ flush $::test::fd
+ set ::test::bgDone 0
+ set ::test::bgData {}
+ tkwait variable ::test::bgDone
+ set ::test::bgData
+}
+
+# Data arrived from background process. Check for special marker
+# indicating end of data for this command, and make data available
+# to dobg procedure.
+proc ::test::bgReady {} {
+ set x [gets $::test::fd]
+ if {[eof $::test::fd]} {
+ fileevent $::test::fd readable {}
+ set ::test::bgDone 1
+ } elseif {$x == "**DONE**"} {
+ set ::test::bgDone 1
+ } else {
+ append ::test::bgData $x
+ }
+}
+
+# Exit the background process, and close the pipes
+proc ::test::cleanupbg {} {
+ catch {
+ puts $::test::fd "exit"
+ close $::test::fd
+ }
+ set ::test::fd ""
+}
+
+# Clean up focus after using generate event, which
+# can leave the window manager with the wrong impression
+# about who thinks they have the focus. (BW)
+
+proc ::test::fixfocus {} {
+ catch {destroy .focus}
+ toplevel .focus
+ wm geometry .focus +0+0
+ entry .focus.e
+ .focus.e insert 0 "fixfocus"
+ pack .focus.e
+ update
+ focus -force .focus.e
+ destroy .focus
+}
+
+# Need to catch the import because it fails if defs.tcl is sourced
+# more than once.
+catch {namespace import ::test::*}
diff --git a/tests/entry.test b/tests/entry.test
index d802878..25a0ade 100644
--- a/tests/entry.test
+++ b/tests/entry.test
@@ -3,11 +3,10 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-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.
-#
-# RCS: @(#) $Id: entry.test,v 1.1.4.3 1999/02/16 11:39:35 lfb Exp $
+# RCS: @(#) $Id: entry.test,v 1.1.4.4 1999/03/11 18:50:47 hershey Exp $
if {[lsearch [image types] test] < 0} {
puts "This application hasn't been compiled with the \"test\""
@@ -16,8 +15,8 @@ if {[lsearch [image types] test] < 0} {
return
}
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
foreach i [winfo children .] {
@@ -1358,5 +1357,8 @@ test entry-18.1 {Entry widget vs hiding} {
# XXX Still need to write tests for EntryBlinkProc, EntryFocusProc,
# and EntryTextVarProc.
-
option clear
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/event.test b/tests/event.test
index 5790c6c..046b4f7 100644
--- a/tests/event.test
+++ b/tests/event.test
@@ -3,14 +3,13 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-1995 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.
-#
-# RCS: @(#) $Id: event.test,v 1.1.4.1 1998/09/30 02:18:35 stanton Exp $
+# RCS: @(#) $Id: event.test,v 1.1.4.2 1999/03/11 18:50:47 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]
}
foreach i [winfo children .] {
@@ -39,3 +38,7 @@ test event-1.1 {Tk_HandleEvent procedure, filter events for dead windows} {
destroy .b
set x
} {destroy}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/filebox.test b/tests/filebox.test
index 22646a4..aff8a68 100644
--- a/tests/filebox.test
+++ b/tests/filebox.test
@@ -3,13 +3,15 @@
# for Tcl tests.
#
# Copyright (c) 1996 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.
-#
-# RCS: @(#) $Id: filebox.test,v 1.1.4.3 1998/12/10 03:43:54 stanton Exp $
+# RCS: @(#) $Id: filebox.test,v 1.1.4.4 1999/03/11 18:50:48 hershey Exp $
#
+puts "skipping these tests: TEMPORARILY under construction"
+return
+
set tk_strictMotif_old $tk_strictMotif
#----------------------------------------------------------------------
@@ -90,8 +92,8 @@ proc SendButtonPress {parent btn type} {
#
#----------------------------------------------------------------------
-if {[string compare test [info procs test]] == 1} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
if {$tcl_platform(platform) == "unix"} {
@@ -292,5 +294,8 @@ if {$isNative && ![info exists INTERACTIVE]} {
puts " automatically on this platform. If you wish to execute them"
puts " interactively, set the TCL variable INTERACTIVE and re-run"
puts " the test."
- return
}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/focus.test b/tests/focus.test
index e8d7882..481848a 100644
--- a/tests/focus.test
+++ b/tests/focus.test
@@ -3,18 +3,18 @@
# standard fashion for Tcl tests.
#
# Copyright (c) 1994-1996 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.
-#
-# RCS: @(#) $Id: focus.test,v 1.1.4.2 1998/12/10 03:43:54 stanton Exp $
+# RCS: @(#) $Id: focus.test,v 1.1.4.3 1999/03/11 18:50:48 hershey Exp $
if {$tcl_platform(platform) != "unix"} {
+ puts "skipping: Unix only tests..."
return
}
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
eval destroy [winfo children .]
@@ -635,3 +635,7 @@ test focus-6.2 {miscellaneous - embedded application in different process} {unix
eval destroy [winfo children .]
bind all <FocusIn> {}
bind all <FocusOut> {}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/focusTcl.test b/tests/focusTcl.test
index b7ebc1f..0741a6a 100644
--- a/tests/focusTcl.test
+++ b/tests/focusTcl.test
@@ -4,14 +4,13 @@
# standard fashion for Tcl tests.
#
# Copyright (c) 1995 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.
-#
-# RCS: @(#) $Id: focusTcl.test,v 1.1.4.1 1998/09/30 02:18:36 stanton Exp $
+# RCS: @(#) $Id: focusTcl.test,v 1.1.4.2 1999/03/11 18:50:49 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]
}
eval destroy [winfo children .]
@@ -277,3 +276,7 @@ test focusTcl-5.11 {tkFocusOK procedure, -takefocus "", check for bindings} {
bind Frame <Key> {}
. configure -takefocus 0 -highlightthickness 0
option clear
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/font.test b/tests/font.test
index ce87d70..5b60f95 100644
--- a/tests/font.test
+++ b/tests/font.test
@@ -3,21 +3,20 @@
# standard white-box fashion for Tcl tests.
#
# Copyright (c) 1996-1998 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.
-#
-# RCS: @(#) $Id: font.test,v 1.1.4.2 1998/09/30 02:18:36 stanton Exp $
-
-if {[string compare test [info procs test]] != 0} {
- source defs
-}
+# RCS: @(#) $Id: font.test,v 1.1.4.3 1999/03/11 18:50:50 hershey Exp $
if {[info commands testfont] != "testfont"} {
puts "testfont command not available; skipping tests"
return
}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
+
catch {destroy .b}
toplevel .b
wm geom .b +0+0
@@ -1370,4 +1369,7 @@ test font-46.4 {TkFontGetAliasList: match} {unixOnly} {
setup
destroy .b
+
+# cleanup
+::test::cleanupTests
return
diff --git a/tests/frame.test b/tests/frame.test
index bbe38a8..048e4f7 100644
--- a/tests/frame.test
+++ b/tests/frame.test
@@ -4,14 +4,13 @@
#
# Copyright (c) 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.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: frame.test,v 1.1.4.1 1998/09/30 02:18:37 stanton Exp $
+# RCS: @(#) $Id: frame.test,v 1.1.4.2 1999/03/11 18:50:50 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]
}
foreach i [winfo children .] {
@@ -615,3 +614,7 @@ test frame-11.2 {TkInstallFrameMenu - frame renamed} {
catch {destroy .f}
rename eatColors {}
rename colorsFree {}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/geometry.test b/tests/geometry.test
index 182a67d..c06e196 100644
--- a/tests/geometry.test
+++ b/tests/geometry.test
@@ -4,14 +4,13 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994 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.
-#
-# RCS: @(#) $Id: geometry.test,v 1.1.4.1 1998/09/30 02:18:38 stanton Exp $
+# RCS: @(#) $Id: geometry.test,v 1.1.4.2 1999/03/11 18:50:51 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]
}
foreach i [winfo children .] {
@@ -247,5 +246,9 @@ test geometry-4.10 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} {
update
winfo ismapped .t.quit
} {1}
+
catch {destroy .t}
-concat
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/get.test b/tests/get.test
index c68b7e7..e787524 100644
--- a/tests/get.test
+++ b/tests/get.test
@@ -3,14 +3,13 @@
# white-box tests.
#
# Copyright (c) 1998 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.
-#
-# RCS: @(#) $Id: get.test,v 1.1.2.2 1998/09/30 02:18:39 stanton Exp $
+# RCS: @(#) $Id: get.test,v 1.1.2.3 1999/03/11 18:50:52 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]
}
eval destroy [winfo children .]
@@ -79,3 +78,7 @@ test get-2.3 {Tk_GetJustifyFromObj} {
test get-2.4 {Tk_GetJustifyFromObj - error} {
list [catch {.b configure -justify stupid} msg] $msg
} {1 {bad justification "stupid": must be left, right, or center}}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/grid.test b/tests/grid.test
index 74bbb69..716ff48 100644
--- a/tests/grid.test
+++ b/tests/grid.test
@@ -3,14 +3,13 @@
#
# Copyright (c) 1996 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.
-#
-# RCS: @(#) $Id: grid.test,v 1.1.4.2 1999/01/29 00:34:34 stanton Exp $
+# RCS: @(#) $Id: grid.test,v 1.1.4.3 1999/03/11 18:50:52 hershey Exp $
-if {[string compare test [info procs test]] == 1} then \
- {source ../tests/defs}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
# helper routine to return "." to a sane state after a test
# The variable GRID_VERBOSE can be used to "look" at the result
@@ -1212,3 +1211,7 @@ test grid-17.1 {forget and pending idle handlers} {
destroy .t
set result ok
} ok
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/id.test b/tests/id.test
index 61fb97f..b5e2311 100644
--- a/tests/id.test
+++ b/tests/id.test
@@ -3,14 +3,13 @@
# the standard fashion for Tcl tests.
#
# Copyright (c) 1995 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.
-#
-# RCS: @(#) $Id: id.test,v 1.1.4.1 1998/09/30 02:18:41 stanton Exp $
+# RCS: @(#) $Id: id.test,v 1.1.4.2 1999/03/11 18:50:53 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]
}
if {[string compare testwrapper [info commands testwrapper]] != 0} {
@@ -100,3 +99,7 @@ test id-1.1 {WindowIdCleanup, delaying window release} {unixOnly} {
lappend result [lsort $reused] [lsort $x]
} {{.f .f.a .f.b .f.c .f.d .f.e .f.f .f.g .f.h .f.i .f.j .f.k .f.l .f.m .f.n .f.o .f.p .f.q} {} {} {.f.o .f.p .f.q wrapper.f.p wrapper.f.q} {}}
bind all <Destroy> {}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/image.test b/tests/image.test
index fce2199..e483155 100644
--- a/tests/image.test
+++ b/tests/image.test
@@ -4,11 +4,10 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994 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.
-#
-# RCS: @(#) $Id: image.test,v 1.1.4.1 1998/09/30 02:18:42 stanton Exp $
+# RCS: @(#) $Id: image.test,v 1.1.4.2 1999/03/11 18:50:53 hershey Exp $
if {[lsearch [image types] test] < 0} {
puts "This application hasn't been compiled with the \"test\" image"
@@ -17,8 +16,8 @@ if {[lsearch [image types] test] < 0} {
return
}
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
foreach i [winfo children .] {
@@ -355,3 +354,7 @@ test image-13.1 {image command vs hidden commands} {
destroy .c
eval image delete [image names]
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/imgBmap.test b/tests/imgBmap.test
index 1d70d15..81ee69c 100644
--- a/tests/imgBmap.test
+++ b/tests/imgBmap.test
@@ -4,14 +4,13 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-1995 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.
-#
-# RCS: @(#) $Id: imgBmap.test,v 1.1.4.1 1998/09/30 02:18:42 stanton Exp $
+# RCS: @(#) $Id: imgBmap.test,v 1.1.4.2 1999/03/11 18:50:54 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]
}
foreach i [winfo children .] {
@@ -472,3 +471,7 @@ removeFile foo.bm
removeFile foo2.bm
destroy .c
eval image delete [image names]
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/imgPPM.test b/tests/imgPPM.test
index baed63f..567e9ae 100644
--- a/tests/imgPPM.test
+++ b/tests/imgPPM.test
@@ -3,14 +3,13 @@
# The files is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1994-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.
-#
-# RCS: @(#) $Id: imgPPM.test,v 1.1.4.1 1998/09/30 02:18:43 stanton Exp $
+# RCS: @(#) $Id: imgPPM.test,v 1.1.4.2 1999/03/11 18:50:54 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]
}
foreach i [winfo children .] {
@@ -154,3 +153,7 @@ test imgPPM-3.13 {ReadPPMFileHeader procedure, file ends too soon} {
removeFile test.ppm
removeFile test2.ppm
eval image delete [image names]
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/imgPhoto.test b/tests/imgPhoto.test
index 00dfe97..6fcefbb 100644
--- a/tests/imgPhoto.test
+++ b/tests/imgPhoto.test
@@ -4,16 +4,15 @@
#
# Copyright (c) 1994 The Australian National University
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
#
# Author: Paul Mackerras (paulus@cs.anu.edu.au)
#
-# RCS: @(#) $Id: imgPhoto.test,v 1.1.4.2 1998/12/10 03:43:54 stanton Exp $
+# RCS: @(#) $Id: imgPhoto.test,v 1.1.4.3 1999/03/11 18:50:55 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]
}
foreach i [winfo children .] {
@@ -28,13 +27,20 @@ canvas .c
pack .c
update
+# temporarily copy the README fiel from testsDir to tmpDir
+if {![file exists README]} {
+ set newREADME [file join $::test::tmpDir README]
+ file copy [file join $::test::testsDir README] $newREADME
+ set removeREADME 1
+}
+
# find the teapot.ppm file for use in these tests
# first look in $tk_library/demos/images/teapot.ppm
# then look in <this file>/../../library/demos/images/teapot.ppm
# skip this file if you can't find the teapot.ppm file.
set teapotPhotoFile [file join $tk_library demos images teapot.ppm]
if {![file exists $teapotPhotoFile]} {
- set newLib [file dirname [file dirname [info script]]]
+ set newLib [file dirname $::test::testsDir]
set teapotPhotoFile \
[file join $newLib library demos images teapot.ppm]
if {![file exists $teapotPhotoFile]} {
@@ -432,3 +438,10 @@ test imgPhoto-13.1 {check separation of images in different interpreters} {
destroy .c
eval image delete [image names]
+
+# cleanup
+if {[info exists removeREADME]} {
+ catch {file delete -force $newREADME}
+}
+::test::cleanupTests
+return
diff --git a/tests/listbox.test b/tests/listbox.test
index 2eed971..06e051c 100644
--- a/tests/listbox.test
+++ b/tests/listbox.test
@@ -3,14 +3,14 @@
#
# Copyright (c) 1993-1994 The Regents of the University of California.
# Copyright (c) 1994-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.
-#
-# RCS: @(#) $Id: listbox.test,v 1.1.4.1 1998/09/30 02:18:44 stanton Exp $
+# RCS: @(#) $Id: listbox.test,v 1.1.4.2 1999/03/11 18:50: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]
+}
foreach i [winfo children .] {
destroy $i
@@ -1656,3 +1656,6 @@ catch {destroy .e}
catch {destroy .partial}
option clear
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/macEmbed.test b/tests/macEmbed.test
index 89c831c..8d23015 100644
--- a/tests/macEmbed.test
+++ b/tests/macEmbed.test
@@ -3,18 +3,18 @@
# tests.
#
# 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.
-#
-# RCS: @(#) $Id: macEmbed.test,v 1.1.4.1 1998/09/30 02:18:45 stanton Exp $
+# RCS: @(#) $Id: macEmbed.test,v 1.1.4.2 1999/03/11 18:50:56 hershey Exp $
if {$tcl_platform(platform) != "macintosh"} {
+ puts "skipping: Mac only tests..."
return
}
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
eval destroy [winfo children .]
@@ -295,3 +295,7 @@ test macEmbed-7.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} {
foreach w [winfo child .] {
catch {destroy $w}
}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/macFont.test b/tests/macFont.test
index 51fa738..a6d20d1 100644
--- a/tests/macFont.test
+++ b/tests/macFont.test
@@ -7,18 +7,18 @@
# but there are no results that can be checked.
#
# Copyright (c) 1996 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.
-#
-# RCS: @(#) $Id: macFont.test,v 1.1.4.2 1998/09/30 02:18:45 stanton Exp $
+# RCS: @(#) $Id: macFont.test,v 1.1.4.3 1999/03/11 18:50:57 hershey Exp $
if {$tcl_platform(platform)!="macintosh"} {
+ puts "skipping: Mac only tests..."
return
}
-if {[string compare test [info procs test]] != 0} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
catch {destroy .b}
@@ -44,11 +44,11 @@ proc getsize {} {
return "[winfo reqwidth .b.l] [winfo reqheight .b.l]"
}
-set testConfig(gothic) 0
+set ::test::testConfig(gothic) 0
set gothic {gothic 12}
set mx [font measure $gothic \u4e4e]
if {[font actual $gothic -family] != [font actual system -family]} {
- set testConfig(gothic) 1
+ set ::test::testConfig(gothic) 1
}
test macFont-1.1 {TkpFontPkgInit} {
@@ -282,3 +282,7 @@ test macFont-9.4 {AllocMacFont: extract text metrics} {
} {1}
destroy .b
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/macMenu.test b/tests/macMenu.test
index ccf9759..e0eb389 100644
--- a/tests/macMenu.test
+++ b/tests/macMenu.test
@@ -4,13 +4,13 @@
# system.
#
# Copyright (c) 1995-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.
-#
-# RCS: @(#) $Id: macMenu.test,v 1.1.4.1 1998/09/30 02:18:46 stanton Exp $
+# RCS: @(#) $Id: macMenu.test,v 1.1.4.2 1999/03/11 18:50:57 hershey Exp $
if {$tcl_platform(platform) != "macintosh"} {
+ puts "skipping: Mac only tests..."
return
}
@@ -21,8 +21,8 @@ if {[lsearch [image types] test] < 0} {
return
}
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
proc deleteWindows {} {
@@ -1561,5 +1561,7 @@ test macMenu-44.2 {DrawMenuEntryBackground} {
test macMenu-45.1 {TkpMenuInit - called at boot time} {} {}
+# cleanup
deleteWindows
-
+::test::cleanupTests
+return
diff --git a/tests/macWinMenu.test b/tests/macWinMenu.test
index 2db2f8c..2c51bea 100644
--- a/tests/macWinMenu.test
+++ b/tests/macWinMenu.test
@@ -3,13 +3,13 @@
# the common implementation of Macintosh and Windows menus.
#
# Copyright (c) 1995-1996 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.
-#
-# RCS: @(#) $Id: macWinMenu.test,v 1.1.4.1 1998/09/30 02:18:46 stanton Exp $
+# RCS: @(#) $Id: macWinMenu.test,v 1.1.4.2 1999/03/11 18:50:58 hershey Exp $
if {$tcl_platform(platform) == "unix"} {
+ puts "skipping: Unix only tests..."
return
}
@@ -20,8 +20,8 @@ if {[lsearch [image types] test] < 0} {
return
}
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
proc deleteWindows {} {
@@ -114,4 +114,7 @@ if {$tcl_platform(platform) != "windows" || [info exists INTERACTIVE]} {
} {0 2.1 2.1 {} {}}
}
+# cleanup
deleteWindows
+::test::cleanupTests
+return
diff --git a/tests/macscrollbar.test b/tests/macscrollbar.test
index bb32323..193dfef 100644
--- a/tests/macscrollbar.test
+++ b/tests/macscrollbar.test
@@ -4,17 +4,19 @@
# Tcl tests.
#
# Copyright (c) 1996 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.
-#
-# RCS: @(#) $Id: macscrollbar.test,v 1.1.4.1 1998/09/30 02:18:47 stanton Exp $
+# RCS: @(#) $Id: macscrollbar.test,v 1.1.4.2 1999/03/11 18:50:58 hershey Exp $
# Only run this test on the Macintosh
-if {$tcl_platform(platform) != "macintosh"} return
+if {$tcl_platform(platform) != "macintosh"} {
+ puts "skipping: Mac only tests..."
+ return
+}
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
foreach i [winfo children .] {
@@ -98,4 +100,7 @@ test macscroll-1.7 {TkpDisplayScrollbar procedure} {
foreach i [winfo children .] {
destroy $i
}
-concat {}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/main.test b/tests/main.test
index ab21e77..db4c2b4 100644
--- a/tests/main.test
+++ b/tests/main.test
@@ -5,14 +5,13 @@
# 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.
+# All rights reserved.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: main.test,v 1.1.4.3 1999/02/11 04:13:49 stanton Exp $
+# RCS: @(#) $Id: main.test,v 1.1.4.4 1999/03/11 18:50:59 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 main-1.1 {StdinProc} {unixOnly} {
@@ -31,7 +30,7 @@ test main-1.1 {StdinProc} {unixOnly} {
list $error $msg
} {0 {}}
-#
-# Clean up.
-#
+# cleanup
catch {removeFile script}
+::test::cleanupTests
+return
diff --git a/tests/menu.test b/tests/menu.test
index a0aca14..9f56582 100644
--- a/tests/menu.test
+++ b/tests/menu.test
@@ -2,11 +2,10 @@
# organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1995-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.
-#
-# RCS: @(#) $Id: menu.test,v 1.1.4.3 1998/12/04 07:21:22 welch Exp $
+# RCS: @(#) $Id: menu.test,v 1.1.4.4 1999/03/11 18:50:59 hershey Exp $
if {[lsearch [image types] test] < 0} {
puts "This application hasn't been compiled with the \"test\" image"
@@ -15,8 +14,8 @@ if {[lsearch [image types] test] < 0} {
return
}
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
if {$tcl_platform(platform) == "windows" && ![info exists INTERACTIVE]} {
@@ -24,9 +23,9 @@ if {$tcl_platform(platform) == "windows" && ![info exists INTERACTIVE]} {
puts " automatically on this platform. If you wish to execute them"
puts " interactively, set the TCL variable INTERACTIVE and re-run"
puts " the test."
- set testConfig(menuInteractive) 0
+ set ::test::testConfig(menuInteractive) 0
} else {
- set testConfig(menuInteractive) 1
+ set ::test::testConfig(menuInteractive) 1
}
proc deleteWindows {} {
@@ -2443,4 +2442,7 @@ test menu-33.1 {menu vs command hiding} {
# menu-34 MenuInit only called at boot time
+# cleanup
deleteWindows
+::test::cleanupTests
+return
diff --git a/tests/menuDraw.test b/tests/menuDraw.test
index 7dd7d80..65b7f55 100644
--- a/tests/menuDraw.test
+++ b/tests/menuDraw.test
@@ -2,11 +2,10 @@
# organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1996-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.
-#
-# RCS: @(#) $Id: menuDraw.test,v 1.1.4.2 1998/09/30 02:18:48 stanton Exp $
+# RCS: @(#) $Id: menuDraw.test,v 1.1.4.3 1999/03/11 18:51:00 hershey Exp $
if {[lsearch [image types] test] < 0} {
puts "This application hasn't been compiled with the \"test\" image"
@@ -15,8 +14,8 @@ if {[lsearch [image types] test] < 0} {
return
}
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
proc deleteWindows {} {
@@ -34,9 +33,9 @@ if {$tcl_platform(platform) == "windows" && ![info exists INTERACTIVE]} {
puts " automatically on this platform. If you wish to execute them"
puts " interactively, set the TCL variable INTERACTIVE and re-run"
puts " the test."
- set testConfig(menuInteractive) 0
+ set ::test::testConfig(menuInteractive) 0
} else {
- set testConfig(menuInteractive) 1
+ set ::test::testConfig(menuInteractive) 1
}
test menuDraw-1.1 {TkMenuInitializeDrawingFields} {
@@ -543,4 +542,7 @@ test menuDraw-17.2 {AdjustMenuCoords - menu} {menuInteractive} {
list [$tearoff postcascade 0] [destroy .m1] [destroy .m2]
} {{} {} {}}
+# cleanup
deleteWindows
+::test::cleanupTests
+return
diff --git a/tests/menubut.test b/tests/menubut.test
index 35e43c9..326f754 100644
--- a/tests/menubut.test
+++ b/tests/menubut.test
@@ -3,11 +3,10 @@
#
# Copyright (c) 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.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: menubut.test,v 1.1.4.2 1999/02/16 06:00:42 lfb Exp $
+# RCS: @(#) $Id: menubut.test,v 1.1.4.3 1999/03/11 18:51:01 hershey Exp $
# XXX This test file is woefully incomplete right now. If any part
# XXX of a procedure has tests then the whole procedure has tests,
@@ -20,8 +19,8 @@ if {[lsearch [image types] test] < 0} {
return
}
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
foreach i [winfo children .] {
@@ -350,3 +349,6 @@ eval image delete [image names]
eval destroy [winfo children .]
option clear
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/msgbox.test b/tests/msgbox.test
index f63cf53..6379ca4 100644
--- a/tests/msgbox.test
+++ b/tests/msgbox.test
@@ -2,15 +2,14 @@
# It is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1996 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.
-#
-# RCS: @(#) $Id: msgbox.test,v 1.1.4.3 1998/12/09 01:18:38 stanton Exp $
+# RCS: @(#) $Id: msgbox.test,v 1.1.4.4 1999/03/11 18:51:01 hershey Exp $
#
-if {[string compare test [info procs test]] == 1} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
test msgbox-1.1 {tk_messageBox command} {
@@ -155,3 +154,7 @@ foreach spec $specs {
} "$button"
}
}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/obj.test b/tests/obj.test
index 20e1572..844652c 100644
--- a/tests/obj.test
+++ b/tests/obj.test
@@ -2,14 +2,13 @@
# It is organized in the standard fashion for Tcl tests.
#
# 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.
-#
-# RCS: @(#) $Id: obj.test,v 1.1.2.2 1998/09/30 02:18:50 stanton Exp $
+# RCS: @(#) $Id: obj.test,v 1.1.2.3 1999/03/11 18:51:02 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]
}
foreach i [winfo children .] {
@@ -34,4 +33,7 @@ test obj-4.1 {SetPixelFromAny} {
eval destroy [winfo children .]
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/oldpack.test b/tests/oldpack.test
index 2448fb5..2e91731 100644
--- a/tests/oldpack.test
+++ b/tests/oldpack.test
@@ -4,14 +4,14 @@
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994 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.
-#
-# RCS: @(#) $Id: oldpack.test,v 1.1.4.1 1998/09/30 02:18:50 stanton Exp $
+# RCS: @(#) $Id: oldpack.test,v 1.1.4.2 1999/03/11 18:51: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]
+}
# First, test a single window packed in various ways in a parent
@@ -505,4 +505,7 @@ test pack-9.3 {information output} {
} {{.pack.blue .pack.red .pack.green .pack.violet} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top}}
catch {destroy .pack}
-concat {}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/option.test b/tests/option.test
index d199769..2fe0458 100644
--- a/tests/option.test
+++ b/tests/option.test
@@ -3,14 +3,14 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 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.
-#
-# RCS: @(#) $Id: option.test,v 1.1.4.1 1998/09/30 02:18:50 stanton Exp $
+# RCS: @(#) $Id: option.test,v 1.1.4.2 1999/03/11 18:51: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 {destroy .op1}
catch {destroy .op2}
@@ -186,13 +186,13 @@ test option-14.12 {error conditions} {
} {1 {bad window path name ".gorp.gorp"}}
if {$tcl_platform(os) == "Win32s"} {
- set option1 OPTION~2.FIL
- set option2 OPTION~1.FIL
- set option3 OPTION~3.FIL
+ set option1 [file join $::test::testsDir OPTION~2.FIL]
+ set option2 [file join $::test::testsDir OPTION~1.FIL]
+ set option3 [file join $::test::testsDir OPTION~3.FIL]
} else {
- set option1 option.file1
- set option2 option.file2
- set option3 option.file3
+ set option1 [file join $::test::testsDir option.file1]
+ set option2 [file join $::test::testsDir option.file2]
+ set option3 [file join $::test::testsDir option.file3]
}
test option-15.1 {database files} {
@@ -229,4 +229,7 @@ test option-16.1 {ReadOptionFile} {
catch {destroy .op1}
catch {destroy .op2}
-concat {}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/pack.test b/tests/pack.test
index 9aafd2c..d572443 100644
--- a/tests/pack.test
+++ b/tests/pack.test
@@ -3,14 +3,14 @@
#
# Copyright (c) 1993 The Regents of the University of California.
# Copyright (c) 1994 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.
-#
-# RCS: @(#) $Id: pack.test,v 1.1.4.1 1998/09/30 02:18:51 stanton Exp $
+# RCS: @(#) $Id: pack.test,v 1.1.4.2 1999/03/11 18:51: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]
+}
# Utility procedures:
@@ -967,3 +967,7 @@ destroy .pack
foreach i {pack1 pack2 pack3 pack4} {
rename $i {}
}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/place.test b/tests/place.test
index 54752e9..ef473c4 100644
--- a/tests/place.test
+++ b/tests/place.test
@@ -2,14 +2,13 @@
# organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1995 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.
-#
-# RCS: @(#) $Id: place.test,v 1.1.4.1 1998/09/30 02:18:51 stanton Exp $
+# RCS: @(#) $Id: place.test,v 1.1.4.2 1999/03/11 18:51:04 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]
}
foreach i [winfo children .] {
@@ -218,4 +217,7 @@ test place-8.2 {MasterStructureProc, mapping and unmapping slaves} {
} {1 0 42 32 0 1}
catch {destroy .t}
-concat
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/raise.test b/tests/raise.test
index 811884a..74b7b63 100644
--- a/tests/raise.test
+++ b/tests/raise.test
@@ -5,11 +5,10 @@
#
# Copyright (c) 1993-1994 The Regents of the University of California.
# Copyright (c) 1994 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.
-#
-# RCS: @(#) $Id: raise.test,v 1.1.4.1 1998/09/30 02:18:52 stanton Exp $
+# RCS: @(#) $Id: raise.test,v 1.1.4.2 1999/03/11 18:51:05 hershey Exp $
if {[info commands testmakeexist] == {}} {
puts "This application hasn't been compiled with the \"testmakeexist\""
@@ -18,8 +17,9 @@ if {[info commands testmakeexist] == {}} {
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]
+}
# Procedure to create a bunch of overlapping windows, which should
# make it easy to detect differences in order.
@@ -297,3 +297,7 @@ test raise-7.8 {errors in raise/lower commands} {
foreach i [winfo child .] {
destroy $i
}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/safe.test b/tests/safe.test
index c302e0f..8efa165 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -3,14 +3,13 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-1995 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.
-#
-# RCS: @(#) $Id: safe.test,v 1.1.4.2 1998/09/30 02:18:52 stanton Exp $
+# RCS: @(#) $Id: safe.test,v 1.1.4.3 1999/03/11 18:51:05 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]
}
foreach i [winfo children .] {
@@ -173,4 +172,7 @@ test safe-7.1 {canvas printing} {
set r
} 0
+# cleanup
unset hidden_cmds
+::test::cleanupTests
+return
diff --git a/tests/scale.test b/tests/scale.test
index 55f2469..fb9aa81 100644
--- a/tests/scale.test
+++ b/tests/scale.test
@@ -3,14 +3,13 @@
#
# Copyright (c) 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.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: scale.test,v 1.1.4.4 1999/02/16 11:39:35 lfb Exp $
+# RCS: @(#) $Id: scale.test,v 1.1.4.5 1999/03/11 18:51:06 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]
}
foreach i [winfo children .] {
@@ -799,3 +798,7 @@ test scale-16.1 {scale widget vs hidden commands} {
catch {destroy .s}
option clear
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/scrollbar.test b/tests/scrollbar.test
index 035d754..ce9afba 100644
--- a/tests/scrollbar.test
+++ b/tests/scrollbar.test
@@ -4,14 +4,13 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-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.
-#
-# RCS: @(#) $Id: scrollbar.test,v 1.1.4.1 1998/09/30 02:18:53 stanton Exp $
+# RCS: @(#) $Id: scrollbar.test,v 1.1.4.2 1999/03/11 18:51:07 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]
}
foreach i [winfo children .] {
@@ -662,4 +661,7 @@ test scrollbar-9.1 {scrollbar widget vs hidden commands} {
catch {destroy .s}
catch {destroy .t}
-concat {}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/select.test b/tests/select.test
index f51d550..d0839fa 100644
--- a/tests/select.test
+++ b/tests/select.test
@@ -3,19 +3,18 @@
# fashion for Tcl tests.
#
# Copyright (c) 1994 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.
-#
-# RCS: @(#) $Id: select.test,v 1.1.4.1 1998/09/30 02:18:54 stanton Exp $
+# RCS: @(#) $Id: select.test,v 1.1.4.2 1999/03/11 18:51:07 hershey Exp $
#
# Note: Multiple display selection handling will only be tested if the
# environment variable TK_ALT_DISPLAY is set to an alternate display.
#
-if {[string compare test [info procs test]] == 1} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
eval destroy [winfo child .]
@@ -449,10 +448,10 @@ test select-5.10 {Tk_GetSelection procedure} {unixOnly} {
set selInfo ""
selection own .f1
set result ""
- fileevent $fd readable {}
- puts $fd {catch {selection get TEST} msg; update; puts $msg; flush stdout}
- flush $fd
- lappend result [gets $fd]
+ fileevent $::test::fd readable {}
+ puts $::test::fd {catch {selection get TEST} msg; update; puts $msg; flush stdout}
+ flush $::test::fd
+ lappend result [gets $::test::fd]
cleanupbg
lappend result $selInfo
} {{selection owner didn't respond} {}}
@@ -814,14 +813,14 @@ test select-10.1 {ConvertSelection procedure, race with selection clear} {unixOn
set selInfo ""
selection handle .f1 {handler STRING}
update
- puts $fd {puts "[catch {selection get} msg] $msg"; puts **DONE**; flush stdout}
- flush $fd
+ puts $::test::fd {puts "[catch {selection get} msg] $msg"; puts **DONE**; flush stdout}
+ flush $::test::fd
after 200
selection own .
- set bgData {}
- tkwait variable bgDone
+ set ::test::bgData {}
+ tkwait variable ::test::bgDone
cleanupbg
- list $bgData $selInfo
+ list $::test::bgData $selInfo
} {{1 PRIMARY selection doesn't exist or form "STRING" not defined} {}}
test select-10.2 {ConvertSelection procedure} {unixOnly} {
setup
@@ -984,4 +983,7 @@ test select-13.1 {SelectionSize procedure, handler deleted} {unixOnly} {
} {{PRIMARY selection doesn't exist or form "STRING" not defined} {.f1 STRING 0 4000 .f1 STRING 4000 4000}}
catch {rename weirdHandler {}}
-concat
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/send.test b/tests/send.test
index 1ea0070..b3583e7 100644
--- a/tests/send.test
+++ b/tests/send.test
@@ -4,11 +4,10 @@
#
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1994-1996 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.
-#
-# RCS: @(#) $Id: send.test,v 1.1.4.3 1998/12/08 02:02:41 stanton Exp $
+# RCS: @(#) $Id: send.test,v 1.1.4.4 1999/03/11 18:51:08 hershey Exp $
if {$tcl_platform(platform) == "macintosh"} {
puts "send is not available on the Mac - skipping tests"
@@ -23,8 +22,8 @@ if {[auto_execok xhost] == ""} {
return
}
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
if {[info commands testsend] == "testsend"} {
set gotTestCmds 1
@@ -580,11 +579,11 @@ test send-12.2 {TimeoutProc procedure} {
update
setupbg
puts $fd {after 10 {after 5000; exit}; puts [tk appname]; puts **DONE**; flush stdout}
- set bgDone 0
- set bgData {}
+ set ::test::bgDone 0
+ set ::test::bgData {}
flush $fd
- tkwait variable bgDone
- set app $bgData
+ tkwait variable ::test::bgDone
+ set app $::test::bgData
after 200
set result [list [catch {send $app foo} msg] $msg]
close $fd
@@ -656,3 +655,7 @@ if $gotTestCmds {
testdeleteapps
}
rename newApp {}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/text.test b/tests/text.test
index 3a2d4b4..231c146 100644
--- a/tests/text.test
+++ b/tests/text.test
@@ -3,14 +3,14 @@
#
# Copyright (c) 1992-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.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: text.test,v 1.1.4.2 1998/12/08 02:02:41 stanton Exp $
+# RCS: @(#) $Id: text.test,v 1.1.4.3 1999/03/11 18:51: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]
+}
eval destroy [winfo child .]
@@ -1260,3 +1260,7 @@ test text-23.1 {text widget vs hidden commands} {
eval destroy [winfo child .]
option clear
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/textBTree.test b/tests/textBTree.test
index db30a96..b38a614 100644
--- a/tests/textBTree.test
+++ b/tests/textBTree.test
@@ -5,14 +5,14 @@
#
# Copyright (c) 1992-1994 The Regents of the University of California.
# Copyright (c) 1994 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.
-#
-# RCS: @(#) $Id: textBTree.test,v 1.1.4.1 1998/09/30 02:18:56 stanton Exp $
+# RCS: @(#) $Id: textBTree.test,v 1.1.4.2 1999/03/11 18:51: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]
+}
catch {destroy .t}
text .t
@@ -893,5 +893,8 @@ test btree-18.9 {tag search back, large complex btree spans} {
list [.t tag prev x end] [.t tag prev x 433.0]
} {{500.0 520.0} {200.0 220.0}}
-
destroy .t
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/textDisp.test b/tests/textDisp.test
index 8ce4172..01201c5 100644
--- a/tests/textDisp.test
+++ b/tests/textDisp.test
@@ -3,17 +3,16 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-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.
-#
-# RCS: @(#) $Id: textDisp.test,v 1.1.4.2 1998/09/30 02:18:56 stanton Exp $
+# RCS: @(#) $Id: textDisp.test,v 1.1.4.3 1999/03/11 18:51:10 hershey Exp $
-if {[string compare test [info procs test]] == 1} {
- source defs
- if {$testConfig(fonts) == 0} {
- puts "skipping font-sensitive tests"
- }
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
+if {$::test::testConfig(fonts) == 0} {
+ puts "skipping font-sensitive tests"
}
# The procedure below is used as the scrolling command for the text;
@@ -2866,3 +2865,7 @@ foreach i [winfo children .] {
catch {destroy $i}
}
option clear
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/textImage.test b/tests/textImage.test
index bee9e20..d0d53c7 100644
--- a/tests/textImage.test
+++ b/tests/textImage.test
@@ -1,7 +1,17 @@
-# RCS: @(#) $Id: textImage.test,v 1.1.4.1 1998/09/30 02:18:58 stanton Exp $
-
-if {[string compare test [info procs test]] == 1} then \
- {source ../tests/defs}
+# textImage.test -- test images embedded in text widgets
+#
+# 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: textImage.test,v 1.1.4.2 1999/03/11 18:51:11 hershey Exp $
+
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
# Test Arguments:
# name - Name of test, in the form foo-1.2.
@@ -9,7 +19,7 @@ if {[string compare test [info procs test]] == 1} then \
# 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
+# 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
@@ -351,3 +361,7 @@ test textImage-4.3 {alignment and padding checking} {fonts} {
catch {destroy .t}
foreach image [image names] {image delete $image}
font delete test_font
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/textIndex.test b/tests/textIndex.test
index fa0fa05..aea75be 100644
--- a/tests/textIndex.test
+++ b/tests/textIndex.test
@@ -3,14 +3,14 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994 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.
-#
-# RCS: @(#) $Id: textIndex.test,v 1.1.4.2 1998/09/30 02:18:58 stanton Exp $
+# RCS: @(#) $Id: textIndex.test,v 1.1.4.3 1999/03/11 18:51: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]
+}
catch {destroy .t}
text .t -font {Courier -12} -width 20 -height 10
@@ -640,6 +640,8 @@ test textIndex-15.15 {StartEnd} {
list [catch {.t index {2.12 word}} msg] $msg
} {1 {bad text index "2.12 word"}}
+# cleanup
rename textimage {}
catch {destroy .t}
-concat
+::test::cleanupTests
+return
diff --git a/tests/textMark.test b/tests/textMark.test
index 17a91fb..d9e2bc9 100644
--- a/tests/textMark.test
+++ b/tests/textMark.test
@@ -3,14 +3,14 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994 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.
-#
-# RCS: @(#) $Id: textMark.test,v 1.1.4.2 1998/09/30 02:18:59 stanton Exp $
+# RCS: @(#) $Id: textMark.test,v 1.1.4.3 1999/03/11 18:51: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]
+}
catch {destroy .t}
if [catch {text .t -font {Courier 12} -width 20 -height 10}] {
@@ -219,4 +219,7 @@ test textMark-8.8 {MarkFindPrev - no previous mark} {
} {}
catch {destroy .t}
-concat {}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/textTag.test b/tests/textTag.test
index a02aa9c..0d299c9 100644
--- a/tests/textTag.test
+++ b/tests/textTag.test
@@ -3,14 +3,14 @@
#
# Copyright (c) 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.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: textTag.test,v 1.1.4.2 1998/09/30 02:18:59 stanton Exp $
+# RCS: @(#) $Id: textTag.test,v 1.1.4.3 1999/03/11 18:51: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]
+}
catch {destroy .t}
if [catch {text .t -font {Courier 12} -width 20 -height 10}] {
@@ -760,4 +760,7 @@ test textTag-16.7 {TkTextPickCurrent procedure} {
} {3.1}
catch {destroy .t}
-concat {}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/textWind.test b/tests/textWind.test
index 6987d55..f6b46e2 100644
--- a/tests/textWind.test
+++ b/tests/textWind.test
@@ -3,14 +3,14 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-1995 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.
-#
-# RCS: @(#) $Id: textWind.test,v 1.1.4.1 1998/09/30 02:19:00 stanton Exp $
+# RCS: @(#) $Id: textWind.test,v 1.1.4.2 1999/03/11 18:51: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]
+}
foreach i [winfo child .] {
catch {destroy $i}
@@ -824,3 +824,7 @@ pack .t
catch {destroy .t}
option clear
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/tk.test b/tests/tk.test
index e211234..69d3195 100644
--- a/tests/tk.test
+++ b/tests/tk.test
@@ -2,14 +2,13 @@
# It is organized in the standard fashion for Tcl tests.
#
# 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.
-#
-# RCS: @(#) $Id: tk.test,v 1.1.4.2 1998/09/30 02:19:00 stanton Exp $
+# RCS: @(#) $Id: tk.test,v 1.1.4.3 1999/03/11 18:51:14 hershey Exp $
-if {[info commands test] == ""} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
test tk-1.1 {tk command: general} {
@@ -78,3 +77,7 @@ test tk-3.11 {tk command: scaling: heightmm} {
expr {int((25.4*[winfo screenheight .])/(72*1.25)+0.5)-[winfo screenmmheight .]}
} {0}
tk scaling $scaling
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/unixButton.test b/tests/unixButton.test
index 5f30d3c..4cf8270 100644
--- a/tests/unixButton.test
+++ b/tests/unixButton.test
@@ -5,13 +5,13 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-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.
-#
-# RCS: @(#) $Id: unixButton.test,v 1.1.4.1 1998/09/30 02:19:01 stanton Exp $
+# RCS: @(#) $Id: unixButton.test,v 1.1.4.2 1999/03/11 18:51:14 hershey Exp $
if {$tcl_platform(platform)!="unix"} {
+ puts "skipping: Unix only tests..."
return
}
@@ -22,8 +22,8 @@ if {[lsearch [image types] test] < 0} {
return
}
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
foreach i [winfo children .] {
@@ -180,3 +180,7 @@ test unixbutton-1.11 {TkpComputeButtonGeometry procedure} {
} {27 37}
eval destroy [winfo children .]
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/unixEmbed.test b/tests/unixEmbed.test
index ebbdcde..0ffcbfc 100644
--- a/tests/unixEmbed.test
+++ b/tests/unixEmbed.test
@@ -3,18 +3,18 @@
# tests.
#
# Copyright (c) 1996-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.
-#
-# RCS: @(#) $Id: unixEmbed.test,v 1.1.4.2 1998/12/10 03:43:55 stanton Exp $
+# RCS: @(#) $Id: unixEmbed.test,v 1.1.4.3 1999/03/11 18:51:15 hershey Exp $
if {$tcl_platform(platform) != "unix"} {
+ puts "skipping: Unix only tests..."
return
}
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
eval destroy [winfo children .]
@@ -621,8 +621,10 @@ test unixEmbed-10.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} {
wm geometry .t1
} {70x300+0+0}
-
+# cleanup
foreach w [winfo child .] {
catch {destroy $w}
}
cleanupbg
+::test::cleanupTests
+return
diff --git a/tests/unixFont.test b/tests/unixFont.test
index e9d1568..fd85fe3 100644
--- a/tests/unixFont.test
+++ b/tests/unixFont.test
@@ -9,18 +9,18 @@
# at all sites.
#
# Copyright (c) 1996 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.
-#
-# RCS: @(#) $Id: unixFont.test,v 1.1.4.2 1998/09/30 02:19:01 stanton Exp $
+# RCS: @(#) $Id: unixFont.test,v 1.1.4.3 1999/03/11 18:51:16 hershey Exp $
if {$tcl_platform(platform)!="unix"} {
+ puts "skipping: Unix only tests..."
return
}
-if {[string compare test [info procs test]] != 0} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
catch {destroy .b}
@@ -291,3 +291,6 @@ test unixfont-9.2 {GetControlCharSubst procedure: 4 chars subst} {
lappend x [.b.c index $t @[expr $ax*5],0]
} {0 1 1 1 1 2}
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/unixMenu.test b/tests/unixMenu.test
index 5e28f0a..354f19a 100644
--- a/tests/unixMenu.test
+++ b/tests/unixMenu.test
@@ -4,13 +4,13 @@
# system.
#
# Copyright (c) 1995-1996 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.
-#
-# RCS: @(#) $Id: unixMenu.test,v 1.1.4.2 1998/09/30 02:19:02 stanton Exp $
+# RCS: @(#) $Id: unixMenu.test,v 1.1.4.3 1999/03/11 18:51:16 hershey Exp $
if {$tcl_platform(platform) != "unix"} {
+ puts "skipping: Unix only tests..."
return
}
@@ -21,8 +21,8 @@ if {[lsearch [image types] test] < 0} {
return
}
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
proc deleteWindows {} {
@@ -966,4 +966,7 @@ test unixMenu-25.20 {TkpComputeStandardMenuGeometry - hide margin} {
test unixMenu-26.1 {TkpMenuInit - nothing to do} {} {}
+# cleanup
deleteWindows
+::test::cleanupTests
+return
diff --git a/tests/unixSend.test b/tests/unixSend.test
index 8528692..aa140d2 100644
--- a/tests/unixSend.test
+++ b/tests/unixSend.test
@@ -4,17 +4,17 @@
#
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1994-1996 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.
-#
-# RCS: @(#) $Id: unixSend.test,v 1.1.2.2 1998/09/30 02:19:03 stanton Exp $
+# RCS: @(#) $Id: unixSend.test,v 1.1.2.3 1999/03/11 18:51:17 hershey Exp $
if {$tcl_platform(platform) == "macintosh"} {
puts "send is not available on the Mac - skipping tests"
return
}
if {$tcl_platform(platform) == "windows"} {
+ puts "skipping: Unix only tests..."
return
}
if {[auto_execok xhost] == ""} {
@@ -22,9 +22,10 @@ if {[auto_execok xhost] == ""} {
return
}
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
+
if {[info commands testsend] == "testsend"} {
set gotTestCmds 1
} else {
@@ -579,11 +580,11 @@ test unixSend-12.2 {TimeoutProc procedure} {
update
setupbg
puts $fd {after 10 {after 5000; exit}; puts [tk appname]; puts **DONE**; flush stdout}
- set bgDone 0
- set bgData {}
+ set ::test::bgDone 0
+ set ::test::bgData {}
flush $fd
- tkwait variable bgDone
- set app $bgData
+ tkwait variable ::test::bgDone
+ set app $::test::bgData
after 200
set result [list [catch {send $app foo} msg] $msg]
close $fd
@@ -655,3 +656,7 @@ if $gotTestCmds {
testdeleteapps
}
rename newApp {}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/unixWm.test b/tests/unixWm.test
index ca8bcd8..ff6b4d9 100644
--- a/tests/unixWm.test
+++ b/tests/unixWm.test
@@ -4,18 +4,18 @@
#
# Copyright (c) 1992-1994 The Regents of the University of California.
# Copyright (c) 1994-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.
-#
-# RCS: @(#) $Id: unixWm.test,v 1.1.4.3 1999/02/11 04:13:49 stanton Exp $
+# RCS: @(#) $Id: unixWm.test,v 1.1.4.4 1999/03/11 18:51:18 hershey Exp $
if {$tcl_platform(platform) != "unix"} {
+ puts "skipping: Unix only tests..."
return
}
-if {[string compare test [info procs test]] == 1} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
proc sleep ms {
@@ -2384,7 +2384,8 @@ test unixWm-58.3 {exit processing} {
list $error $msg
} {0 {}}
-
+# cleanup
catch {destroy .t}
catch {removeFile script}
-concat {}
+::test::cleanupTests
+return
diff --git a/tests/util.test b/tests/util.test
index af09f20..9efc917 100644
--- a/tests/util.test
+++ b/tests/util.test
@@ -3,14 +3,14 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994 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.
-#
-# RCS: @(#) $Id: util.test,v 1.1.4.1 1998/09/30 02:19:04 stanton Exp $
+# RCS: @(#) $Id: util.test,v 1.1.4.2 1999/03/11 18:51: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]
+}
foreach i [winfo children .] {
destroy $i
@@ -68,3 +68,7 @@ test util-1.11 {Tk_GetScrollInfo procedure} {
test util-1.12 {Tk_GetScrollInfo procedure} {
list [catch {.l yview dropdead 3 times} msg] $msg
} {1 {unknown option "dropdead": must be moveto or scroll}}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/visual.test b/tests/visual.test
index a114d0f..4f02600 100644
--- a/tests/visual.test
+++ b/tests/visual.test
@@ -4,14 +4,13 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-1995 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.
-#
-# RCS: @(#) $Id: visual.test,v 1.1.4.1 1998/09/30 02:19:05 stanton Exp $
+# RCS: @(#) $Id: visual.test,v 1.1.4.2 1999/03/11 18:51:19 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]
}
foreach i [winfo children .] {
@@ -310,3 +309,7 @@ foreach w [winfo child .] {
}
rename eatColors {}
rename colorsFree {}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/winButton.test b/tests/winButton.test
index 621433e..1baba5f 100644
--- a/tests/winButton.test
+++ b/tests/winButton.test
@@ -5,13 +5,13 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-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.
-#
-# RCS: @(#) $Id: winButton.test,v 1.1.4.1 1998/09/30 02:19:05 stanton Exp $
+# RCS: @(#) $Id: winButton.test,v 1.1.4.2 1999/03/11 18:51:20 hershey Exp $
if {$tcl_platform(platform)!="windows"} {
+ puts "skipping: Windows only tests..."
return
}
@@ -22,8 +22,8 @@ if {[lsearch [image types] test] < 0} {
return
}
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
foreach i [winfo children .] {
@@ -151,4 +151,7 @@ test winbutton-1.9 {TkpComputeButtonGeometry procedure} {
list [winfo reqwidth .b2] [winfo reqheight .b2]
} {24 34}
+# cleanup
eval destroy [winfo children .]
+::test::cleanupTests
+return
diff --git a/tests/winClipboard.test b/tests/winClipboard.test
index b07fcdf..ed16d0c 100644
--- a/tests/winClipboard.test
+++ b/tests/winClipboard.test
@@ -7,18 +7,18 @@
# 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.
+# All rights reserved.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: winClipboard.test,v 1.1.4.2 1998/11/25 21:16:40 stanton Exp $
+# RCS: @(#) $Id: winClipboard.test,v 1.1.4.3 1999/03/11 18:51:20 hershey Exp $
if {$tcl_platform(platform)!="windows"} {
+ puts "skipping: Windows only tests..."
return
}
-if {[string compare test [info procs test]] == 1} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
# Note that these tests may fail if another application is grabbing the
@@ -45,3 +45,6 @@ test winClipboard-1.4 {TkSelGetSelection & TkWinClipboardRender} {
list [selection get -selection CLIPBOARD] [testclipboard]
} [list "line 1\nline 2" "line 1\r\nline 2"]
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/winDialog.test b/tests/winDialog.test
index c10331e..5537ba6 100644
--- a/tests/winDialog.test
+++ b/tests/winDialog.test
@@ -3,21 +3,21 @@
# fashion for Tcl tests.
#
# 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.
-#
-# RCS: @(#) $Id: winDialog.test,v 1.1.2.2 1998/09/30 02:19:06 stanton Exp $
+# RCS: @(#) $Id: winDialog.test,v 1.1.2.3 1999/03/11 18:51:21 hershey Exp $
if {$tcl_platform(os) != "Windows NT"} {
+ puts "skipping: Windows NT only tests..."
return
}
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
-set testConfig(interactive) [info exists INTERACTIVE]
+set ::test::testConfig(interactive) [info exists INTERACTIVE]
testwinevent debug 1
@@ -314,3 +314,7 @@ test winDialog-7.1 {Tk_MessageBoxObjCmd} {
} {}
testwinevent debug 0
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/winFont.test b/tests/winFont.test
index 1eb5672..910b86c 100644
--- a/tests/winFont.test
+++ b/tests/winFont.test
@@ -7,18 +7,18 @@
# but there are no results that can be checked.
#
# Copyright (c) 1996-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.
-#
-# RCS: @(#) $Id: winFont.test,v 1.1.4.1 1998/09/30 02:19:06 stanton Exp $
+# RCS: @(#) $Id: winFont.test,v 1.1.4.2 1999/03/11 18:51:21 hershey Exp $
if {$tcl_platform(platform)!="windows"} {
+ puts "skipping: Windows only tests..."
return
}
-if {[string compare test [info procs test]] != 0} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
catch {destroy .b}
@@ -182,4 +182,7 @@ test winfont-7.4 {AllocFont procedure: extract info from textmetric} {
font metric systemfixed -fixed
} {1}
+# cleanup
destroy .b
+::test::cleanupTests
+return
diff --git a/tests/winMenu.test b/tests/winMenu.test
index 28c65c4..800fb4f 100644
--- a/tests/winMenu.test
+++ b/tests/winMenu.test
@@ -4,13 +4,13 @@
# system.
#
# Copyright (c) 1995-1996 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.
-#
-# RCS: @(#) $Id: winMenu.test,v 1.1.4.2 1998/09/30 02:19:07 stanton Exp $
+# RCS: @(#) $Id: winMenu.test,v 1.1.4.3 1999/03/11 18:51:22 hershey Exp $
if {$tcl_platform(platform) != "windows"} {
+ puts "skipping: Windows only tests..."
return
}
@@ -19,9 +19,9 @@ if {![info exists INTERACTIVE]} {
puts " automatically on this platform. If you wish to execute them"
puts " interactively, set the TCL variable INTERACTIVE and re-run"
puts " the test."
- set testConfig(menuInteractive) 0
+ set ::test::testConfig(menuInteractive) 0
} else {
- set testConfig(menuInteractive) 1
+ set ::test::testConfig(menuInteractive) 1
}
if {[lsearch [image types] test] < 0} {
@@ -31,8 +31,8 @@ if {[lsearch [image types] test] < 0} {
return
}
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
proc deleteWindows {} {
@@ -1042,4 +1042,7 @@ test winMenu-33.2 {TkpNotifyTopLevelCreate - menu} {
test winMenu-34.1 {TkpMenuInit called at boot time} {} {}
+# cleanup
deleteWindows
+::test::cleanupTests
+return
diff --git a/tests/winSend.test b/tests/winSend.test
index 70ac07c..5e116cb 100644
--- a/tests/winSend.test
+++ b/tests/winSend.test
@@ -4,18 +4,18 @@
#
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1994-1996 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.
-#
-# RCS: @(#) $Id: winSend.test,v 1.1.2.2 1998/09/30 02:19:07 stanton Exp $
+# RCS: @(#) $Id: winSend.test,v 1.1.2.3 1999/03/11 18:51:22 hershey Exp $
if {$tcl_platform(platform) != "windows"} {
+ puts "skipping: Windows only tests..."
return
}
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
foreach i [winfo children .] {
@@ -413,3 +413,6 @@ while {[llength $newInterps] != [llength $currentInterps]} {
}
}
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/winWm.test b/tests/winWm.test
index 06b0219..25ddb72 100644
--- a/tests/winWm.test
+++ b/tests/winWm.test
@@ -6,18 +6,18 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996 by 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.
-#
-# RCS: @(#) $Id: winWm.test,v 1.1.4.1 1998/09/30 02:19:08 stanton Exp $
+# RCS: @(#) $Id: winWm.test,v 1.1.4.2 1999/03/11 18:51:23 hershey Exp $
if {$tcl_platform(platform) != "windows"} {
+ puts "skipping: Windows only tests..."
return
}
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
foreach i [winfo children .] {
@@ -217,3 +217,7 @@ test winWm-5.2 {UpdateGeometryInfo: menu resizing} {
destroy .t
set result
} {50 50 0}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/window.test b/tests/window.test
index 4573f5f..25306f8 100644
--- a/tests/window.test
+++ b/tests/window.test
@@ -2,14 +2,13 @@
# tkWindow.c. It is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1995 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.
-#
-# RCS: @(#) $Id: window.test,v 1.1.4.1 1998/09/30 02:19:08 stanton Exp $
+# RCS: @(#) $Id: window.test,v 1.1.4.2 1999/03/11 18:51:24 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]
}
foreach i [winfo children .] {
@@ -135,3 +134,7 @@ test window-5.1 {Tk_MakeWindowExist procedure, stacking order and menubars} unix
update
# If stacking order isn't handled properly, generates an X error.
} {}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/winfo.test b/tests/winfo.test
index 5cd0098..052e5a6 100644
--- a/tests/winfo.test
+++ b/tests/winfo.test
@@ -3,14 +3,13 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-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.
-#
-# RCS: @(#) $Id: winfo.test,v 1.1.4.2 1998/09/30 02:19:09 stanton Exp $
+# RCS: @(#) $Id: winfo.test,v 1.1.4.3 1999/03/11 18:51:24 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]
}
foreach i [winfo children .] {
@@ -365,3 +364,7 @@ test winfo-13.4 {[winfo containing] with embedded windows} {winCrash} {
foreach i [winfo children .] {
catch {destroy $i}
}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/xmfbox.test b/tests/xmfbox.test
index 6381c70..554d05b 100644
--- a/tests/xmfbox.test
+++ b/tests/xmfbox.test
@@ -6,14 +6,13 @@
# to call the internal Tcl procedures in xmfbox.tcl directly.
#
# 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.
-#
-# RCS: @(#) $Id: xmfbox.test,v 1.1.2.2 1998/09/30 02:19:09 stanton Exp $
+# RCS: @(#) $Id: xmfbox.test,v 1.1.2.3 1999/03/11 18:51:25 hershey Exp $
-if {[string compare test [info procs test]] == 1} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
if {$tcl_platform(platform) != "unix"} {
@@ -142,5 +141,7 @@ test xmfbox-2.5 {tkMotifFDialog_ActivateFList, ~ in file names} {
list $foo(selectPath) $foo(selectFile) $tkPriv(selectFilePath)
} [list $testPWD ~nosuchuser1 $testPWD/~nosuchuser1]
+# cleanup
cleanup
+::test::cleanupTests
return