summaryrefslogtreecommitdiffstats
path: root/Lib/idlelib/ToolTip.py
blob: ce7a3d3ee5253abdb59cc3a7981e6eba27f3d822 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
# general purpose 'tooltip' routines - currently unused in idlefork
# (although the 'calltips' extension is partly based on this code)
# may be useful for some purposes in (or almost in ;) the current project scope
# Ideas gleaned from PySol

from Tkinter import *

class ToolTipBase:

    def __init__(self, button):
        self.button = button
        self.tipwindow = None
        self.id = None
        self.x = self.y = 0
        self._id1 = self.button.bind("<Enter>", self.enter)
        self._id2 = self.button.bind("<Leave>", self.leave)
        self._id3 = self.button.bind("<ButtonPress>", self.leave)

    def enter(self, event=None):
        self.schedule()

    def leave(self, event=None):
        self.unschedule()
        self.hidetip()

    def schedule(self):
        self.unschedule()
        self.id = self.button.after(1500, self.showtip)

    def unschedule(self):
        id = self.id
        self.id = None
        if id:
            self.button.after_cancel(id)

    def showtip(self):
        if self.tipwindow:
            return
        # The tip window must be completely outside the button;
        # otherwise when the mouse enters the tip window we get
        # a leave event and it disappears, and then we get an enter
        # event and it reappears, and so on forever :-(
        x = self.button.winfo_rootx() + 20
        y = self.button.winfo_rooty() + self.button.winfo_height() + 1
        self.tipwindow = tw = Toplevel(self.button)
        tw.wm_overrideredirect(1)
        tw.wm_geometry("+%d+%d" % (x, y))
        self.showcontents()

    def showcontents(self, text="Your text here"):
        # Override this in derived class
        label = Label(self.tipwindow, text=text, justify=LEFT,
                      background="#ffffe0", relief=SOLID, borderwidth=1)
        label.pack()

    def hidetip(self):
        tw = self.tipwindow
        self.tipwindow = None
        if tw:
            tw.destroy()

class ToolTip(ToolTipBase):
    def __init__(self, button, text):
        ToolTipBase.__init__(self, button)
        self.text = text
    def showcontents(self):
        ToolTipBase.showcontents(self, self.text)

class ListboxToolTip(ToolTipBase):
    def __init__(self, button, items):
        ToolTipBase.__init__(self, button)
        self.items = items
    def showcontents(self):
        listbox = Listbox(self.tipwindow, background="#ffffe0")
        listbox.pack()
        for item in self.items:
            listbox.insert(END, item)

def main():
    # Test code
    root = Tk()
    b = Button(root, text="Hello", command=root.destroy)
    b.pack()
    root.update()
    tip = ListboxToolTip(b, ["Hello", "world"])
    root.mainloop()

if __name__ == '__main__':
    main()
