diff options
author | hershey <hershey> | 1999-03-11 18:50:35 (GMT) |
---|---|---|
committer | hershey <hershey> | 1999-03-11 18:50:35 (GMT) |
commit | 95793f0a86f9a589b52f49eee1af88cad60d3815 (patch) | |
tree | 7ac15d9a4b9c10b48e56cb919ad0cab43610f7c5 | |
parent | 69ee2609ee8597545759c164761f5ee1b2dc288a (diff) | |
download | tk-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.
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 |