on> Tk is a free and open-source, cross-platform widget toolkit that provides a library of basic elements of GUI widgets for building a graphical user interface (GUI) in many programming languages.
summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorhershey <hershey>1999-03-11 18:50:35 (GMT)
committerhershey <hershey>1999-03-11 18:50:35 (GMT)
commit95793f0a86f9a589b52f49eee1af88cad60d3815 (patch)
tree7ac15d9a4b9c10b48e56cb919ad0cab43610f7c5
parent69ee2609ee8597545759c164761f5ee1b2dc288a (diff)
downloadtk-95793f0a86f9a589b52f49eee1af88cad60d3815.zip
tk-95793f0a86f9a589b52f49eee1af88cad60d3815.tar.gz
tk-95793f0a86f9a589b52f49eee1af88cad60d3815.tar.bz2
Updated the testsuite to use "test" namespace and commandline args
to control verbose level and which tests get run. Tests now work from any working dir.
Diffstat
-rw-r--r--tests/README268
-rw-r--r--tests/all77
-rw-r--r--tests/all.tcl71
-rw-r--r--tests/bell.test16
-rw-r--r--tests/bgerror.test15
-rw-r--r--tests/bind.test16
-rw-r--r--tests/bitmap.test15
-rw-r--r--tests/border.test15
-rw-r--r--tests/button.test15
-rw-r--r--tests/canvImg.test15
-rw-r--r--tests/canvPs.test17
-rw-r--r--tests/canvRect.test15
-rw-r--r--tests/canvText.test14
-rw-r--r--tests/canvWind.test17
-rw-r--r--tests/canvas.test16
-rw-r--r--tests/clipboard.test15
-rw-r--r--tests/clrpick.test15
-rw-r--r--tests/cmds.test15
-rw-r--r--tests/color.test19
-rw-r--r--tests/config.test14
-rw-r--r--tests/cursor.test15
-rw-r--r--tests/defs392
-rw-r--r--tests/defs.tcl915
-rw-r--r--tests/entry.test16
-rw-r--r--tests/event.test15
-rw-r--r--tests/filebox.test19
-rw-r--r--tests/focus.test16
-rw-r--r--tests/focusTcl.test15
-rw-r--r--tests/font.test18
-rw-r--r--tests/frame.test15
-rw-r--r--tests/geometry.test17
-rw-r--r--tests/get.test15
-rw-r--r--tests/grid.test15
-rw-r--r--tests/id.test15
-rw-r--r--tests/image.test15
-rw-r--r--tests/imgBmap.test15
-rw-r--r--tests/imgPPM.test15
-rw-r--r--tests/imgPhoto.test27
-rw-r--r--tests/listbox.test15
-rw-r--r--tests/macEmbed.test16
-rw-r--r--tests/macFont.test20
-rw-r--r--tests/macMenu.test16
-rw-r--r--tests/macWinMenu.test15
-rw-r--r--tests/macscrollbar.test21
-rw-r--r--tests/main.test17
-rw-r--r--tests/menu.test18
-rw-r--r--tests/menuDraw.test18
-rw-r--r--tests/menubut.test14
-rw-r--r--tests/msgbox.test15
-rw-r--r--tests/obj.test14
-rw-r--r--tests/oldpack.test17
-rw-r--r--tests/option.test29
-rw-r--r--tests/pack.test16
-rw-r--r--tests/place.test16
-rw-r--r--tests/raise.test16
-rw-r--r--tests/safe.test14
-rw-r--r--tests/scale.test15
-rw-r--r--tests/scrollbar.test16
-rw-r--r--tests/select.test34
-rw-r--r--tests/send.test23
-rw-r--r--tests/text.test16
-rw-r--r--tests/textBTree.test17
-rw-r--r--tests/textDisp.test21
-rw-r--r--tests/textImage.test24
-rw-r--r--tests/textIndex.test16
-rw-r--r--tests/textMark.test17
-rw-r--r--tests/textTag.test17
-rw-r--r--tests/textWind.test16
-rw-r--r--tests/tk.test15
-rw-r--r--tests/unixButton.test16
-rw-r--r--tests/unixEmbed.test16
-rw-r--r--tests/unixFont.test15
-rw-r--r--tests/unixMenu.test15
-rw-r--r--tests/unixSend.test25
-rw-r--r--tests/unixWm.test17
-rw-r--r--tests/util.test16
-rw-r--r--tests/visual.test15
-rw-r--r--tests/winButton.test15
-rw-r--r--tests/winClipboard.test15
-rw-r--r--tests/winDialog.test18
-rw-r--r--tests/winFont.test15
-rw-r--r--tests/winMenu.test19
-rw-r--r--tests/winSend.test15
-rw-r--r--tests/winWm.test16
-rw-r--r--tests/window.test15
-rw-r--r--tests/winfo.test15
-rw-r--r--tests/xmfbox.test13
87 files changed, 2036 insertions, 1059 deletions
diff --git a/tests/README b/tests/README
index 5aaea27..4f75cdb 100644
--- a/tests/README
+++ b/tests/README
@@ -1,30 +1,238 @@
-Tk Test Suite
---------------
-
-RCS: @(#) $Id: README,v 1.1.4.1 1998/09/30 02:18:21 stanton Exp $
-
-This directory contains a set of validation tests for Tk.
-Each of the files whose name ends in ".test" is intended to
-fully exercise one or a few Tk features. The features
-tested by a given file are listed in the first line of the
-file. The test suite is nowhere near complete yet. Contributions
-of additional tests would be most welcome.
-
-You can run the tests in two ways:
- (a) type "make test" in the directory ../unix; this will run all of
- the tests.
- (b) start up tktest in this directory, then "source" the test
- file (for example, type "source pack.test"). To run all
- of the tests, type "source all".
-In either case no output will be generated if all goes well, except
-for a listing of the tests. If there are errors then additional
-messages will appear.
-
-For more details on the testing environment, see the README
-file in the Tcl test directory.
-
-You can also run a set of visual tests, which create various screens
-that you can verify visually for appropriate behavior. The visual
-tests are available through the "visual" script: if you invoke this
-script, it creates a main window with a bunch of menus. Each menu
-runs a particular test.
+README -- Tk test suite design document.
+
+RCS: @(#) $Id: README,v 1.1.4.2 1999/03/11 18:50:35 hershey Exp $
+
+
+Introduction:
+-------------
+
+This directory contains a set of validation tests for the Tk
+commands. Each of the files whose name ends in ".test" is
+intended to fully exercise one or a few Tk commands. The
+commands tested by a given file are listed in the first line
+of the file.
+
+You can run the tests in three ways:
+
+ (a) type "make test" in ../unix; this will run all of the tests.
+
+ (b) type "tktest <testFile> ?<option> <value>?
+
+ (c) start up tktest in this directory, then "source" the test
+ file (for example, type "source parse.test"). To run all
+ of the tests, type "source all.tcl".
+
+In all cases, no output will be generated if all goes well, except for
+a listing of the tests.. If there are errors then additional messages
+will appear in the format described below. Note that some tests will
+be skipped if you run as superuser.
+
+This approach to testing was designed and initially implemented
+by Mary Ann May-Pumphrey of Sun Microsystems. Many thanks to
+her for donating her work back to the public Tcl release.
+
+The rest of this file provides additional information on the
+features of the testing environment.
+
+
+Definitions file:
+-----------------
+
+The file "defs.tcl" defines the "test" namespace which contains a
+collection of procedures and variables used to run the tests. It is
+read in automatically by each of the .test files if needed, but once
+it has been read once it will not be read again by the .test files.
+Currently, the following procedures are exported from the "test"
+namespace and automatically imported:
+
+ cleanupTests dotests saveState restoreState normalizeMsg
+ makeFile removeFile makeDirectory removeDirectory viewFile
+ safeFetch bytestring set_iso8859_1_locale restore_locale
+ setTmpDir setupbg dobg bgReady cleanupbg fixfocus
+
+Please refer to the defs.tcl file for these procedures' specs.
+
+To keep tests from polluting the current working directory with
+unwanted files, you can specify a temporary directory, which will
+become the current working directory for the tests, by specifying
+-tmpdir on the command line or by calling the ::test::setTmpDir
+procedure (after sourcing the defs.tcl file). The default working dir
+is the directory from which tktest was called. Please note that when
+you run the test suite by calling "make test", the working dir is
+<tk8.1>/tests.
+
+
+Test output:
+------------
+
+Foreach test file, the number of tests passed, skipped, and failed is
+printed to stdout. Aside from this statistical information, output
+can be controlled on a per-test basis by the ::test::verbose variable.
+
+::test::verbose can be set to any substring or permutation of "bps".
+The default value of ::test::verbose is "b". If 'b' is present, then
+the entire test is printed for each failed test, otherwise only the
+test's name, desired output, and actual output, are printed for each
+failed test. If 'p' is present, then a line is printed for each
+passed test, otherwise no line is printed for passed tests. If 's' is
+present, then a line (containing the consraints taht cause the test to
+be skipped) is printed for each skipped test, otherwise no line is
+printed for skipped tests.
+
+You can set ::test::verbose either interactively (after the defs.tcl
+file has been sourced) or by the command line argument -verbose, for
+example:
+
+ tktest select.test -verbose "psb"
+
+
+Selecting files to be sourced by all.tcl:
+-----------------------------------------
+
+You can specify the files you want all.tcl to source on the command
+line with the -file options. For example, if you call the
+following:
+
+ tktest all.tcl -file canv*.test
+
+all files in <tk8.1>/tests that match the pattern canv*.test will be
+sourced by the all.tcl file. Another useful example is if a
+particular test hangs, say "grid.test", and you just want to run the
+remaining tests, then you can call the following:
+
+ tktest all.tcl -file [h-z]*.test
+
+Note that the argument to -file will be substituted relative to the
+directory containing this file.
+
+
+Selecting tests for execution within a file:
+--------------------------------------------
+
+Normally, all the tests in a file are run whenever the file is
+sourced. Each test will be skipped if it doesn't match (using glob
+sytle matching) any element in the ::test::matchingTests variable, if
+it matches (using glob sytle matching) an element in
+::test::skippingTests, or if one of the elements of "constraints"
+turns out not to be true.
+
+You can set ::test::matchingTests and/or ::test::skippingTests either
+interactively (after the defs.tcl file has been sourced), or by the
+command line arguments -match and -skip, for example:
+
+ tktest select.test -match "*2.* *4.*" -skip "*2.33*"
+
+The three constraints: notIfCompiled, knownBug, and nonPortable can be
+overridden either interactively (after the defs.tcl file has been
+sourced) by setting the ::test::testConfig(<constraint>) variable, or
+by using the -constraints command line option with the name of the
+constraint in the argument. The following example shows how to run
+tests that are constrained by the knownBug and nonPortable
+restricions:
+
+ tktest all.tcl -constraints "knownBug nonPortable"
+
+See the defs.tcl file for information about each of these constraints.
+Other constraints can be added at any time. See the "Writing a new
+test" section below for more details about using built-in constraints
+and adding new ones.
+
+Adding a New Test File:
+-----------------------
+
+If the file matches the tests/*.test pattern (as it should), then it
+will automatically be run by the all.tcl file. Make sure your test
+file can be run from any working dir. Running the following should
+work the same from any cwd:
+
+ tktest <Tk8.1>/tests/all.tcl
+
+Make sure no temporary files are left behind by your test file. Your
+test file should call "::test::cleanupTests" before returning. The
+::test::cleanupTests procedure prints statistics about the number of
+tests that passed, skipped, and failed, and removes all files the were
+created using the ::test::makeFile and ::test::makeDirectory
+procedures.
+
+Be sure your tests can run cross-platform in both the build
+environment as well as the installation environment. If your test
+file contains tests that should not be run in or more of those cases,
+please use the constraints mechanism described in the next section to
+skip those tests.
+
+
+Writing a new test:
+-------------------
+
+The following is the spec for the "test" command:
+
+ test <name> <description> ?<constraint>? <script> <answer>
+
+The <name> field should be:
+
+ <target>-<majorNum>.<minorNum>
+
+For white-box (regression) tests, the target should be the name of the
+c function or Tk procedure being tested. For black-box tests, the
+target should be the name of the feature being tested. Related tests
+should share a major number.
+
+If your test requires that a file be created on the fly, please use
+the ::test::makeFile procedure. If your test requires that a small
+file (<50 lines) be checked in, please consider creating the file on
+the fly using the ::test::makeFile procedure. Files created by the
+::test::makeFile procedure will automatically be removed by the
+::test::cleanupTests call at the end of each test file.
+
+Add appropriate constraints (e.g., unixOnly) to any tests that should
+not always be run. For example, a test that should only be run on
+Unix should look like the following:
+
+ test getAttribute-1.1 {testing file permissions} {unixOnly} {
+ lindex [file attributes foo.tcl] 5
+ } {00644}
+
+See the defs.tcl file for a list of built-in flags. You can add any
+constraints that you need. The following is how the defs.tcl file
+adds the "unixOnly" constraint:
+
+ set ::test::testConfig(unixOnly) [expr {$tcl_platform(platform) == "unix"}]
+
+
+Saving keystrokes:
+------------------
+
+A convenience procedure named "::test::dotests" is included in file
+"defs.tcl". It takes two arguments--the name of the test file (such
+as "parse.test"), and a pattern selecting the tests you want to
+execute. It sets ::test::matching to the second argument, calls
+"source" on the file specified in the first argument, and restores
+::test::matching to its pre-call value at the end.
+
+
+Incompatibilities with prior Tk versions:
+------------------------------------------
+
+1) Global variables such as VERBOSE, TESTS, and testConfig are now
+ renamed to use the new "test" namespace.
+
+ old name new name
+ -------- --------
+ VERBOSE ::test::verbose
+ TESTS ::test::matchingTests
+ testConfig ::test::testConfig
+
+ The introduction of the "test" namespace is a precursor to using a
+ "test" package. This next step will be part of a future Tk
+ version.
+
+2) VERBOSE values are no longer numeric. Please see the section above
+ on "Test output" for the new usage of the ::test::verbose variable.
+
+3) When you run "make test", the working dir for the test suite is now
+ the one from which you called "make test", rather than the
+ <tk8.1>/tests directory. This change allows for both unix and
+ windows test suites to be run simultaneously without interference.
+ All tests must now run independently of their working directory.
+ You can also control the working directory from the tktest command
+ line with the -tmpdir option.
diff --git a/tests/all b/tests/all
deleted file mode 100644
index 6ca20b5..0000000
--- a/tests/all
+++ /dev/null
@@ -1,77 +0,0 @@
-# This file contains a top-level script to run all of the Tcl
-# tests. Execute it by invoking "source all" when running tclTest
-# in this directory.
-#
-# RCS: @(#) $Id: all,v 1.1.4.3 1998/12/10 03:43:54 stanton Exp $
-
-set TESTS_DIR [file join [pwd] [file dirname [info script]]]
-source [file join $TESTS_DIR defs]
-set currentDir [pwd]
-
-catch {array set flag $argv}
-set requiredSourceFiles [list arc.tcl bugs.tcl butGeom2.tcl \
- canvPsBmap.tcl canvPsText.tcl bevel.tcl butGeom.tcl \
- canvPsArc.tcl canvPsGrph.tcl cmap.tcl filebox.test \
- option.file1 option.file2 visual README defs]
-
-#
-# Set the TMP_DIR to pwd or the arg of -tmpdir, if given.
-#
-
-if {[info exists flag(-tmpdir)]} {
- set TMP_DIR $flag(-tmpdir)
- if {![file exists $TMP_DIR]} {
- if {[catch {file mkdir $TMP_DIR} msg]} {
- error "bad argument \"$flag(-tmpdir)\" to -tmpdir:\n$msg"
- }
- file mkdir $TMP_DIR
- } elseif {![file isdir $TMP_DIR]} {
- error "bad argument \"$flag(-tmpdir)\" to -tmpdir:\n$TMP_DIR is not a directory"
- }
- if {[string compare [file pathtype $TMP_DIR] absolute] != 0} {
- set TMP_DIR [file join [pwd] $TMP_DIR]
- }
- cd $TMP_DIR
-}
-
-#
-# copy each required source file to the current dir (if it's not already there).
-#
-
-if {[string compare $TESTS_DIR [pwd]] != 0} {
-
- foreach file $requiredSourceFiles {
- if {![file exists $file]} {
- catch {file copy [file join $TESTS_DIR $file] .}
- }
- }
-}
-
-if {$tcl_platform(os) == "Win32s"} {
- set globPattern [file join $TESTS_DIR *.tes]
-} else {
- set globPattern [file join $TESTS_DIR *.test]
-}
-
-foreach file [lsort [glob $globPattern]] {
- set tail [file tail $file]
- if {[string match l.*.test $tail]} {
- # This is an SCCS lockfile; ignore it
- continue
- }
- puts stdout $tail
- if {[catch {source $file} msg]} {
- puts stdout $msg
- }
-}
-
-# remove the required source files from the current dir.
-if {[info exists TMP_DIR]} {
- foreach file $requiredSourceFiles {
- catch {file delete -force $file}
- }
- cd $currentDir
-}
-
-catch {destroy .}
-exit
diff --git a/tests/all.tcl b/tests/all.tcl
new file mode 100644
index 0000000..600be5b
--- /dev/null
+++ b/tests/all.tcl
@@ -0,0 +1,71 @@
+# all.tcl --
+#
+# This file contains a top-level script to run all of the Tk
+# tests. Execute it by invoking "source all.tcl" when running tktest
+# in this directory.
+#
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+#
+# RCS: @(#) $Id: all.tcl,v 1.1.2.1 1999/03/11 18:50:36 hershey Exp $
+
+# extra files: arc.tcl bugs.tcl butGeom2.tcl \
+# canvPsBmap.tcl canvPsText.tcl bevel.tcl butGeom.tcl \
+# canvPsArc.tcl canvPsGrph.tcl cmap.tcl filebox.test \
+# visual
+
+# trouble files: unixWm.test filebox.test
+
+if {[lsearch ::test [namespace children]] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
+puts stdout "Tk 8.1 tests running in interp: [info nameofexecutable]"
+puts stdout "Tests running in working dir: $::test::tmpDir"
+if {[llength $::test::skippingTests] > 0} {
+ puts stdout "Skipping tests that match: $::test::skippingTests"
+}
+if {[llength $::test::matchingTests] > 0} {
+ puts stdout "Only running tests that match: $::test::matchingTests"
+}
+
+# Use command line specified glob pattern (specified by -file or -f)
+# if one exists. Otherwise use *.test (or *.tes on win32s). If given,
+# the file pattern should be specified relative to the dir containing
+# this file. If no files are found to match the pattern, print an
+# error message and exit.
+set fileIndex [expr {[lsearch $argv "-file"] + 1}]
+set fIndex [expr {[lsearch $argv "-f"] + 1}]
+if {($fileIndex < 1) || ($fIndex > $fileIndex)} {
+ set fileIndex $fIndex
+}
+if {$fileIndex > 0} {
+ set globPattern [file join $::test::testsDir [lindex $argv $fileIndex]]
+ puts stdout "Sourcing files that match: $globPattern"
+} elseif {$tcl_platform(os) == "Win32s"} {
+ set [file join $::test::testsDir globPattern *.tes]
+} else {
+ set [file join $::test::testsDir globPattern *.test]
+}
+set fileList [glob -nocomplain $globPattern]
+if {[llength $fileList] < 1} {
+ puts "Error: no files found matching $globPattern"
+ exit
+}
+
+set timeCmd {clock format [clock seconds]}
+puts stdout "Tests began at [eval $timeCmd]"
+foreach file [lsort $fileList] {
+ set tail [file tail $file]
+ if {[string match l.*.test $tail]} {
+ # This is an SCCS lockfile; ignore it
+ continue
+ }
+ puts stdout $tail
+ if {[catch {source $file} msg]} {
+ puts stdout $msg
+ }
+}
+puts stdout "\nTests ended at [eval $timeCmd]"
+
+catch {destroy .}
+exit
diff --git a/tests/bell.test b/tests/bell.test
index 1bf62c6..9fc3ede 100644
--- a/tests/bell.test
+++ b/tests/bell.test
@@ -2,15 +2,13 @@
# It is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1994 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: bell.test,v 1.1.4.1 1998/09/30 02:18:22 stanton Exp $
+# RCS: @(#) $Id: bell.test,v 1.1.4.2 1999/03/11 18:50:36 hershey Exp $
-if {[string compare test [info procs test]] == 1} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
test bell-1.1 {bell command} {
@@ -32,3 +30,7 @@ test bell-1.4 {bell command} {
after 200
bell
} {}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/bgerror.test b/tests/bgerror.test
index c99f216..dff98f5 100644
--- a/tests/bgerror.test
+++ b/tests/bgerror.test
@@ -2,17 +2,15 @@
# It is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: bgerror.test,v 1.1.4.1 1998/09/30 02:18:23 stanton Exp $
+# RCS: @(#) $Id: bgerror.test,v 1.1.4.2 1999/03/11 18:50:36 hershey Exp $
-if {[info commands test] == ""} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
-
test bgerror-1.1 {bgerror / tkerror compat} {
set errRes {}
proc tkerror {err} {
@@ -57,3 +55,6 @@ catch {rename tkerror {}}
# would be needed too, but that's not easy at all
# to emulate.
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/bind.test b/tests/bind.test
index 581abac..48e39d5 100644
--- a/tests/bind.test
+++ b/tests/bind.test
@@ -4,15 +4,13 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-1995 Sun Microsystems, Inc.
-# Copyright (c) 1998 by Scriptics Corporation.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: bind.test,v 1.1.4.3 1998/11/25 21:16:39 stanton Exp $
+# RCS: @(#) $Id: bind.test,v 1.1.4.4 1999/03/11 18:50:37 hershey Exp $
-if {[string compare test [info procs test]] != 0} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
catch {destroy .b}
@@ -2569,3 +2567,7 @@ test bind-31.2 {MouseWheel events} {
destroy .b
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/bitmap.test b/tests/bitmap.test
index 6975f86..af4e542 100644
--- a/tests/bitmap.test
+++ b/tests/bitmap.test
@@ -3,14 +3,13 @@
# Tcl tests.
#
# Copyright (c) 1998 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: bitmap.test,v 1.1.2.2 1998/09/30 02:18:24 stanton Exp $
+# RCS: @(#) $Id: bitmap.test,v 1.1.2.3 1999/03/11 18:50:37 hershey Exp $
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
if {[info commands testbitmap] != "testbitmap"} {
@@ -97,3 +96,7 @@ test bitmap-4.1 {FreeBitmapObjProc} {
} {{{1 3}} {{1 2}} {{1 1}} {}}
destroy .t
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/border.test b/tests/border.test
index 835a807..a299392 100644
--- a/tests/border.test
+++ b/tests/border.test
@@ -2,14 +2,13 @@
# tkBorder.c. It is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1998 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: border.test,v 1.1.2.2 1998/09/30 02:18:25 stanton Exp $
+# RCS: @(#) $Id: border.test,v 1.1.2.3 1999/03/11 18:50:38 hershey Exp $
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
if {[info commands testborder] != "testborder"} {
@@ -174,3 +173,7 @@ test get-2.4 {Tk_GetReliefFromObj - error} {
} {1 {bad relief "upanddown": must be flat, groove, raised, ridge, solid, or sunken}}
destroy .t
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/button.test b/tests/button.test
index 0f3c494..24d6111 100644
--- a/tests/button.test
+++ b/tests/button.test
@@ -4,11 +4,10 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: button.test,v 1.1.4.2 1998/09/30 02:18:26 stanton Exp $
+# RCS: @(#) $Id: button.test,v 1.1.4.3 1999/03/11 18:50:38 hershey Exp $
if {[lsearch [image types] test] < 0} {
puts "This application hasn't been compiled with the \"test\""
@@ -17,8 +16,8 @@ if {[lsearch [image types] test] < 0} {
return
}
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
foreach i [winfo children .] {
@@ -779,3 +778,7 @@ test button-13.1 {button widget vs hidden commands} {
eval destroy [winfo children .]
option clear
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/canvImg.test b/tests/canvImg.test
index dbd9031..61cffc0 100644
--- a/tests/canvImg.test
+++ b/tests/canvImg.test
@@ -4,11 +4,10 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: canvImg.test,v 1.1.4.1 1998/09/30 02:18:27 stanton Exp $
+# RCS: @(#) $Id: canvImg.test,v 1.1.4.2 1999/03/11 18:50:39 hershey Exp $
if {[lsearch [image types] test] < 0} {
puts "This application hasn't been compiled with the \"test\" image"
@@ -17,8 +16,8 @@ if {[lsearch [image types] test] < 0} {
return
}
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
foreach i [winfo children .] {
@@ -395,3 +394,7 @@ test canvImg-11.3 {ImageChangedProc procedure} {
update
set y
} {{foo2 display 0 0 20 40 50 40}}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/canvPs.test b/tests/canvPs.test
index 2087a31..a4da7f7 100644
--- a/tests/canvPs.test
+++ b/tests/canvPs.test
@@ -3,14 +3,13 @@
# TkCanvPostscriptCmd in generic/tkCanvPs.c
#
# Copyright (c) 1995 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: canvPs.test,v 1.1.4.1 1998/09/30 02:18:27 stanton Exp $
+# RCS: @(#) $Id: canvPs.test,v 1.1.4.2 1999/03/11 18:50:40 hershey Exp $
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
foreach i [winfo children .] {
@@ -95,11 +94,11 @@ test canvPs-2.4 {test writing to channel and file, same output} {pcOnly} {
set status
} ok
-# Clean-up
-
+# cleanup
removeFile foo.ps
removeFile bar.ps
-
foreach i [winfo children .] {
destroy $i
}
+::test::cleanupTests
+return
diff --git a/tests/canvRect.test b/tests/canvRect.test
index d6d050f..5a2a34f 100644
--- a/tests/canvRect.test
+++ b/tests/canvRect.test
@@ -3,14 +3,13 @@
# in the standard fashion for Tcl tests.
#
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: canvRect.test,v 1.1.4.1 1998/09/30 02:18:29 stanton Exp $
+# RCS: @(#) $Id: canvRect.test,v 1.1.4.2 1999/03/11 18:50:40 hershey Exp $
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
foreach i [winfo children .] {
@@ -327,3 +326,7 @@ restore showpage
end
%%EOF
}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/canvText.test b/tests/canvText.test
index 3de8813..38de088 100644
--- a/tests/canvText.test
+++ b/tests/canvText.test
@@ -3,14 +3,13 @@
# fashion for Tcl tests.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: canvText.test,v 1.1.4.3 1998/11/25 21:16:40 stanton Exp $
+# RCS: @(#) $Id: canvText.test,v 1.1.4.4 1999/03/11 18:50:41 hershey Exp $
-if {"[info procs test]" != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
foreach i [winfo children .] {
@@ -491,3 +490,6 @@ restore showpage
end
%%EOF
"
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/canvWind.test b/tests/canvWind.test
index 0791998..0038dac 100644
--- a/tests/canvWind.test
+++ b/tests/canvWind.test
@@ -3,14 +3,13 @@
# fashion for Tcl tests.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: canvWind.test,v 1.1.4.2 1999/02/16 11:39:35 lfb Exp $
+# RCS: @(#) $Id: canvWind.test,v 1.1.4.3 1999/03/11 18:50:41 hershey Exp $
-if {"[info procs test]" != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
foreach i [winfo children .] {
@@ -131,4 +130,8 @@ test canvWind-1.4 {DisplayWinItem, windows off-screen horizontally} {
update
lappend x [list [winfo ismapped $f] [winfo x $f]]
} {{1 3} {1 -79} {0 -79} {1 255} {0 255}}
-catch {destroy .t} \ No newline at end of file
+catch {destroy .t}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/canvas.test b/tests/canvas.test
index 5807b52..7eb96c6 100644
--- a/tests/canvas.test
+++ b/tests/canvas.test
@@ -3,15 +3,13 @@
# standard fashion for Tcl tests.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998 by Scriptics Corporation.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: canvas.test,v 1.1.4.3 1998/11/25 21:16:40 stanton Exp $
+# RCS: @(#) $Id: canvas.test,v 1.1.4.4 1999/03/11 18:50:42 hershey Exp $
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
foreach i [winfo children .] {
@@ -245,3 +243,7 @@ test canvas-9.1 {canvas id creation and deletion} {
set x ""
} {}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/clipboard.test b/tests/clipboard.test
index b2f19d4..08e3f1e 100644
--- a/tests/clipboard.test
+++ b/tests/clipboard.test
@@ -3,19 +3,18 @@
# fashion for Tcl tests.
#
# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: clipboard.test,v 1.1.4.1 1998/09/30 02:18:31 stanton Exp $
+# RCS: @(#) $Id: clipboard.test,v 1.1.4.2 1999/03/11 18:50:42 hershey Exp $
#
# Note: Multiple display clipboard handling will only be tested if the
# environment variable TK_ALT_DISPLAY is set to an alternate display.
#
-if {[string compare test [info procs test]] == 1} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
eval destroy [winfo child .]
@@ -232,3 +231,7 @@ test clipboard-7.13 {Tk_ClipboardCmd procedure} {
test clipboard-7.14 {Tk_ClipboardCmd procedure} {
list [catch {clipboard error} msg] $msg
} {1 {bad option "error": must be clear or append}}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/clrpick.test b/tests/clrpick.test
index 133b333..7f2ca75 100644
--- a/tests/clrpick.test
+++ b/tests/clrpick.test
@@ -2,15 +2,14 @@
# It is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: clrpick.test,v 1.1.4.2 1998/09/30 02:18:31 stanton Exp $
+# RCS: @(#) $Id: clrpick.test,v 1.1.4.3 1999/03/11 18:50:43 hershey Exp $
#
-if {[string compare test [info procs test]] == 1} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
test clrpick-1.1 {tk_chooseColor command} {
@@ -213,3 +212,7 @@ test clrpick-3.2 {tk_chooseColor: background events} {
ToPressButton $parent cancel
tk_chooseColor -parent $parent -title "Press Cancel"
} ""
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/cmds.test b/tests/cmds.test
index 578b06b..8c5e932 100644
--- a/tests/cmds.test
+++ b/tests/cmds.test
@@ -2,14 +2,13 @@
# tkCmds.c. It is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: cmds.test,v 1.1.4.1 1998/09/30 02:18:32 stanton Exp $
+# RCS: @(#) $Id: cmds.test,v 1.1.4.2 1999/03/11 18:50:43 hershey Exp $
-if {[string compare test [info procs test]] == 1} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
eval destroy [winfo child .]
@@ -41,3 +40,7 @@ test cmds-1.5 {tkwait visibility, window gets deleted} {
after 100 {set x deleted; destroy .f}
list [catch {tkwait visibility .f.b} msg] $msg $x
} {1 {window ".f.b" was deleted before its visibility changed} deleted}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/color.test b/tests/color.test
index 528c1de..876632d 100644
--- a/tests/color.test
+++ b/tests/color.test
@@ -2,21 +2,20 @@
# tkColor.c. It is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1995-1998 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: color.test,v 1.1.4.2 1998/09/30 02:18:32 stanton Exp $
-
-if {[info procs test] != "test"} {
- source defs
-}
+# RCS: @(#) $Id: color.test,v 1.1.4.3 1999/03/11 18:50:44 hershey Exp $
if {[info commands testcolor] != "testcolor"} {
puts "testcolor command not available; skipping tests"
return
}
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
+
eval destroy [winfo children .]
wm geometry . {}
raise .
@@ -276,3 +275,7 @@ test color-4.1 {FreeColorObjProc} {
} {{{1 3}} {{1 2}} {{1 1}} {}}
destroy .t
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/config.test b/tests/config.test
index eec6634..724f0e3 100644
--- a/tests/config.test
+++ b/tests/config.test
@@ -3,11 +3,10 @@
# organized in the standard "white-box" fashion for Tcl tests.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: config.test,v 1.1.2.2 1998/09/30 02:18:33 stanton Exp $
+# RCS: @(#) $Id: config.test,v 1.1.2.3 1999/03/11 18:50:45 hershey Exp $
if {[info command testobjconfig] != "testobjconfig"} {
puts "This application hasn't been compiled with the \"testobjconfig\""
@@ -16,8 +15,8 @@ if {[info command testobjconfig] != "testobjconfig"} {
return
}
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
proc killTables {} {
@@ -819,5 +818,8 @@ test config-12.16 {GetObjectForOption - null values} {
[.a cget -cursor] [.a cget -window]
} {{} {} {} {} {} {} {} {}}
+# cleanup
eval destroy [winfo children .]
killTables
+::test::cleanupTests
+return
diff --git a/tests/cursor.test b/tests/cursor.test
index 8f5af68..84c9f29 100644
--- a/tests/cursor.test
+++ b/tests/cursor.test
@@ -3,14 +3,13 @@
# Tcl tests.
#
# Copyright (c) 1998 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: cursor.test,v 1.1.2.2 1998/09/30 02:18:33 stanton Exp $
+# RCS: @(#) $Id: cursor.test,v 1.1.2.3 1999/03/11 18:50:45 hershey Exp $
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
if {[info commands testcursor] != "testcursor"} {
@@ -97,3 +96,7 @@ test cursor-4.1 {FreeCursorObjProc} {
} {{{1 3}} {{1 2}} {{1 1}} {}}
destroy .t
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/defs b/tests/defs
deleted file mode 100644
index 8d4efda..0000000
--- a/tests/defs
+++ /dev/null
@@ -1,392 +0,0 @@
-# This file contains support code for the Tcl test suite. It is
-# normally sourced by the individual files in the test suite before
-# they run their tests. This improved approach to testing was designed
-# and initially implemented by Mary Ann May-Pumphrey of Sun Microsystems.
-#
-# Copyright (c) 1994-1997 Sun Microsystems, Inc.
-# Copyright (c) 1998 by Scriptics Corporation
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: defs,v 1.1.4.3 1998/12/10 03:43:54 stanton Exp $
-
-if {![info exists VERBOSE]} {
- set VERBOSE 0
-}
-if {![info exists TESTS]} {
- set TESTS {}
-}
-
-tk appname tktest
-wm title . tktest
-
-# Check configuration information that will determine which tests
-# to run. To do this, create an array testConfig. Each element
-# has a 0 or 1 value, and the following elements are defined:
-# unixOnly - 1 means this is a UNIX platform, so it's OK
-# to run tests that only work under UNIX.
-# macOnly - 1 means this is a Mac platform, so it's OK
-# to run tests that only work on Macs.
-# pcOnly - 1 means this is a PC platform, so it's OK to
-# run tests that only work on PCs.
-# unixOrPc - 1 means this is a UNIX or PC platform.
-# macOrPc - 1 means this is a Mac or PC platform.
-# macOrUnix - 1 means this is a Mac or UNIX platform.
-# nonPortable - 1 means this the tests are being running in
-# the master Tcl/Tk development environment;
-# Some tests are inherently non-portable because
-# they depend on things like word length, file system
-# configuration, window manager, etc. These tests
-# are only run in the main Tcl development directory
-# where the configuration is well known. The presence
-# of the file "doAllTests" in this directory indicates
-# that it is safe to run non-portable tests.
-# knownBug - The test is known to fail and the bug is not yet
-# fixed. The test will be run only if the file
-# "doBuggyTests" exists (intended for Tcl dev. group
-# internal use only).
-# fonts - 1 means that this platform uses fonts with
-# well-know geometries, so it is safe to run
-# tests that depend on particular font sizes.
-
-catch {unset testConfig}
-
-set testConfig(unixOnly) [expr {$tcl_platform(platform) == "unix"}]
-set testConfig(macOnly) [expr {$tcl_platform(platform) == "macintosh"}]
-set testConfig(pcOnly) [expr {$tcl_platform(platform) == "windows"}]
-
-set testConfig(unix) $testConfig(unixOnly)
-set testConfig(mac) $testConfig(macOnly)
-set testConfig(pc) $testConfig(pcOnly)
-
-set testConfig(unixOrPc) [expr {$testConfig(unixOnly) || $testConfig(pcOnly)}]
-set testConfig(macOrPc) [expr {$testConfig(macOnly) || $testConfig(pcOnly)}]
-set testConfig(macOrUnix) [expr {$testConfig(macOnly) || $testConfig(unixOnly)}]
-
-set testConfig(knownBug) [expr {[file exists doBuggyTests] || [file exists doBuggyT]}]
-set testConfig(nonPortable) [expr {[file exists doAllTests] || [file exists DOALLT~1]}]
-
-set testConfig(nt) [expr {$tcl_platform(os) == "Windows NT"}]
-set testConfig(95) [expr {$tcl_platform(os) == "Windows 95"}]
-set testConfig(win32s) [expr {$tcl_platform(os) == "Win32s"}]
-
-# The following config switches are used to mark tests that should work,
-# but have been temporarily disabled on certain platforms because they don't.
-
-set testConfig(tempNotPc) [expr {!$testConfig(pc)}]
-set testConfig(tempNotMac) [expr {!$testConfig(mac)}]
-set testConfig(tempNotUnix) [expr {!$testConfig(unix)}]
-
-# The following config switches are used to mark tests that crash on
-# certain platforms, so that they can be reactivated again when the
-# underlying problem is fixed.
-
-set testConfig(pcCrash) [expr {!$testConfig(pc)}]
-set testConfig(win32sCrash) [expr {!$testConfig(win32s)}]
-set testConfig(macCrash) [expr {!$testConfig(mac)}]
-set testConfig(unixCrash) [expr {!$testConfig(unix)}]
-
-set testConfig(fonts) 1
-catch {destroy .e}
-entry .e -width 0 -font {Helvetica -12} -bd 1
-.e insert end "a.bcd"
-if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} {
- set testConfig(fonts) 0
-}
-destroy .e
-catch {destroy .t}
-text .t -width 80 -height 20 -font {Times -14} -bd 1
-pack .t
-.t insert end "This is\na dot."
-update
-set x [list [.t bbox 1.3] [.t bbox 2.5]]
-destroy .t
-if {[string match {{22 3 6 15} {31 18 [34] 15}} $x] == 0} {
- set testConfig(fonts) 0
-}
-
-if {$testConfig(nonPortable) == 0} {
- puts stdout "(will skip non-portable tests)"
-}
-if {$testConfig(fonts) == 0} {
- puts stdout "(will skip font-sensitive tests: this system has unexpected font geometries)"
-}
-
-trace variable testConfig r safeFetch
-
-proc safeFetch {n1 n2 op} {
- global testConfig
-
- if {($n2 != {}) && ([info exists testConfig($n2)] == 0)} {
- set testConfig($n2) 0
- }
-}
-
-# If there is no "memory" command (because memory debugging isn't
-# enabled), generate a dummy command that does nothing.
-
-if {[info commands memory] == ""} {
- proc memory args {}
-}
-
-proc print_verbose {name description script code answer} {
- puts stdout "\n"
- puts stdout "==== $name $description"
- puts stdout "==== Contents of test case:"
- puts stdout "$script"
- if {$code != 0} {
- if {$code == 1} {
- puts stdout "==== Test generated error:"
- puts stdout $answer
- } elseif {$code == 2} {
- puts stdout "==== Test generated return exception; result was:"
- puts stdout $answer
- } elseif {$code == 3} {
- puts stdout "==== Test generated break exception"
- } elseif {$code == 4} {
- puts stdout "==== Test generated continue exception"
- } else {
- puts stdout "==== Test generated exception $code; message was:"
- puts stdout $answer
- }
- } else {
- puts stdout "==== Result was:"
- puts stdout "$answer"
- }
-}
-
-# test --
-# This procedure runs a test and prints an error message if the
-# test fails. If VERBOSE has been set, it also prints a message
-# even if the test succeeds. The test will be skipped if it
-# doesn't match the TESTS variable, or if one of the elements
-# of "constraints" turns out not to be true.
-#
-# Arguments:
-# name - Name of test, in the form foo-1.2.
-# description - Short textual description of the test, to
-# help humans understand what it does.
-# constraints - A list of one or more keywords, each of
-# which must be the name of an element in
-# the array "testConfig". If any of these
-# elements is zero, the test is skipped.
-# This argument may be omitted.
-# script - Script to run to carry out the test. It must
-# return a result that can be checked for
-# correctness.
-# answer - Expected result from script.
-
-proc test {name description script answer args} {
- global VERBOSE TESTS testConfig
- if {[string compare $TESTS ""] != 0} {
- set ok 0
- foreach test $TESTS {
- if {[string match $test $name]} {
- set ok 1
- break
- }
- }
- if {!$ok} {
- return
- }
- }
- set i [llength $args]
- if {$i == 0} {
- # Empty body
- } elseif {$i == 1} {
- # "constraints" argument exists; shuffle arguments down, then
- # make sure that the constraints are satisfied.
-
- set constraints $script
- set script $answer
- set answer [lindex $args 0]
- set doTest 0
- if {[string match {*[$\[]*} $constraints] != 0} {
- # full expression, e.g. {$foo > [info tclversion]}
-
- catch {set doTest [uplevel #0 expr $constraints]}
- } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} {
- # something like {a || b} should be turned into
- # $testConfig(a) || $testConfig(b).
-
- regsub -all {[.a-zA-Z0-9]+} $constraints {$testConfig(&)} c
- catch {set doTest [eval expr $c]}
- } else {
- # just simple constraints such as {unixOnly fonts}.
-
- set doTest 1
- foreach constraint $constraints {
- if {![info exists testConfig($constraint)]
- || !$testConfig($constraint)} {
- set doTest 0
- break
- }
- }
- }
- if {$doTest == 0} {
- if {$VERBOSE} {
- puts stdout "++++ $name SKIPPED: $constraints"
- }
- return
- }
- } else {
- error "wrong # args: must be \"test name description ?constraints? script answer\""
- }
- memory tag $name
- set code [catch {uplevel $script} result]
- if {$code != 0} {
- print_verbose $name $description $script $code $result
- } elseif {[string compare $result $answer] == 0} {
- if {$VERBOSE} {
- if {$VERBOSE > 0} {
- print_verbose $name $description $script $code $result
- }
- if {$VERBOSE != -2} {
- puts stdout "++++ $name PASSED"
- }
- }
- } else {
- print_verbose $name $description $script $code $result
- puts stdout "---- Result should have been:"
- puts stdout "$answer"
- puts stdout "---- $name FAILED"
- }
-}
-
-proc dotests {file args} {
- global TESTS
- set savedTests $TESTS
- set TESTS $args
- source $file
- set TESTS $savedTests
-}
-
-# If the main window isn't already mapped (e.g. because the tests are
-# being run automatically) , specify a precise size for it so that the
-# user won't have to position it manually.
-
-if {![winfo ismapped .]} {
- wm geometry . +0+0
- update
-}
-
-# The following code can be used to perform tests involving a second
-# process running in the background.
-
-# Locate tktest executable
-
-set tktest [info nameofexecutable]
-if {$tktest == "{}"} {
- set tktest {}
- puts stdout "Unable to find tktest executable, skipping multiple process tests."
-}
-
-# Create background process
-
-proc setupbg args {
- global tktest fd bgData
- if {$tktest == ""} {
- error "you're not running tktest so setupbg should not have been called"
- }
- if {[info exists fd] && ($fd != "")} {
- cleanupbg
- }
- set fd [open "|[list $tktest -geometry +0+0 -name tktest] $args" r+]
- puts $fd "puts foo; flush stdout"
- flush $fd
- if {[gets $fd data] < 0} {
- error "unexpected EOF from \"$tktest\""
- }
- if {[string compare $data foo]} {
- error "unexpected output from background process \"$data\""
- }
- fileevent $fd readable bgReady
-}
-
-# Send a command to the background process, catching errors and
-# flushing I/O channels
-proc dobg {command} {
- global fd bgData bgDone
- puts $fd "catch [list $command] msg; update; puts \$msg; puts **DONE**; flush stdout"
- flush $fd
- set bgDone 0
- set bgData {}
- tkwait variable bgDone
- set bgData
-}
-
-# Data arrived from background process. Check for special marker
-# indicating end of data for this command, and make data available
-# to dobg procedure.
-proc bgReady {} {
- global fd bgData bgDone
- set x [gets $fd]
- if {[eof $fd]} {
- fileevent $fd readable {}
- set bgDone 1
- } elseif {$x == "**DONE**"} {
- set bgDone 1
- } else {
- append bgData $x
- }
-}
-
-# Exit the background process, and close the pipes
-proc cleanupbg {} {
- global fd
- catch {
- puts $fd "exit"
- close $fd
- }
- set fd ""
-}
-
-# Clean up focus after using generate event, which
-# can leave the window manager with the wrong impression
-# about who thinks they have the focus. (BW)
-
-proc fixfocus {} {
- catch {destroy .focus}
- toplevel .focus
- wm geometry .focus +0+0
- entry .focus.e
- .focus.e insert 0 "fixfocus"
- pack .focus.e
- update
- focus -force .focus.e
- destroy .focus
-}
-
-proc makeFile {contents name} {
- set fd [open $name w]
- fconfigure $fd -translation lf
- if {[string index $contents [expr {[string length $contents] - 1}]] == "\n"} {
- puts -nonewline $fd $contents
- } else {
- puts $fd $contents
- }
- close $fd
-}
-
-proc removeFile {name} {
- file delete -- $name
-}
-
-#
-# Construct a string that consists of the requested sequence of bytes,
-# as opposed to a string of properly formed UTF-8 characters.
-# This allows the tester to
-# 1. Create denormalized or improperly formed strings to pass to C procedures
-# that are supposed to accept strings with embedded NULL bytes.
-# 2. Confirm that a string result has a certain pattern of bytes, for instance
-# to confirm that "\xe0\0" in a Tcl script is stored internally in
-# UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80".
-#
-# Generally, it's a bad idea to examine the bytes in a Tcl string or to
-# construct improperly formed strings in this manner, because it involves
-# exposing that Tcl uses UTF-8 internally.
-
-proc bytestring {string} {
- testencoding toutf $string identity
-}
diff --git a/tests/defs.tcl b/tests/defs.tcl
new file mode 100644
index 0000000..68b5f2c
--- /dev/null
+++ b/tests/defs.tcl
@@ -0,0 +1,915 @@
+# defs.tcl --
+#
+# This file contains support code for the Tk test suite.It is
+# It is normally sourced by the individual files in the test suite
+# before they run their tests. This improved approach to testing
+# was designed and initially implemented by Mary Ann May-Pumphrey
+# of Sun Microsystems.
+#
+# Copyright (c) 1990-1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+#
+# RCS: @(#) $Id: defs.tcl,v 1.1.2.1 1999/03/11 18:50:47 hershey Exp $
+
+tk appname tktest
+wm title . tktest
+
+# create the "test" namespace for all testing variables and procedures
+namespace eval test {
+ foreach proc [list test cleanupTests dotests saveState restoreState \
+ normalizeMsg makeFile removeFile makeDirectory removeDirectory \
+ viewFile safeFetch bytestring set_iso8859_1_locale restore_locale \
+ setTmpDir setupbg dobg bgReady cleanupbg fixfocus] {
+ namespace export $proc
+ }
+
+ # ::test::verbose defaults to "b"
+ variable verbose "b"
+
+ # matchingTests defaults to the empty list
+ variable matchingTests {}
+
+ # skippingTests defaults to the empty list
+ variable skippingTests {}
+
+ # Tests should not rely on the current working directory.
+ # Files that are part of the test suite should be accessed relative to
+ # ::test::testsDir.
+
+ set originalDir [pwd]
+ set tDir [file join $originalDir [file dirname [info script]]]
+ cd $tDir
+ variable testsDir [pwd]
+ cd $originalDir
+
+ # Tests should remove all files they create. The test suite will
+ # check tmpDir for files created by the tests. ::test::filesMade
+ # keeps track of such files created using the test::makeFile and
+ # test::makeDirectory procedures. ::test::filesExisted stores
+ # the names of pre-existing files.
+
+ variable filesMade {}
+ variable filesExisted {}
+
+ # initialize ::test::numTests array to keep track fo the number of
+ # tests that pass, fial, and are skipped.
+ array set numTests [list Total 0 Passed 0 Skipped 0 Failed 0]
+ #array set originalEnv [array get env]
+
+}
+
+# If there is no "memory" command (because memory debugging isn't
+# enabled), generate a dummy command that does nothing.
+
+if {[info commands memory] == ""} {
+ proc memory args {}
+}
+
+# ::test::setTmpDir --
+#
+# Set the ::test::tmpDir to the specified value. If the path
+# is relative, make it absolute. If the file exists but is not
+# a dir, then return an error. If the dir does not already
+# exist, create it. If you cannot create it, then return an error.
+#
+# Arguments:
+# value the new value of ::test::tmpDir
+#
+# Results:
+# ::test::tmpDir is set to <value> and created if it didn't already
+# exist. The working dir is changed to ::test::tmpDir.
+
+proc ::test::setTmpDir {value} {
+
+ set ::test::tmpDir $value
+
+ if {[string compare [file pathtype $::test::tmpDir] absolute] != 0} {
+ set ::test::tmpDir [file join [pwd] $::test::tmpDir]
+ }
+ if {[file exists $::test::tmpDir]} {
+ if {![file isdir $::test::tmpDir]} {
+ puts stderr "Error: bad argument \"$value\" to -tmpdir:"
+ puts stderr " \"$::test::tmpDir\""
+ puts stderr " is not a directory"
+ exit
+ }
+ } else {
+ file mkdir $::test::tmpDir
+ }
+
+ # change the working dir to tmpDir and add the existing files in
+ # tmpDir to the filesExisted list.
+ cd $::test::tmpDir
+ foreach file [glob -nocomplain [file join [pwd] *]] {
+ lappend ::test::filesExisted $file
+ }
+}
+
+# ::test::processCmdLineArgs --
+#
+# Use command line args to set the tmpDir, verbose, skippingTests, and
+# matchingTests variables.
+#
+# Arguments:
+# none
+#
+# Results:
+# ::test::verbose is set to <value>
+
+proc ::test::processCmdLineArgs {} {
+ global argv
+
+ # The "argv" var doesn't exist in some cases, so use {}
+ # The "argv" var doesn't exist in some cases.
+ if {(![info exists argv]) || ([llength $argv] < 2)} {
+ set flagArray {}
+ } else {
+ set flagArray $argv
+ }
+
+ if {[catch {array set flag $flagArray}]} {
+ puts stderr "Error: odd number of command line args specified:"
+ puts stderr " $argv"
+ exit
+ }
+
+ # Allow for 1-char abbreviations, where applicable (e.g., -tmpdir == -t).
+ # Note that -verbose cannot be abbreviated to -v because it conflicts
+ # with the wish option -visual.
+ foreach arg {-match -skip -constraints -tmpdir} {
+ set abbrev [string range $arg 0 1]
+ if {([info exists flag($abbrev)]) && \
+ ([lsearch $flagArray $arg] < [lsearch $flagArray $abbrev])} {
+ set flag($arg) $flag($abbrev)
+ }
+ }
+
+ # Set ::test::tmpDir to the arg of the -tmpdir flag, if given.
+ # ::test::tmpDir defaults to [pwd].
+ # Save the names of files that already exist in ::test::tmpDir.
+ if {[info exists flag(-tmpdir)]} {
+ ::test::setTmpDir $flag(-tmpdir)
+ } else {
+ set ::test::tmpDir [pwd]
+ }
+ foreach file [glob -nocomplain [file join $::test::tmpDir *]] {
+ lappend ::test::filesExisted [file tail $file]
+ }
+
+ # Set ::test::verbose to the arg of the -verbose flag, if given
+ if {[info exists flag(-verbose)]} {
+ set ::test::verbose $flag(-verbose)
+ }
+
+ # Set ::test::matchingTests to the arg of the -match flag, if given
+ if {[info exists flag(-match)]} {
+ set ::test::matchingTests $flag(-match)
+ }
+
+ # Set ::test::skippingTests to the arg of the -skip flag, if given
+ if {[info exists flag(-skip)]} {
+ set ::test::skippingTests $flag(-skip)
+ }
+
+ # Use the -constraints flag, if given, so turn on the following
+ # constraints: notIfCompiled, knownBug, nonPortable
+ if {[info exists flag(-constraints)]} {
+ set constrList $flag(-constraints)
+ } else {
+ set constrList {}
+ }
+ foreach elt [list notIfCompiled knownBug nonPortable] {
+ set ::test::testConfig($elt) [expr {[lsearch $constrList $elt] != -1}]
+ }
+ if {$::test::testConfig(nonPortable) == 0} {
+ puts "(will skip non-portable tests)"
+ }
+}
+test::processCmdLineArgs
+
+
+# Check configuration information that will determine which tests
+# to run. To do this, create an array ::test::testConfig. Each element
+# has a 0 or 1 value, and the following elements are defined:
+# unixOnly - 1 means this is a UNIX platform, so it's OK
+# to run tests that only work under UNIX.
+# macOnly - 1 means this is a Mac platform, so it's OK
+# to run tests that only work on Macs.
+# pcOnly - 1 means this is a PC platform, so it's OK to
+# run tests that only work on PCs.
+# unixOrPc - 1 means this is a UNIX or PC platform.
+# macOrPc - 1 means this is a Mac or PC platform.
+# macOrUnix - 1 means this is a Mac or UNIX platform.
+# notIfCompiled - 1 means this that it is safe to run tests that
+# might fail if the bytecode compiler is used. This
+# element is set to 1 if the -allComp flag was used.
+# Normally, this element is 0 so that tests that
+# fail with the bytecode compiler are skipped.
+# As of 11/2/96 these are the history tests since
+# they depend on accurate source location information.
+# You can run these tests by using the -constraint
+# command line option with "knownBug" in the argument
+# list.
+# knownBug - The test is known to fail and the bug is not yet
+# fixed. The test will be run only if the flag
+# -allBuggy is used (intended for Tcl dev. group
+# internal use only). You can run these tests by
+# using the -constraint command line option with
+# "knownBug" in the argument list.
+# nonPortable - 1 means this the tests are being running in
+# the master Tcl/Tk development environment;
+# Some tests are inherently non-portable because
+# they depend on things like word length, file system
+# configuration, window manager, etc. These tests
+# are only run in the main Tcl development directory
+# where the configuration is well known. You can
+# run these tests by using the -constraint command
+# line option with "nonPortable" in the argument list.
+
+catch {unset ::test::testConfig}
+
+# The following trace procedure makes it so that we can safely refer to
+# non-existent members of the ::test::testConfig array without causing an
+# error. Instead, reading a non-existent member will return 0. This is
+# necessary because tests are allowed to use constraint "X" without ensuring
+# that ::test::testConfig("X") is defined.
+
+trace variable ::test::testConfig r ::test::safeFetch
+
+proc ::test::safeFetch {n1 n2 op} {
+ if {($n2 != {}) && ([info exists ::test::testConfig($n2)] == 0)} {
+ set ::test::testConfig($n2) 0
+ }
+}
+
+set ::test::testConfig(unixOnly) [expr {$tcl_platform(platform) == "unix"}]
+set ::test::testConfig(macOnly) [expr {$tcl_platform(platform) == "macintosh"}]
+set ::test::testConfig(pcOnly) [expr {$tcl_platform(platform) == "windows"}]
+
+set ::test::testConfig(unix) $::test::testConfig(unixOnly)
+set ::test::testConfig(mac) $::test::testConfig(macOnly)
+set ::test::testConfig(pc) $::test::testConfig(pcOnly)
+
+set ::test::testConfig(unixOrPc) [expr {$::test::testConfig(unix) || $::test::testConfig(pc)}]
+set ::test::testConfig(macOrPc) [expr {$::test::testConfig(mac) || $::test::testConfig(pc)}]
+set ::test::testConfig(macOrUnix) [expr {$::test::testConfig(mac) || $::test::testConfig(unix)}]
+
+set ::test::testConfig(nt) [expr {$tcl_platform(os) == "Windows NT"}]
+set ::test::testConfig(95) [expr {$tcl_platform(os) == "Windows 95"}]
+set ::test::testConfig(win32s) [expr {$tcl_platform(os) == "Win32s"}]
+
+# The following config switches are used to mark tests that should work,
+# but have been temporarily disabled on certain platforms because they don't
+# and we haven't gotten around to fixing the underlying problem.
+
+set ::test::testConfig(tempNotPc) [expr {!$::test::testConfig(pc)}]
+set ::test::testConfig(tempNotMac) [expr {!$::test::testConfig(mac)}]
+set ::test::testConfig(tempNotUnix) [expr {!$::test::testConfig(unix)}]
+
+# The following config switches are used to mark tests that crash on
+# certain platforms, so that they can be reactivated again when the
+# underlying problem is fixed.
+
+set ::test::testConfig(pcCrash) [expr {!$::test::testConfig(pc)}]
+set ::test::testConfig(macCrash) [expr {!$::test::testConfig(mac)}]
+set ::test::testConfig(unixCrash) [expr {!$::test::testConfig(unix)}]
+
+if {[catch {set f [open defs r]}]} {
+ set ::test::testConfig(nonBlockFiles) 1
+} else {
+ if {[catch {fconfigure $f -blocking off}] == 0} {
+ set ::test::testConfig(nonBlockFiles) 1
+ } else {
+ set ::test::testConfig(nonBlockFiles) 0
+ }
+ close $f
+}
+
+# set the "fonts" constraint
+
+set ::test::testConfig(fonts) 1
+catch {destroy .e}
+entry .e -width 0 -font {Helvetica -12} -bd 1
+.e insert end "a.bcd"
+if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} {
+ set ::test::testConfig(fonts) 0
+}
+destroy .e
+catch {destroy .t}
+text .t -width 80 -height 20 -font {Times -14} -bd 1
+pack .t
+.t insert end "This is\na dot."
+update
+set x [list [.t bbox 1.3] [.t bbox 2.5]]
+destroy .t
+if {[string match {{22 3 6 15} {31 18 [34] 15}} $x] == 0} {
+ set ::test::testConfig(fonts) 0
+}
+if {$::test::testConfig(fonts) == 0} {
+ puts stdout "(will skip font-sensitive tests: this system has unexpected font geometries)"
+}
+
+# If tests are being run as root, issue a warning message and set a
+# variable to prevent some tests from running at all.
+
+set user {}
+if {$tcl_platform(platform) == "unix"} {
+ catch {set user [exec whoami]}
+ if {$user == ""} {
+ catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
+ }
+ if {$user == ""} {set user root}
+ if {$user == "root"} {
+ puts stdout "Warning: you're executing as root. I'll have to"
+ puts stdout "skip some of the tests, since they'll fail as root."
+ set ::test::testConfig(root) 1
+ }
+}
+
+# Test for SCO Unix - cannot run async flushing tests because a potential
+# problem with select is apparently interfering. (Mark Diekhans).
+
+if {$tcl_platform(platform) == "unix"} {
+ if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} {
+ set ::test::testConfig(asyncPipeClose) 0
+ } else {
+ set ::test::testConfig(asyncPipeClose) 1
+ }
+} else {
+ set ::test::testConfig(asyncPipeClose) 1
+}
+
+# Test to see if we have a broken version of sprintf with respect to the
+# "e" format of floating-point numbers.
+
+set ::test::testConfig(eformat) 1
+if {[string compare "[format %g 5e-5]" "5e-05"] != 0} {
+ set ::test::testConfig(eformat) 0
+ puts stdout "(will skip tests that depend on the \"e\" format of floating-point numbers)"
+}
+
+# Test to see if execed commands such as cat, echo, rm and so forth are
+# present on this machine.
+
+set ::test::testConfig(unixExecs) 1
+if {$tcl_platform(platform) == "macintosh"} {
+ set ::test::testConfig(unixExecs) 0
+}
+if {($::test::testConfig(unixExecs) == 1) && ($tcl_platform(platform) == "windows")} {
+ if {[catch {exec cat defs}] == 1} {
+ set ::test::testConfig(unixExecs) 0
+ }
+ if {($::test::testConfig(unixExecs) == 1) && ([catch {exec echo hello}] == 1)} {
+ set ::test::testConfig(unixExecs) 0
+ }
+ if {($::test::testConfig(unixExecs) == 1) && \
+ ([catch {exec sh -c echo hello}] == 1)} {
+ set ::test::testConfig(unixExecs) 0
+ }
+ if {($::test::testConfig(unixExecs) == 1) && ([catch {exec wc defs}] == 1)} {
+ set ::test::testConfig(unixExecs) 0
+ }
+ if {$::test::testConfig(unixExecs) == 1} {
+ exec echo hello > removeMe
+ if {[catch {exec rm removeMe}] == 1} {
+ set ::test::testConfig(unixExecs) 0
+ }
+ }
+ if {($::test::testConfig(unixExecs) == 1) && ([catch {exec sleep 1}] == 1)} {
+ set ::test::testConfig(unixExecs) 0
+ }
+ if {($::test::testConfig(unixExecs) == 1) && \
+ ([catch {exec fgrep unixExecs defs}] == 1)} {
+ set ::test::testConfig(unixExecs) 0
+ }
+ if {($::test::testConfig(unixExecs) == 1) && ([catch {exec ps}] == 1)} {
+ set ::test::testConfig(unixExecs) 0
+ }
+ if {($::test::testConfig(unixExecs) == 1) && \
+ ([catch {exec echo abc > removeMe}] == 0) && \
+ ([catch {exec chmod 644 removeMe}] == 1) && \
+ ([catch {exec rm removeMe}] == 0)} {
+ set ::test::testConfig(unixExecs) 0
+ } else {
+ catch {exec rm -f removeMe}
+ }
+ if {($::test::testConfig(unixExecs) == 1) && \
+ ([catch {exec mkdir removeMe}] == 1)} {
+ set ::test::testConfig(unixExecs) 0
+ } else {
+ catch {exec rm -r removeMe}
+ }
+ if {$::test::testConfig(unixExecs) == 0} {
+ puts "(will skip tests that depend on Unix-style executables)"
+ }
+}
+
+# ::test::cleanupTests --
+#
+# Print the number tests (total, passed, failed, and skipped) since the
+# last time this procedure was invoked.
+#
+# Remove files and dirs created using the makeFile and makeDirectory
+# commands since the last time this proc was invoked.
+#
+# Print the names of the files created without the makeFile command
+# since the last time this proc was invoked.
+#
+
+proc ::test::cleanupTests {} {
+ # print stats
+ puts -nonewline stdout "[file tail [info script]]:"
+ foreach index [list "Total" "Passed" "Skipped" "Failed"] {
+ puts -nonewline stdout "\t$index\t$::test::numTests($index)"
+ }
+ puts stdout ""
+
+ # remove files and directories created by the tests
+ foreach file $::test::filesMade {
+ if {[file exists $file]} {
+ catch {file delete -force $file}
+ }
+ }
+
+ # report the names of files in ::test::tmpDir that were not pre-existing.
+ set currentFiles {}
+ foreach file [glob -nocomplain [file join $::test::tmpDir *]] {
+ lappend currentFiles [file tail $file]
+ }
+ set filesNew {}
+ foreach file $currentFiles {
+ if {[lsearch $::test::filesExisted $file] == -1} {
+ lappend filesNew $file
+ }
+ }
+ if {[llength $filesNew] > 0} {
+ puts stdout "\t\tFiles created:\t$filesNew"
+ }
+
+ # reset filesMade, filesExisted, and numTests
+ foreach index [list "Total" "Passed" "Skipped" "Failed"] {
+ set ::test::numTests($index) 0
+ }
+ set ::test::filesMade {}
+ set ::test::filesExisted $currentFiles
+}
+
+
+# test --
+#
+# This procedure runs a test and prints an error message if the test fails.
+# If ::test::verbose has been set, it also prints a message even if the
+# test succeeds. The test will be skipped if it doesn't match the
+# ::test::matchingTests variable, if it matches an element in
+# ::test::skippingTests, or if one of the elements of "constraints" turns
+# out not to be true.
+#
+# Arguments:
+# name - Name of test, in the form foo-1.2.
+# description - Short textual description of the test, to
+# help humans understand what it does.
+# constraints - A list of one or more keywords, each of
+# which must be the name of an element in
+# the array "::test::testConfig". If any of these
+# elements is zero, the test is skipped.
+# This argument may be omitted.
+# script - Script to run to carry out the test. It must
+# return a result that can be checked for
+# correctness.
+# expectedAnswer - Expected result from script.
+
+proc ::test::test {name description script expectedAnswer args} {
+ incr ::test::numTests(Total)
+
+ # skip the test if it's name matches an element of skippingTests
+ foreach pattern $::test::skippingTests {
+ if {[string match $pattern $name]} {
+ incr ::test::numTests(Skipped)
+ return
+ }
+ }
+ # skip the test if it's name doesn't match any element of matchingTests
+ if {[llength $::test::matchingTests] > 0} {
+ set ok 0
+ foreach pattern $::test::matchingTests {
+ if {[string match $pattern $name]} {
+ set ok 1
+ break
+ }
+ }
+ if {!$ok} {
+ incr ::test::numTests(Skipped)
+ return
+ }
+ }
+ set i [llength $args]
+ if {$i == 0} {
+ set constraints {}
+ } elseif {$i == 1} {
+ # "constraints" argument exists; shuffle arguments down, then
+ # make sure that the constraints are satisfied.
+
+ set constraints $script
+ set script $expectedAnswer
+ set expectedAnswer [lindex $args 0]
+ set doTest 0
+ if {[string match {*[$\[]*} $constraints] != 0} {
+ # full expression, e.g. {$foo > [info tclversion]}
+
+ catch {set doTest [uplevel #0 expr $constraints]}
+ } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} {
+ # something like {a || b} should be turned into
+ # $::test::testConfig(a) || $::test::testConfig(b).
+
+ regsub -all {[.a-zA-Z0-9]+} $constraints {$::test::testConfig(&)} c
+ catch {set doTest [eval expr $c]}
+ } else {
+ # just simple constraints such as {unixOnly fonts}.
+
+ set doTest 1
+ foreach constraint $constraints {
+ if {![info exists ::test::testConfig($constraint)]
+ || !$::test::testConfig($constraint)} {
+ set doTest 0
+ break
+ }
+ }
+ }
+ if {$doTest == 0} {
+ incr ::test::numTests(Skipped)
+ if {[string first s $::test::verbose] != -1} {
+ puts stdout "++++ $name SKIPPED: $constraints"
+ }
+ return
+ }
+ } else {
+ error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\""
+ }
+ memory tag $name
+ set code [catch {uplevel $script} actualAnswer]
+ if {$code != 0 || [string compare $actualAnswer $expectedAnswer] != 0} {
+ incr ::test::numTests(Failed)
+ if {[string first b $::test::verbose] == -1} {
+ set script ""
+ }
+ puts stdout "\n==== $name $description FAILED"
+ if {$script != ""} {
+ puts stdout "==== Contents of test case:"
+ puts stdout $script
+ }
+ if {$code != 0} {
+ if {$code == 1} {
+ puts stdout "==== Test generated error:"
+ puts stdout $actualAnswer
+ } elseif {$code == 2} {
+ puts stdout "==== Test generated return exception; result was:"
+ puts stdout $actualAnswer
+ } elseif {$code == 3} {
+ puts stdout "==== Test generated break exception"
+ } elseif {$code == 4} {
+ puts stdout "==== Test generated continue exception"
+ } else {
+ puts stdout "==== Test generated exception $code; message was:"
+ puts stdout $actualAnswer
+ }
+ } else {
+ puts stdout "---- Result was:\n$actualAnswer"
+ }
+ puts stdout "---- Result should have been:\n$expectedAnswer"
+ puts stdout "==== $name FAILED\n"
+ } else {
+ incr ::test::numTests(Passed)
+ if {[string first p $::test::verbose] != -1} {
+ puts stdout "++++ $name PASSED"
+ }
+ }
+}
+
+proc ::test::dotests {file args} {
+ set savedTests $::test::matchingTests
+ set ::test::matchingTests $args
+ source $file
+ set ::test::matchingTests $savedTests
+}
+
+proc ::test::openfiles {} {
+ if {[catch {testchannel open} result]} {
+ return {}
+ }
+ return $result
+}
+
+proc ::test::leakfiles {old} {
+ if {[catch {testchannel open} new]} {
+ return {}
+ }
+ set leak {}
+ foreach p $new {
+ if {[lsearch $old $p] < 0} {
+ lappend leak $p
+ }
+ }
+ return $leak
+}
+
+set ::test::saveState {}
+
+proc ::test::saveState {} {
+ uplevel #0 {set ::test::saveState [list [info procs] [info vars]]}
+}
+
+proc ::test::restoreState {} {
+ foreach p [info procs] {
+ if {[lsearch [lindex $::test::saveState 0] $p] < 0} {
+ rename $p {}
+ }
+ }
+ foreach p [uplevel #0 {info vars}] {
+ if {[lsearch [lindex $::test::saveState 1] $p] < 0} {
+ uplevel #0 "unset $p"
+ }
+ }
+}
+
+proc ::test::normalizeMsg {msg} {
+ regsub "\n$" [string tolower $msg] "" msg
+ regsub -all "\n\n" $msg "\n" msg
+ regsub -all "\n\}" $msg "\}" msg
+ return $msg
+}
+
+# makeFile --
+#
+# Create a new file with the name <name>, and write <contents> to it.
+#
+# If this file hasn't been created via makeFile since the last time
+# cleanupTests was called, add it to the $filesMade list, so it will
+# be removed by the next call to cleanupTests.
+#
+proc ::test::makeFile {contents name} {
+ set fd [open $name w]
+ fconfigure $fd -translation lf
+ if {[string index $contents [expr {[string length $contents] - 1}]] == "\n"} {
+ puts -nonewline $fd $contents
+ } else {
+ puts $fd $contents
+ }
+ close $fd
+
+ set fullName [file join [pwd] $name]
+ if {[lsearch $::test::filesMade $fullName] == -1} {
+ lappend ::test::filesMade $fullName
+ }
+}
+
+proc ::test::removeFile {name} {
+ file delete $name
+}
+
+# makeDirectory --
+#
+# Create a new dir with the name <name>.
+#
+# If this dir hasn't been created via makeDirectory since the last time
+# cleanupTests was called, add it to the $directoriesMade list, so it will
+# be removed by the next call to cleanupTests.
+#
+proc ::test::makeDirectory {name} {
+ file mkdir $name
+
+ set fullName [file join [pwd] $name]
+ if {[lsearch $::test::filesMade $fullName] == -1} {
+ lappend ::test::filesMade $fullName
+ }
+}
+
+proc ::test::removeDirectory {name} {
+ file delete -force $name
+}
+
+proc ::test::viewFile {name} {
+ global tcl_platform
+ if {($tcl_platform(platform) == "macintosh") || \
+ ($::test::testConfig(unixExecs) == 0)} {
+ set f [open $name]
+ set data [read -nonewline $f]
+ close $f
+ return $data
+ } else {
+ exec cat $name
+ }
+}
+
+#
+# Construct a string that consists of the requested sequence of bytes,
+# as opposed to a string of properly formed UTF-8 characters.
+# This allows the tester to
+# 1. Create denormalized or improperly formed strings to pass to C procedures
+# that are supposed to accept strings with embedded NULL bytes.
+# 2. Confirm that a string result has a certain pattern of bytes, for instance
+# to confirm that "\xe0\0" in a Tcl script is stored internally in
+# UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80".
+#
+# Generally, it's a bad idea to examine the bytes in a Tcl string or to
+# construct improperly formed strings in this manner, because it involves
+# exposing that Tcl uses UTF-8 internally.
+
+proc ::test::bytestring {string} {
+ encoding convertfrom identity $string
+}
+
+# Locate tcltest executable
+
+set tcltest [info nameofexecutable]
+
+if {$tcltest == "{}"} {
+ set tcltest {}
+ puts stdout "Unable to find tcltest executable, multiple process tests will fail."
+}
+
+set ::test::testConfig(stdio) 0
+if {$tcl_platform(os) != "Win32s"} {
+ # Don't even try running another copy of tcltest under win32s, or you
+ # get an error dialog about multiple instances.
+
+ catch {
+ file delete -force tmp
+ set f [open tmp w]
+ puts $f {
+ exit
+ }
+ close $f
+ set f [open "|[list $tcltest tmp]" r]
+ close $f
+ set ::test::testConfig(stdio) 1
+ }
+ catch {file delete -force tmp}
+}
+
+if {($tcl_platform(platform) == "windows") && ($::test::testConfig(stdio) == 0)} {
+ puts stdout "(will skip tests that redirect stdio of exec'd 32-bit applications)"
+}
+
+catch {socket} msg
+set ::test::testConfig(socket) [expr {$msg != "sockets are not available on this system"}]
+
+if {$::test::testConfig(socket) == 0} {
+ puts stdout "(will skip tests that use sockets)"
+}
+
+#
+# Internationalization / ISO support procs -- dl
+#
+if {[info commands testlocale]==""} {
+ # No testlocale command, no tests...
+ # (it could be that we are a sub interp and we could just load
+ # the Tcltest package but that would interfere with tests
+ # that tests packages/loading in slaves...)
+ set ::test::testConfig(hasIsoLocale) 0
+} else {
+ proc ::test::set_iso8859_1_locale {} {
+ set ::test::previousLocale [testlocale ctype]
+ testlocale ctype $::test::isoLocale
+ }
+
+ proc ::test::restore_locale {} {
+ testlocale ctype $::test::previousLocale
+ }
+
+ if {![info exists ::test::isoLocale]} {
+ set ::test::isoLocale fr
+ switch $tcl_platform(platform) {
+ "unix" {
+ # Try some 'known' values for some platforms:
+ switch -exact -- $tcl_platform(os) {
+ "FreeBSD" {
+ set ::test::isoLocale fr_FR.ISO_8859-1
+ }
+ HP-UX {
+ set ::test::isoLocale fr_FR.iso88591
+ }
+ Linux -
+ IRIX {
+ set ::test::isoLocale fr
+ }
+ default {
+ # Works on SunOS 4 and Solaris, and maybe others...
+ # define it to something else on your system
+ #if you want to test those.
+ set ::test::isoLocale iso_8859_1
+ }
+ }
+ }
+ "windows" {
+ set ::test::isoLocale French
+ }
+ }
+ }
+
+ set ::test::testConfig(hasIsoLocale) \
+ [string length [::test::set_iso8859_1_locale]]
+ ::test::restore_locale
+
+ if {$::test::testConfig(hasIsoLocale) == 0} {
+ puts "(will skip tests that need to set an iso8859-1 locale)"
+ }
+
+}
+
+# If the main window isn't already mapped (e.g. because the tests are
+# being run automatically) , specify a precise size for it so that the
+# user won't have to position it manually.
+
+if {![winfo ismapped .]} {
+ wm geometry . +0+0
+ update
+}
+
+# The following code can be used to perform tests involving a second
+# process running in the background.
+
+# Locate tktest executable
+
+set ::test::tktest [info nameofexecutable]
+if {$::test::tktest == "{}"} {
+ set ::test::tktest {}
+ puts stdout "Unable to find tktest executable, skipping multiple process tests."
+}
+
+# Create background process
+
+proc ::test::setupbg args {
+ if {$::test::tktest == ""} {
+ error "you're not running tktest so setupbg should not have been called"
+ }
+ if {[info exists ::test::fd] && ($::test::fd != "")} {
+ cleanupbg
+ }
+ set ::test::fd [open "|[list $::test::tktest -geometry +0+0 -name tktest] $args" r+]
+ puts $::test::fd "puts foo; flush stdout"
+ flush $::test::fd
+ if {[gets $::test::fd data] < 0} {
+ error "unexpected EOF from \"$::test::tktest\""
+ }
+ if {[string compare $data foo]} {
+ error "unexpected output from background process \"$data\""
+ }
+ fileevent $::test::fd readable bgReady
+}
+
+# Send a command to the background process, catching errors and
+# flushing I/O channels
+proc ::test::dobg {command} {
+ puts $::test::fd "catch [list $command] msg; update; puts \$msg; puts **DONE**; flush stdout"
+ flush $::test::fd
+ set ::test::bgDone 0
+ set ::test::bgData {}
+ tkwait variable ::test::bgDone
+ set ::test::bgData
+}
+
+# Data arrived from background process. Check for special marker
+# indicating end of data for this command, and make data available
+# to dobg procedure.
+proc ::test::bgReady {} {
+ set x [gets $::test::fd]
+ if {[eof $::test::fd]} {
+ fileevent $::test::fd readable {}
+ set ::test::bgDone 1
+ } elseif {$x == "**DONE**"} {
+ set ::test::bgDone 1
+ } else {
+ append ::test::bgData $x
+ }
+}
+
+# Exit the background process, and close the pipes
+proc ::test::cleanupbg {} {
+ catch {
+ puts $::test::fd "exit"
+ close $::test::fd
+ }
+ set ::test::fd ""
+}
+
+# Clean up focus after using generate event, which
+# can leave the window manager with the wrong impression
+# about who thinks they have the focus. (BW)
+
+proc ::test::fixfocus {} {
+ catch {destroy .focus}
+ toplevel .focus
+ wm geometry .focus +0+0
+ entry .focus.e
+ .focus.e insert 0 "fixfocus"
+ pack .focus.e
+ update
+ focus -force .focus.e
+ destroy .focus
+}
+
+# Need to catch the import because it fails if defs.tcl is sourced
+# more than once.
+catch {namespace import ::test::*}
diff --git a/tests/entry.test b/tests/entry.test
index d802878..25a0ade 100644
--- a/tests/entry.test
+++ b/tests/entry.test
@@ -3,11 +3,10 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: entry.test,v 1.1.4.3 1999/02/16 11:39:35 lfb Exp $
+# RCS: @(#) $Id: entry.test,v 1.1.4.4 1999/03/11 18:50:47 hershey Exp $
if {[lsearch [image types] test] < 0} {
puts "This application hasn't been compiled with the \"test\""
@@ -16,8 +15,8 @@ if {[lsearch [image types] test] < 0} {
return
}
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
foreach i [winfo children .] {
@@ -1358,5 +1357,8 @@ test entry-18.1 {Entry widget vs hiding} {
# XXX Still need to write tests for EntryBlinkProc, EntryFocusProc,
# and EntryTextVarProc.
-
option clear
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/event.test b/tests/event.test
index 5790c6c..046b4f7 100644
--- a/tests/event.test
+++ b/tests/event.test
@@ -3,14 +3,13 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-1995 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: event.test,v 1.1.4.1 1998/09/30 02:18:35 stanton Exp $
+# RCS: @(#) $Id: event.test,v 1.1.4.2 1999/03/11 18:50:47 hershey Exp $
-if {[info procs test] != "test"} {
- source defs
+if {[lsearch [namespace children] ::test] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
}
foreach i [winfo children .] {
@@ -39,3 +38,7 @@ test event-1.1 {Tk_HandleEvent procedure, filter events for dead windows} {
destroy .b
set x
} {destroy}
+
+# cleanup
+::test::cleanupTests
+return
diff --git a/tests/filebox.test b/tests/filebox.test