summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2002-07-14 05:48:45 (GMT)
committerdgp <dgp@users.sourceforge.net>2002-07-14 05:48:45 (GMT)
commitf79b432c7c47051e0c7e11bd52e82547ad7aacf2 (patch)
tree506cf7b5383406d4969854b8209566f9c0b690c6
parent213541e4a3a5a49415c0f9f8d37a5cbce28f89f7 (diff)
downloadtk-f79b432c7c47051e0c7e11bd52e82547ad7aacf2.zip
tk-f79b432c7c47051e0c7e11bd52e82547ad7aacf2.tar.gz
tk-f79b432c7c47051e0c7e11bd52e82547ad7aacf2.tar.bz2
* Completed conversion of Tk test suite to use tcltest.
-rw-r--r--ChangeLog7
-rw-r--r--tests/all.tcl62
-rw-r--r--tests/bell.test13
-rw-r--r--tests/bgerror.test13
-rw-r--r--tests/bind.test63
-rw-r--r--tests/bitmap.test31
-rw-r--r--tests/border.test56
-rw-r--r--tests/button.test81
-rw-r--r--tests/canvImg.test153
-rw-r--r--tests/canvPs.test22
-rw-r--r--tests/canvRect.test17
-rw-r--r--tests/canvText.test19
-rw-r--r--tests/canvWind.test19
-rw-r--r--tests/canvas.test23
-rw-r--r--tests/choosedir.test14
-rw-r--r--tests/clipboard.test13
-rw-r--r--tests/clrpick.test21
-rw-r--r--tests/cmds.test13
-rw-r--r--tests/color.test96
-rw-r--r--tests/config.test442
-rw-r--r--tests/constraints.tcl45
-rw-r--r--tests/cursor.test17
-rw-r--r--tests/dialog.test20
-rw-r--r--tests/embed.test20
-rw-r--r--tests/entry.test23
-rw-r--r--tests/event.test19
-rw-r--r--tests/filebox.test20
-rw-r--r--tests/focus.test39
-rw-r--r--tests/focusTcl.test51
-rw-r--r--tests/font.test27
-rw-r--r--tests/frame.test25
-rw-r--r--tests/imgPhoto.test4
-rw-r--r--tests/listbox.test10
-rw-r--r--tests/macEmbed.test4
-rw-r--r--tests/macFont.test4
-rw-r--r--tests/menu.test4
-rw-r--r--tests/send.test163
-rw-r--r--tests/visual.test10
-rw-r--r--unix/Makefile.in6
39 files changed, 789 insertions, 900 deletions
diff --git a/ChangeLog b/ChangeLog
index 21d8151..cd12a8a 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2002-07-13 Don Porter <dgp@users.sf.net>
+
+ * tests/all.tcl: Completed conversion of Tk test suite
+ * tests/constraints.tcl: to use tcltest.
+ * tests/[b-v]*.test:
+ * unix/Makefile.in:
+
2002-07-12 Don Porter <dgp@users.sf.net>
* tests/constraints.tcl: Converted more files to tcltest and
diff --git a/tests/all.tcl b/tests/all.tcl
index f6dee92..dbfe6c6 100644
--- a/tests/all.tcl
+++ b/tests/all.tcl
@@ -9,59 +9,11 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: all.tcl,v 1.6 2002/04/12 09:18:52 hobbs Exp $
+# RCS: @(#) $Id: all.tcl,v 1.7 2002/07/14 05:48:45 dgp Exp $
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-set ::tcltest::testSingleFile false
-
-puts stdout "Tk $tk_patchLevel tests running in interp: [info nameofexecutable]"
-puts stdout "Tests running in working dir: $::tcltest::workingDir"
-if {[llength $::tcltest::skip] > 0} {
- puts stdout "Skipping tests that match: $::tcltest::skip"
-}
-if {[llength $::tcltest::match] > 0} {
- puts stdout "Only running tests that match: $::tcltest::match"
-}
-
-# Use command line specified glob pattern (specified by -file or -f)
-# if one exists. Otherwise use *.test. 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 $::tcltest::testsDir [lindex $argv $fileIndex]]
- puts stdout "Sourcing files that match: $globPattern"
-} else {
- set globPattern [file join $::tcltest::testsDir *.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]"
-
-# source each of the specified tests
-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
- }
-}
-
-# cleanup
-puts stdout "\nTests ended at [eval $timeCmd]"
-::tcltest::cleanupTests 1
-return
+package require Tcl 8.4
+package require tcltest 2.1
+tcltest::configure -testdir [file join [pwd] [file dirname [info script]]]
+tcltest::configure -singleproc 1
+eval tcltest::configure $argv
+tcltest::runAllTests
diff --git a/tests/bell.test b/tests/bell.test
index 96b7a74..3c0975b 100644
--- a/tests/bell.test
+++ b/tests/bell.test
@@ -5,11 +5,14 @@
# Copyright (c) 1998-2000 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: bell.test,v 1.5 2000/05/17 22:44:10 hobbs Exp $
-
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
+# RCS: @(#) $Id: bell.test,v 1.6 2002/07/14 05:48:45 dgp Exp $
+
+package require tcltest 2.1
+namespace import -force tcltest::configure
+namespace import -force tcltest::testsDirectory
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
test bell-1.1 {bell command} {
list [catch {bell a} msg] $msg
diff --git a/tests/bgerror.test b/tests/bgerror.test
index cf6489b..dab97fd 100644
--- a/tests/bgerror.test
+++ b/tests/bgerror.test
@@ -5,11 +5,14 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: bgerror.test,v 1.3 1999/04/16 01:51:33 stanton Exp $
-
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
+# RCS: @(#) $Id: bgerror.test,v 1.4 2002/07/14 05:48:45 dgp Exp $
+
+package require tcltest 2.1
+namespace import -force tcltest::configure
+namespace import -force tcltest::testsDirectory
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
test bgerror-1.1 {bgerror / tkerror compat} {
set errRes {}
diff --git a/tests/bind.test b/tests/bind.test
index ad84ed5..e5ff490 100644
--- a/tests/bind.test
+++ b/tests/bind.test
@@ -7,11 +7,14 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: bind.test,v 1.9 2001/03/30 21:52:28 hobbs Exp $
+# RCS: @(#) $Id: bind.test,v 1.10 2002/07/14 05:48:45 dgp Exp $
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
+package require tcltest 2.1
+namespace import -force tcltest::configure
+namespace import -force tcltest::testsDirectory
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
catch {destroy .b}
toplevel .b -width 100 -height 50
@@ -214,13 +217,7 @@ test bind-5.1 {Tk_CreateBindingTable procedure} {
.b.c bind foo
} {}
-
-if {[string compare testcbind [info commands testcbind]] != 0} {
- puts "This application hasn't been compiled with the testcbind command,"
- puts "therefore I am skipping all of these tests."
- ::tcltest::cleanupTests
- return
-}
+testConstraint testcbind [llength [info commands testcbind]]
test bind-6.1 {Tk_DeleteBindTable procedure} {
catch {destroy .b.c}
@@ -230,7 +227,7 @@ test bind-6.1 {Tk_DeleteBindTable procedure} {
.b.c bind 1 <2> {string 2}
destroy .b.c
} {}
-test bind-6.2 {Tk_DeleteBindTable procedure: pending bindings deleted later} {
+test bind-6.2 {Tk_DeleteBindTable procedure: pending bindings deleted later} testcbind {
catch {interp delete foo}
interp create foo
foo eval {
@@ -258,7 +255,7 @@ test bind-7.1 {Tk_CreateBinding procedure: bad binding} {
canvas .b.c
list [catch {.b.c bind foo <} msg] $msg
} {1 {no event type or button # or keysym}}
-test bind-7.2 {Tk_CreateBinding procedure: replace existing C binding} {
+test bind-7.2 {Tk_CreateBinding procedure: replace existing C binding} testcbind {
catch {destroy .b.f}
frame .b.f
testcbind .b.f <1> "xyz" "lappend x bye.1"
@@ -282,10 +279,10 @@ test bind-7.4 {Tk_CreateBinding procedure: append to non-existing} {
.b.c bind foo <1>
} {button 1}
-test bind-8.1 {TkCreateBindingProcedure: error} {
+test bind-8.1 {TkCreateBindingProcedure: error} testcbind {
list [catch {testcbind . <xyz> "xyz"} msg] $msg
} {1 {bad event type or keysym "xyz"}}
-test bind-8.2 {TkCreateBindingProcedure: new binding} {
+test bind-8.2 {TkCreateBindingProcedure: new binding} testcbind {
catch {destroy .b.f}
frame .b.f
testcbind .b.f <1> "lappend x 1" "lappend x bye.1"
@@ -294,7 +291,7 @@ test bind-8.2 {TkCreateBindingProcedure: new binding} {
destroy .b.f
set x
} {bye.1}
-test bind-8.3 {TkCreateBindingProcedure: replace existing} {
+test bind-8.3 {TkCreateBindingProcedure: replace existing} testcbind {
catch {destroy .b.f}
frame .b.f
pack .b.f
@@ -303,7 +300,7 @@ test bind-8.3 {TkCreateBindingProcedure: replace existing} {
testcbind .b.f <1> "lappend x new1" "lappend x bye.new1"
set x
} {bye.old1}
-test bind-8.4 {TkCreateBindingProcedure: replace existing while pending} {
+test bind-8.4 {TkCreateBindingProcedure: replace existing while pending} testcbind {
catch {destroy .b.f}
frame .b.f
pack .b.f
@@ -347,7 +344,7 @@ test bind-9.3 {Tk_DeleteBinding procedure} {
}
set result
} {{<Button-1> <Double-Alt-Button-1> <Meta-Button-1>} {<Button-1> <Meta-Button-1>} <Meta-Button-1> {}}
-test bind-9.4 {Tk_DeleteBinding procedure: pending bindings delete later} {
+test bind-9.4 {Tk_DeleteBinding procedure: pending bindings delete later} testcbind {
catch {destroy .b.f}
frame .b.f
pack .b.f
@@ -375,7 +372,7 @@ test bind-10.2 {Tk_GetBinding procedure} {
.b.c bind foo a Test
.b.c bind foo a
} {Test}
-test bind-10.3 {Tk_GetBinding procedure: C binding} {
+test bind-10.3 {Tk_GetBinding procedure: C binding} testcbind {
catch {destroy .b.f}
frame .b.f
testcbind .b.f <1> "foo"
@@ -421,7 +418,7 @@ test bind-12.2 {Tk_DeleteAllBindings procedure} {
}
destroy .b.f
} {}
-test bind-12.3 {Tk_DeleteAllBindings procedure: pending bindings deleted later} {
+test bind-12.3 {Tk_DeleteAllBindings procedure: pending bindings deleted later} testcbind {
catch {destroy .b.f}
frame .b.f
pack .b.f
@@ -731,7 +728,7 @@ test bind-13.31 {Tk_BindEvent procedure: match} {
event gen .b.f <Button-2>
set x
} {Button-2}
-test bind-13.32 {Tk_BindEvent procedure: many C bindings cause realloc} {
+test bind-13.32 {Tk_BindEvent procedure: many C bindings cause realloc} testcbind {
setup
bindtags .b.f {a b c d e f g h i j k l m n o p}
foreach p [bindtags .b.f] {
@@ -753,14 +750,14 @@ test bind-13.33 {Tk_BindEvent procedure: multiple tags} {
bind Test <Button-2> {}
set x
} {.b.f Button}
-test bind-13.34 {Tk_BindEvent procedure: execute C binding} {
+test bind-13.34 {Tk_BindEvent procedure: execute C binding} testcbind {
setup
testcbind .b.f <1> {lappend x 1}
set x {}
event gen .b.f <1>
set x
} {1}
-test bind-13.35 {Tk_BindEvent procedure: pending list marked deleted} {
+test bind-13.35 {Tk_BindEvent procedure: pending list marked deleted} testcbind {
setup
testcbind Test <1> {lappend x Test} {lappend x Deleted}
bind .b.f <1> {lappend x .b.f; destroy .b.f}
@@ -770,7 +767,7 @@ test bind-13.35 {Tk_BindEvent procedure: pending list marked deleted} {
bind Test <1> {}
set y
} {.b.f <Button-1>}
-test bind-13.36 {Tk_BindEvent procedure: C binding marked deleted} {
+test bind-13.36 {Tk_BindEvent procedure: C binding marked deleted} testcbind {
setup
testcbind Test <1> {lappend x Test} {lappend x Deleted}
bind .b.f <1> {lappend x .b.f; bind Test <1> {}; lappend x after}
@@ -778,7 +775,7 @@ test bind-13.36 {Tk_BindEvent procedure: C binding marked deleted} {
event gen .b.f <1>
set x
} {.b.f after Deleted}
-test bind-13.37 {Tk_BindEvent procedure: C binding gets to run} {
+test bind-13.37 {Tk_BindEvent procedure: C binding gets to run} testcbind {
setup
testcbind Test <1> {lappend x Test}
bind .b.f <1> {lappend x .b.f}
@@ -787,14 +784,14 @@ test bind-13.37 {Tk_BindEvent procedure: C binding gets to run} {
bind Test <1> {}
set x
} {.b.f Test}
-test bind-13.38 {Tk_BindEvent procedure: C binding deleted, refcount == 0} {
+test bind-13.38 {Tk_BindEvent procedure: C binding deleted, refcount == 0} testcbind {
setup
testcbind .b.f <1> {lappend x hi; bind .b.f <1> {}} {lappend x bye}
set x {}
event gen .b.f <1>
set x
} {hi bye}
-test bind-13.39 {Tk_BindEvent procedure: C binding deleted, refcount != 0} {
+test bind-13.39 {Tk_BindEvent procedure: C binding deleted, refcount != 0} testcbind {
setup
testcbind .b.f <1> {
lappend x before$n
@@ -820,7 +817,7 @@ test bind-13.40 {Tk_BindEvent procedure: continue in script} {
bind Test <Button-2> {}
set x
} {b1 B1}
-test bind-13.41 {Tk_BindEvent procedure: continue in script} {
+test bind-13.41 {Tk_BindEvent procedure: continue in script} testcbind {
setup
testcbind .b.f <Button-2> {lappend x b1; continue; lappend x b2}
testcbind Test <Button-2> {lappend x B1; continue; lappend x B2}
@@ -838,7 +835,7 @@ test bind-13.42 {Tk_BindEvent procedure: break in script} {
bind Test <Button-2> {}
set x
} {b1}
-test bind-13.43 {Tk_BindEvent procedure: break in script} {
+test bind-13.43 {Tk_BindEvent procedure: break in script} testcbind {
setup
testcbind .b.f <Button-2> {lappend x b1; break; lappend x b2}
testcbind Test <Button-2> {lappend x B1; break; lappend x B2}
@@ -862,7 +859,7 @@ test bind-13.44 {Tk_BindEvent procedure: error in script} {
bind Test <Button-2> {}
set x
} {b1 {invalid command name "blap"}}
-test bind-13.45 {Tk_BindEvent procedure: error in script} {
+test bind-13.45 {Tk_BindEvent procedure: error in script} testcbind {
setup
testcbind .b.f <Button-2> {lappend x b1; blap}
testcbind Test <Button-2> {lappend x B1}
@@ -873,13 +870,13 @@ test bind-13.45 {Tk_BindEvent procedure: error in script} {
set x
} {b1 {invalid command name "blap"}}
-test bind-14.1 {TkBindDeadWindow: no C bindings pending} {
+test bind-14.1 {TkBindDeadWindow: no C bindings pending} testcbind {
setup
bind .b.f <1> x
testcbind .b.f <2> y
destroy .b.f
} {}
-test bind-14.2 {TkBindDeadWindow: is called after <Destroy>} {
+test bind-14.2 {TkBindDeadWindow: is called after <Destroy>} testcbind {
setup
testcbind .b.f <Destroy> "lappend x .b.f"
testcbind Test <Destroy> "lappend x Test"
@@ -888,7 +885,7 @@ test bind-14.2 {TkBindDeadWindow: is called after <Destroy>} {
bind Test <Destroy> {}
set x
} {.b.f Test}
-test bind-14.3 {TkBindDeadWindow: pending C bindings} {
+test bind-14.3 {TkBindDeadWindow: pending C bindings} testcbind {
setup
bindtags .b.f {a b c d}
testcbind a <1> "lappend x a1" "lappend x bye.a1"
diff --git a/tests/bitmap.test b/tests/bitmap.test
index 2049840..bb5a50f 100644
--- a/tests/bitmap.test
+++ b/tests/bitmap.test
@@ -6,23 +6,18 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: bitmap.test,v 1.2 1999/04/16 01:51:34 stanton Exp $
+# RCS: @(#) $Id: bitmap.test,v 1.3 2002/07/14 05:48:46 dgp Exp $
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
+package require tcltest 2.1
+namespace import -force tcltest::configure
+namespace import -force tcltest::testsDirectory
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
-if {[info commands testbitmap] != "testbitmap"} {
- puts "testbitmap command not available; skipping tests"
- ::tcltest::cleanupTests
- return
-}
+testConstraint testbitmap [llength [info commands testbitmap]]
-eval destroy [winfo children .]
-wm geometry . {}
-raise .
-
-test bitmap-1.1 {Tk_AllocBitmapFromObj - converting internal reps} {
+test bitmap-1.1 {Tk_AllocBitmapFromObj - converting internal reps} testbitmap {
set x gray25
lindex $x 0
destroy .b1
@@ -30,7 +25,7 @@ test bitmap-1.1 {Tk_AllocBitmapFromObj - converting internal reps} {
lindex $x 0
testbitmap gray25
} {{1 0}}
-test bitmap-1.2 {Tk_AllocBitmapFromObj - discard stale bitmap} {
+test bitmap-1.2 {Tk_AllocBitmapFromObj - discard stale bitmap} testbitmap {
set x gray25
destroy .b1 .b2
button .b1 -bitmap $x
@@ -40,7 +35,7 @@ test bitmap-1.2 {Tk_AllocBitmapFromObj - discard stale bitmap} {
button .b2 -bitmap $x
lappend result [testbitmap gray25]
} {{} {{1 1}}}
-test bitmap-1.3 {Tk_AllocBitmapFromObj - reuse existing bitmap} {
+test bitmap-1.3 {Tk_AllocBitmapFromObj - reuse existing bitmap} testbitmap {
set x gray25
destroy .b1 .b2
button .b1 -bitmap $x
@@ -60,7 +55,7 @@ test bitmap-2.2 {Tk_GetBitmap procedure} {
list [catch {button .b1 -bitmap @xyzzy} msg] $msg
} {1 {error reading bitmap file "xyzzy"}}
-test bitmap-3.1 {Tk_FreeBitmapFromObj - reference counts} {
+test bitmap-3.1 {Tk_FreeBitmapFromObj - reference counts} testbitmap {
set x questhead
destroy .b1 .b2 .b3
button .b1 -bitmap $x
@@ -76,7 +71,7 @@ test bitmap-3.1 {Tk_FreeBitmapFromObj - reference counts} {
lappend result [testbitmap questhead]
} {{{3 1}} {{2 1}} {{1 1}} {}}
-test bitmap-4.1 {FreeBitmapObjProc} {
+test bitmap-4.1 {FreeBitmapObjProc} testbitmap {
destroy .b
set x [format questhead]
button .b -bitmap $x
diff --git a/tests/border.test b/tests/border.test
index e59b405..55df1e4 100644
--- a/tests/border.test
+++ b/tests/border.test
@@ -5,39 +5,23 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: border.test,v 1.2 1999/04/16 01:51:34 stanton Exp $
+# RCS: @(#) $Id: border.test,v 1.3 2002/07/14 05:48:46 dgp Exp $
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-
-if {[info commands testborder] != "testborder"} {
- puts "testborder command not available; skipping tests"
- ::tcltest::cleanupTests
- return
-}
-
-eval destroy [winfo children .]
-wm geometry . {}
-raise .
+package require tcltest 2.1
+namespace import -force tcltest::configure
+namespace import -force tcltest::testsDirectory
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
-# Create a top-level with its own colormap (so we can test under
-# controlled conditions), then check to make sure that the visual
-# is color-mapped with 256 borders. If not, just skip this whole
-# test file.
+testConstraint testborder [llength [info commands testborder]]
-if [catch {toplevel .t -visual {pseudocolor 8} -colormap new}] {
- ::tcltest::cleanupTests
- return
-}
-wm geom .t +0+0
-if {[winfo depth .t] != 8} {
- destroy .t
- ::tcltest::cleanupTests
- return
+if {[testConstraint pseudocolor8]} {
+ toplevel .t -visual {pseudocolor 8} -colormap new
+ wm geom .t +0+0
}
-test border-1.1 {Tk_AllocBorderFromObj - converting internal reps} {
+test border-1.1 {Tk_AllocBorderFromObj - converting internal reps} testborder {
set x orange
lindex $x 0
destroy .b1
@@ -45,7 +29,7 @@ test border-1.1 {Tk_AllocBorderFromObj - converting internal reps} {
lindex $x 0
testborder orange
} {{1 0}}
-test border-1.3 {Tk_AllocBorderFromObj - discard stale border} {
+test border-1.3 {Tk_AllocBorderFromObj - discard stale border} testborder {
set x orange
destroy .b1 .b2
button .b1 -bg $x -text First
@@ -55,7 +39,7 @@ test border-1.3 {Tk_AllocBorderFromObj - discard stale border} {
button .b2 -bg $x -text Second
lappend result [testborder orange]
} {{} {{1 1}}}
-test border-1.2 {Tk_AllocBorderFromObj - reuse existing border} {
+test border-1.2 {Tk_AllocBorderFromObj - reuse existing border} testborder {
set x orange
destroy .b1 .b2
button .b1 -bg $x -text First
@@ -65,7 +49,7 @@ test border-1.2 {Tk_AllocBorderFromObj - reuse existing border} {
pack .b1 .b2 -side top
lappend result [testborder orange]
} {{{1 1}} {{2 1}}}
-test border-1.4 {Tk_AllocBorderFromObj - try other borders in list} {
+test border-1.4 {Tk_AllocBorderFromObj - try other borders in list} {pseudocolor8 testborder} {
set x purple
destroy .b1 .b2 .t.b
button .b1 -bg $x -text First
@@ -80,7 +64,7 @@ test border-1.4 {Tk_AllocBorderFromObj - try other borders in list} {
lappend result [testborder purple]
} {{{1 1}} {{1 1} {1 0}} {{1 0} {2 1}}}
-test border-3.1 {Tk_Free3DBorder - reference counts} {
+test border-3.1 {Tk_Free3DBorder - reference counts} {pseudocolor8 testborder} {
set x purple
destroy .b1 .b2 .t.b
button .b1 -bg $x -text First
@@ -98,7 +82,7 @@ test border-3.1 {Tk_Free3DBorder - reference counts} {
destroy .t.b
lappend result [testborder purple]
} {{{1 0} {2 1}} {{1 0} {1 1}} {{1 0}} {}}
-test border-3.4 {Tk_Free3DBorder - unlinking from list} {
+test border-3.4 {Tk_Free3DBorder - unlinking from list} {pseudocolor8 testborder} {
destroy .b .t.b .t2 .t3
toplevel .t2 -visual {pseudocolor 8} -colormap new
toplevel .t3 -visual {pseudocolor 8} -colormap new
@@ -125,7 +109,7 @@ test border-3.4 {Tk_Free3DBorder - unlinking from list} {
lappend result [testborder purple]
} {{{4 1} {3 0} {2 0} {1 0}} {{4 1} {2 0} {1 0}} {{4 1} {2 0}} {{2 0}} {}}
-test border-4.1 {FreeBorderObjProc} {
+test border-4.1 {FreeBorderObjProc} testborder {
destroy .b
set x [format purple]
button .b -bg $x -text .b1
@@ -175,7 +159,9 @@ test get-2.4 {Tk_GetReliefFromObj - error} {
list [catch {.b configure -relief upanddown} msg] $msg
} {1 {bad relief "upanddown": must be flat, groove, raised, ridge, solid, or sunken}}
-destroy .t
+if {[testConstraint pseudocolor8]} {
+ destroy .t
+}
# cleanup
::tcltest::cleanupTests
diff --git a/tests/button.test b/tests/button.test
index ed0b7ee..d7f9028 100644
--- a/tests/button.test
+++ b/tests/button.test
@@ -7,25 +7,14 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: button.test,v 1.11 2002/06/17 10:54:29 drh Exp $
+# RCS: @(#) $Id: button.test,v 1.12 2002/07/14 05:48:46 dgp Exp $
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-
-if {[lsearch [image types] test] < 0} {
- puts "This application hasn't been compiled with the \"test\""
- puts "image, so I can't run this test. Are you sure you're using"
- puts "tktest instead of wish?"
- ::tcltest::cleanupTests
- return
-}
-
-foreach i [winfo children .] {
- destroy $i
-}
-wm geometry . {}
-raise .
+package require tcltest 2.1
+namespace import -force tcltest::configure
+namespace import -force tcltest::testsDirectory
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
proc bogusTrace args {
error "trace aborted"
@@ -41,7 +30,9 @@ option add *Button.highlightThickness 2
option add *Button.font {Helvetica -12 bold}
eval image delete [image names]
-image create test image1
+if {[testConstraint testImageType]} {
+ image create test image1
+}
label .l -text Label
button .b -text Button
checkbutton .c -text Checkbutton
@@ -109,19 +100,19 @@ foreach test {
set classes [lindex $test 5]
foreach w {.l .b .c .r} hasOption [lindex $test 5] {
if $hasOption {
- test button-1.$i {configuration options} {
+ test button-1.$i {configuration options} testImageType {
$w configure $name [lindex $test 1]
lindex [$w configure $name] 4
} [lindex $test 2]
incr i
if {[lindex $test 3] != ""} {
- test button-1.$i {configuration options} {
+ test button-1.$i {configuration options} testImageType {
list [catch {$w configure $name [lindex $test 3]} msg] $msg
} [list 1 [lindex $test 4]]
}
$w configure $name [lindex [$w configure $name] 3]
} else {
- test button-1.$i {configuration options} {
+ test button-1.$i {configuration options} testImageType {
list [catch {$w configure $name [lindex $test 1]} msg] $msg
} "1 {unknown option \"$name\"}"
}
@@ -412,7 +403,7 @@ test button-4.50 {ButtonWidgetCmd procedure, "toggle" option} {
while executing
".c toggle"}}
-test button-5.1 {DestroyButton procedure} {
+test button-5.1 {DestroyButton procedure} testImageType {
image create test image1
button .b1 -image image1
button .b2 -fg #ff0000 -text "Button 2"
@@ -422,7 +413,7 @@ test button-5.1 {DestroyButton procedure} {
set x 1
pack .b1 .b2 .b3 .b4 .b5
update
- eval destroy [winfo children .]
+ deleteWindows
} {}
test button-6.1 {ConfigureButton - textvariable trace} {
@@ -452,7 +443,7 @@ test button-6.2 {ConfigureButton - variable traces} {
.b1 toggle
set y
} {1}
-test button-6.3 {ConfigureButton - image handling} {
+test button-6.3 {ConfigureButton - image handling} testImageType {
catch {destroy .b1}
eval image delete [image names]
image create test image1
@@ -545,7 +536,7 @@ test button-6.16 {ConfigureButton - -width option} {
(processing -width option)
invoked from within
".b1 configure -width abc"}}
-test button-6.17 {ConfigureButton - -height option} {
+test button-6.17 {ConfigureButton - -height option} testImageType {
catch {destroy .b1}
eval image delete [image names]
image create test image1
@@ -582,7 +573,7 @@ test button-7.1 {ButtonEventProc procedure} {
set x
} {0 {}}
test button-7.2 {ButtonEventProc procedure} {
- eval destroy [winfo children .]
+ deleteWindows
button .b1 -bg #543210
rename .b1 .b2
set x {}
@@ -593,7 +584,7 @@ test button-7.2 {ButtonEventProc procedure} {
} {.b1 #543210 {} {}}
test button-8.1 {ButtonCmdDeletedProc procedure} {
- eval destroy [winfo children .]
+ deleteWindows
button .b1
rename .b1 {}
list [info command .b*] [winfo children .]
@@ -649,20 +640,20 @@ test button-9.5 {TkInvokeButton procedure} {
while executing
".b1 invoke"} red}
test button-9.6 {TkInvokeButton procedure} {
- eval destroy [winfo children .]
+ deleteWindows
set result untouched
button .b1 -command {set result invoked}
list [catch {.b1 invoke} msg] $msg $result
} {0 invoked invoked}
test button-9.7 {TkInvokeButton procedure} {
- eval destroy [winfo children .]
+ deleteWindows
set result untouched
set x 0
checkbutton .b1 -variable x -command {set result "invoked $x"}
list [catch {.b1 invoke} msg] $msg $result
} {0 {invoked 1} {invoked 1}}
test button-9.8 {TkInvokeButton procedure} {
- eval destroy [winfo children .]
+ deleteWindows
set result untouched
set x 0
radiobutton .b1 -variable x -value red -command {set result "invoked $x"}
@@ -670,7 +661,7 @@ test button-9.8 {TkInvokeButton procedure} {
} {0 {invoked red} {invoked red}}
test button-10.1 {ButtonVarProc procedure} {
- eval destroy [winfo children .]
+ deleteWindows
set x 1
checkbutton .b1 -variable x
unset x
@@ -682,7 +673,7 @@ test button-10.1 {ButtonVarProc procedure} {
lappend result $x
} {0 1 1}
test button-10.2 {ButtonVarProc procedure} {
- eval destroy [winfo children .]
+ deleteWindows
set x 0
checkbutton .b1 -variable x
set x 44
@@ -690,7 +681,7 @@ test button-10.2 {ButtonVarProc procedure} {
set x
} {1}
test button-10.3 {ButtonVarProc procedure} {
- eval destroy [winfo children .]
+ deleteWindows
set x 1
checkbutton .b1 -variable x
set x 44
@@ -698,7 +689,7 @@ test button-10.3 {ButtonVarProc procedure} {
set x
} {1}
test button-10.4 {ButtonVarProc procedure} {
- eval destroy [winfo children .]
+ deleteWindows
set x 0
checkbutton .b1 -variable x
set x 1
@@ -706,7 +697,7 @@ test button-10.4 {ButtonVarProc procedure} {
set x
} {0}
test button-10.5 {ButtonVarProc procedure} {
- eval destroy [winfo children .]
+ deleteWindows
set x 1
checkbutton .b1 -variable x
set x 1
@@ -714,7 +705,7 @@ test button-10.5 {ButtonVarProc procedure} {
set x
} {0}
test button-10.6 {ButtonVarProc procedure} {
- eval destroy [winfo children .]
+ deleteWindows
set x 0
checkbutton .b1 -variable x
set x 0
@@ -722,7 +713,7 @@ test button-10.6 {ButtonVarProc procedure} {
set x
} {1}
test button-10.7 {ButtonVarProc procedure} {
- eval destroy [winfo children .]
+ deleteWindows
set x 1
checkbutton .b1 -variable x
set x 0
@@ -731,7 +722,7 @@ test button-10.7 {ButtonVarProc procedure} {
} {1}
test button-10.8 {ButtonVarProc procedure, can't read variable} {
# This test does nothing but produce a core dump if there's a prbblem.
- eval destroy [winfo children .]
+ deleteWindows
catch {unset a}
checkbutton .b1 -variable a
unset a
@@ -740,7 +731,7 @@ test button-10.8 {ButtonVarProc procedure, can't read variable} {
} {}
test button-11.1 {ButtonTextVarProc procedure} {
- eval destroy [winfo children .]
+ deleteWindows
set x Label
button .b1 -textvariable x
unset x
@@ -749,7 +740,7 @@ test button-11.1 {ButtonTextVarProc procedure} {
lappend result [lindex [.b1 configure -text] 4]
} {Label Label New}
test button-11.2 {ButtonTextVarProc procedure} {
- eval destroy [winfo children .]
+ deleteWindows
# Windows buttons have a default min width, so we have to
# set this to be longer to force the wider button.
set x ExtraLongLabel
@@ -760,8 +751,8 @@ test button-11.2 {ButtonTextVarProc procedure} {
list [lindex [.b1 configure -text] 4] [expr $old == $new]
} {New 0}
-test button-12.1 {ButtonImageProc procedure} {
- eval destroy [winfo children .]
+test button-12.1 {ButtonImageProc procedure} testImageType {
+ deleteWindows
eval image delete [image names]
image create test image1
label .b1 -image image1 -padx 0 -pady 0 -bd 0
@@ -771,7 +762,7 @@ test button-12.1 {ButtonImageProc procedure} {
lappend result [winfo reqwidth .b1] [winfo reqheight .b1]
} {30 15 80 100}
-eval destroy [winfo children .]
+deleteWindows
set l [interp hidden]
test button-13.1 {button widget vs hidden commands} {
@@ -782,7 +773,7 @@ test button-13.1 {button widget vs hidden commands} {
list [winfo children .] [interp hidden]
} [list {} $l]
-eval destroy [winfo children .]
+deleteWindows
option clear
diff --git a/tests/canvImg.test b/tests/canvImg.test
index 44d6546..94292d2 100644
--- a/tests/canvImg.test
+++ b/tests/canvImg.test
@@ -7,33 +7,24 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: canvImg.test,v 1.4 1999/12/14 06:53:12 hobbs Exp $
+# RCS: @(#) $Id: canvImg.test,v 1.5 2002/07/14 05:48:46 dgp Exp $
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-
-if {[lsearch [image types] test] < 0} {
- puts "This application hasn't been compiled with the \"test\" image"
- puts "type, so I can't run this test. Are you sure you're using"
- puts "tktest instead of wish?"
- ::tcltest::cleanupTests
- return
-}
-
-foreach i [winfo children .] {
- destroy $i
-}
-wm geometry . {}
-raise .
+package require tcltest 2.1
+namespace import -force tcltest::configure
+namespace import -force tcltest::testsDirectory
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
eval image delete [image names]
canvas .c
pack .c
update
-image create test foo -variable x
-image create test foo2 -variable y
-foo2 changed 0 0 0 0 80 60
+if {[testConstraint testImageType]} {
+ image create test foo -variable x
+ image create test foo2 -variable y
+ foo2 changed 0 0 0 0 80 60
+}
test canvImg-1.1 {options for image items} {
.c delete all
.c create image 50 50 -anchor nw -tags i1
@@ -43,7 +34,7 @@ test canvImg-1.2 {options for image items} {
.c delete all
list [catch {.c create image 50 50 -anchor gorp -tags i1} msg] $msg
} {1 {bad anchor position "gorp": must be n, ne, e, se, s, sw, w, nw, or center}}
-test canvImg-1.3 {options for image items} {
+test canvImg-1.3 {options for image items} testImageType {
.c delete all
.c create image 50 50 -image foo -tags i1
.c itemconfigure i1 -image
@@ -52,7 +43,7 @@ test canvImg-1.4 {options for image items} {
.c delete all
list [catch {.c create image 50 50 -image unknown -tags i1} msg] $msg
} {1 {image "unknown" doesn't exist}}
-test canvImg-1.5 {options for image items} {
+test canvImg-1.5 {options for image items} testImageType {
.c delete all
.c create image 50 50 -image foo -tags {i1 foo}
.c itemconfigure i1 -tags
@@ -77,37 +68,37 @@ test canvImg-2.4 {CreateImage procedure} {
test canvImg-2.5 {CreateImage procedure} {
list [catch {.c create image 50 qrs} msg] $msg
} {1 {bad screen distance "qrs"}}
-test canvImg-2.6 {CreateImage procedure} {
+test canvImg-2.6 {CreateImage procedure} testImageType {
list [catch {.c create image 50 50 -gorp foo} msg] $msg
} {1 {unknown option "-gorp"}}
-test canvImg-3.1 {ImageCoords procedure} {
+test canvImg-3.1 {ImageCoords procedure} testImageType {
.c delete all
.c create image 50 100 -image foo -tags i1
.c coords i1
} {50.0 100.0}
-test canvImg-3.2 {ImageCoords procedure} {
+test canvImg-3.2 {ImageCoords procedure} testImageType {
.c delete all
.c create image 50 100 -image foo -tags i1
list [catch {.c coords i1 dumb 100} msg] $msg
} {1 {bad screen distance "dumb"}}
-test canvImg-3.3 {ImageCoords procedure} {
+test canvImg-3.3 {ImageCoords procedure} testImageType {
.c delete all
.c create image 50 100 -image foo -tags i1
list [catch {.c coords i1 250 dumb0} msg] $msg
} {1 {bad screen distance "dumb0"}}
-test canvImg-3.4 {ImageCoords procedure} {
+test canvImg-3.4 {ImageCoords procedure} testImageType {
.c delete all
.c create image 50 100 -image foo -tags i1
list [catch {.c coords i1 250} msg] $msg
} {1 {wrong # coordinates: expected 2, got 1}}
-test canvImg-3.5 {ImageCoords procedure} {
+test canvImg-3.5 {ImageCoords procedure} testImageType {
.c delete all
.c create image 50 100 -image foo -tags i1
list [catch {.c coords i1 250 300 400} msg] $msg
} {1 {wrong # coordinates: expected 0 or 2, got 3}}
-test canvImg-4.1 {ConfiugreImage procedure} {
+test canvImg-4.1 {ConfiugreImage procedure} testImageType {
.c delete all
.c create image 50 100 -image foo -tags i1
update
@@ -116,7 +107,7 @@ test canvImg-4.1 {ConfiugreImage procedure} {
update
list $x [.c bbox i1]
} {{{foo free}} {}}
-test canvImg-4.2 {ConfiugreImage procedure} {
+test canvImg-4.2 {ConfiugreImage procedure} testImageType {
.c delete all
.c create image 50 100 -image foo -tags i1 -anchor nw
update
@@ -126,7 +117,7 @@ test canvImg-4.2 {ConfiugreImage procedure} {
update
list $x $y [.c bbox i1]
} {{{foo free}} {{foo2 get} {foo2 display 0 0 80 60 30 30}} {50 100 130 160}}
-test canvImg-4.3 {ConfiugreImage procedure} {
+test canvImg-4.3 {ConfiugreImage procedure} testImageType {
.c delete all
.c create image 50 100 -image foo -tags i1 -anchor nw
update
@@ -135,7 +126,7 @@ test canvImg-4.3 {ConfiugreImage procedure} {
list [catch {.c itemconfigure i1 -image lousy} msg] $msg
} {1 {image "lousy" doesn't exist}}
-test canvImg-5.1 {DeleteImage procedure} {
+test canvImg-5.1 {DeleteImage procedure} testImageType {
image create test xyzzy -variable z
.c delete all
.c create image 50 100 -image xyzzy -tags i1
@@ -155,12 +146,12 @@ test canvImg-5.2 {DeleteImage procedure (don't delete non-existent image)} {
update
} {}
-test canvImg-6.1 {ComputeImageBbox procedure} {
+test canvImg-6.1 {ComputeImageBbox procedure} testImageType {
.c delete all
.c create image 15.51 17.51 -image foo -tags i1 -anchor nw
.c bbox i1
} {16 18 46 33}
-test canvImg-6.2 {ComputeImageBbox procedure} {
+test canvImg-6.2 {ComputeImageBbox procedure} testImageType {
.c delete all
.c create image 15.49 17.49 -image foo -tags i1 -anchor nw
.c bbox i1
@@ -170,47 +161,47 @@ test canvImg-6.3 {ComputeImageBbox procedure} {
.c create image 20 30 -tags i1 -anchor nw
.c bbox i1
} {}
-test canvImg-6.4 {ComputeImageBbox procedure} {
+test canvImg-6.4 {ComputeImageBbox procedure} testImageType {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor nw
.c bbox i1
} {20 30 50 45}
-test canvImg-6.5 {ComputeImageBbox procedure} {
+test canvImg-6.5 {ComputeImageBbox procedure} testImageType {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor n
.c bbox i1
} {5 30 35 45}
-test canvImg-6.6 {ComputeImageBbox procedure} {
+test canvImg-6.6 {ComputeImageBbox procedure} testImageType {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor ne
.c bbox i1
} {-10 30 20 45}
-test canvImg-6.7 {ComputeImageBbox procedure} {
+test canvImg-6.7 {ComputeImageBbox procedure} testImageType {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor e
.c bbox i1
} {-10 23 20 38}
-test canvImg-6.8 {ComputeImageBbox procedure} {
+test canvImg-6.8 {ComputeImageBbox procedure} testImageType {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor se
.c bbox i1
} {-10 15 20 30}
-test canvImg-6.9 {ComputeImageBbox procedure} {
+test canvImg-6.9 {ComputeImageBbox procedure} testImageType {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor s
.c bbox i1
} {5 15 35 30}
-test canvImg-6.10 {ComputeImageBbox procedure} {
+test canvImg-6.10 {ComputeImageBbox procedure} testImageType {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor sw
.c bbox i1
} {20 15 50 30}
-test canvImg-6.11 {ComputeImageBbox procedure} {
+test canvImg-6.11 {ComputeImageBbox procedure} testImageType {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor w
.c bbox i1
} {20 23 50 38}
-test canvImg-6.12 {ComputeImageBbox procedure} {
+test canvImg-6.12 {ComputeImageBbox procedure} testImageType {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor center
.c bbox i1
@@ -219,7 +210,7 @@ test canvImg-6.12 {ComputeImageBbox procedure} {
# The following test is non-portable because of differences in
# coordinate rounding on some machines (does 0.5 round up?).
-test canvImg-7.1 {DisplayImage procedure} {nonPortable} {
+test canvImg-7.1 {DisplayImage procedure} {nonPortable testImageType} {
.c delete all
.c create image 50 100 -image foo -tags i1 -anchor nw
update
@@ -238,7 +229,9 @@ test canvImg-7.2 {DisplayImage procedure, no image} {
set i 1
.c delete all
-.c create image 50 100 -image foo -tags image -anchor nw
+if {[testConstraint testImageType]} {
+ .c create image 50 100 -image foo -tags image -anchor nw
+}
.c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
foreach check {
{{50 70 80 81} {70 90} {rect}}
@@ -260,7 +253,7 @@ foreach check {
{{60 70 69 109} {70 110} {image}}
{{60 70 71 111} {70 110} {rect}}
} {
- test canvImg-8.$i {ImageToPoint procedure} {
+ test canvImg-8.$i {ImageToPoint procedure} testImageType {
eval .c coords rect [lindex $check 0]
.c gettags [eval .c find closest [lindex $check 1]]
} [lindex $check 2]
@@ -268,94 +261,96 @@ foreach check {
}
.c delete all
-.c create image 50 100 -image foo -tags image -anchor nw
-test canvImg-8.19 {ImageToArea procedure} {
+if {[testConstraint testImageType]} {
+ .c create image 50 100 -image foo -tags image -anchor nw
+}
+test canvImg-8.19 {ImageToArea procedure} testImageType {
.c gettags [.c find overlapping 60 0 70 99]
} {}
-test canvImg-8.20 {ImageToArea procedure} {
+test canvImg-8.20 {ImageToArea procedure} testImageType {
.c gettags [.c find overlapping 60 0 70 99.999]
} {}
-test canvImg-8.21 {ImageToArea procedure} {
+test canvImg-8.21 {ImageToArea procedure} testImageType {
.c gettags [.c find overlapping 60 0 70 101]
} {image}
-test canvImg-8.22 {ImageToArea procedure} {
+test canvImg-8.22 {ImageToArea procedure} testImageType {
.c gettags [.c find overlapping 81 105 120 115]
} {}
-test canvImg-8.23 {ImageToArea procedure} {
+test canvImg-8.23 {ImageToArea procedure} testImageType {
.c gettags [.c find overlapping 80.001 105 120 115]
} {}
-test canvImg-8.24 {ImageToArea procedure} {
+test canvImg-8.24 {ImageToArea procedure} testImageType {
.c gettags [.c find overlapping 79 105 120 115]
} {image}
-test canvImg-8.25 {ImageToArea procedure} {
+test canvImg-8.25 {ImageToArea procedure} testImageType {
.c gettags [.c find overlapping 60 116 70 150]
} {}
-test canvImg-8.26 {ImageToArea procedure} {
+test canvImg-8.26 {ImageToArea procedure} testImageType {
.c gettags [.c find overlapping 60 115.001 70 150]
} {}
-test canvImg-8.27 {ImageToArea procedure} {
+test canvImg-8.27 {ImageToArea procedure} testImageType {
.c gettags [.c find overlapping 60 114 70 150]
} {image}
-test canvImg-8.28 {ImageToArea procedure} {
+test canvImg-8.28 {ImageToArea procedure} testImageType {
.c gettags [.c find overlapping 0 105 49 115]
} {}
-test canvImg-8.29 {ImageToArea procedure} {
+test canvImg-8.29 {ImageToArea procedure} testImageType {
.c gettags [.c find overlapping 0 105 50 114.999]
} {}
-test canvImg-8.30 {ImageToArea procedure} {
+test canvImg-8.30 {ImageToArea procedure} testImageType {
.c gettags [.c find overlapping 0 105 51 115]
} {image}
-test canvImg-8.31 {ImageToArea procedure} {
+test canvImg-8.31 {ImageToArea procedure} testImageType {
.c gettags [.c find overlapping 0 0 49.999 99.999]
} {}
-test canvImg-8.32 {ImageToArea procedure} {
+test canvImg-8.32 {ImageToArea procedure} testImageType {
.c gettags [.c find overlapping 0 0 51 101]
} {image}
-test canvImg-8.33 {ImageToArea procedure} {
+test canvImg-8.33 {ImageToArea procedure} testImageType {
.c gettags [.c find overlapping 80 0 150 100]
} {}
-test canvImg-8.34 {ImageToArea procedure} {
+test canvImg-8.34 {ImageToArea procedure} testImageType {
.c gettags [.c find overlapping 79 0 150 101]
} {image}
-test canvImg-8.35 {ImageToArea procedure} {
+test canvImg-8.35 {ImageToArea procedure} testImageType {
.c gettags [.c find overlapping 80.001 115.001 150 180]
} {}
-test canvImg-8.36 {ImageToArea procedure} {
+test canvImg-8.36 {ImageToArea procedure} testImageType {
.c gettags [.c find overlapping 79 114 150 180]
} {image}
-test canvImg-8.37 {ImageToArea procedure} {
+test canvImg-8.37 {ImageToArea procedure} testImageType {
.c gettags [.c find overlapping 0 115 50 180]
} {}
-test canvImg-8.38 {ImageToArea procedure} {
+test canvImg-8.38 {ImageToArea procedure} testImageType {
.c gettags [.c find overlapping 0 114 51 180]
} {image}
-test canvImg-8.39 {ImageToArea procedure} {
+test canvImg-8.39 {ImageToArea procedure} testImageType {
.c gettags [.c find enclosed 0 0 200 200]
} {image}
-test canvImg-8.40 {ImageToArea procedure} {
+test canvImg-8.40 {ImageToArea procedure} testImageType {
.c gettags [.c find enclosed 49.999 99.999 80.001 115.001]
} {image}
-test canvImg-8.41 {ImageToArea procedure} {
+test canvImg-8.41 {ImageToArea procedure} testImageType {
.c gettags [.c find enclosed 51 100 80 115]
} {}
-test canvImg-8.42 {ImageToArea procedure} {
+test canvImg-8.42 {ImageToArea procedure} testImageType {
.c gettags [.c find enclosed 50 101 80 115]
} {}
-test canvImg-8.43 {ImageToArea procedure} {
+test canvImg-8.43 {ImageToArea procedure} testImageType {
.c gettags [.c find enclosed 50 100 79 115]
} {}
-test canvImg-8.44 {ImageToArea procedure} {
+test canvImg-8.44 {ImageToArea procedure} testImageType {
.c gettags [.c find enclosed 50 100 80 114]
} {}
-test canvImg-9.1 {DisplayImage procedure} {
+test canvImg-9.1 {DisplayImage procedure} testImageType {
.c delete all
.c create image 50 100 -image foo -tags image -anchor nw
.c scale image 25 0 2.0 1.5
.c bbox image
} {75 150 105 165}
-test canvImg-10.1 {TranslateImage procedure} {
+test canvImg-10.1 {TranslateImage procedure} testImageType {
.c delete all
.c create image 50 100 -image foo -tags image -anchor nw
update
@@ -365,7 +360,7 @@ test canvImg-10.1 {TranslateImage procedure} {
set x
} {{foo display 2 4 6 8 30 30}}
-test canvImg-11.1 {TranslateImage procedure} {
+test canvImg-11.1 {TranslateImage procedure} testImageType {
.c delete all
.c create image 50 100 -image foo -tags image -anchor nw
update
@@ -374,7 +369,7 @@ test canvImg-11.1 {TranslateImage procedure} {
update
set x
} {{foo display 0 0 40 50 30 30}}
-test canvImg-11.2 {ImageChangedProc procedure} {
+test canvImg-11.2 {ImageChangedProc procedure} testImageType {
.c delete all
image create test foo -variable x
.c create image 50 100 -image foo -tags image -anchor center
@@ -383,7 +378,7 @@ test canvImg-11.2 {ImageChangedProc procedure} {
foo changed 0 0 0 0 40 50
.c bbox image
} {30 75 70 125}
-test canvImg-11.3 {ImageChangedProc procedure} {
+test canvImg-11.3 {ImageChangedProc procedure} testImageType {
.c delete all
image create test foo -variable x
foo changed 0 0 0 0 40 50
diff --git a/tests/canvPs.test b/tests/canvPs.test
index 08d72cf..8faad75 100644
--- a/tests/canvPs.test
+++ b/tests/canvPs.test
@@ -6,17 +6,17 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: canvPs.test,v 1.3 1999/04/16 01:51:34 stanton Exp $
+# RCS: @(#) $Id: canvPs.test,v 1.4 2002/07/14 05:48:46 dgp Exp $
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
+package require tcltest 2.1
+namespace import -force tcltest::configure
+namespace import -force tcltest::testsDirectory
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
-foreach i [winfo children .] {
- destroy $i
-}
-wm geometry . {}
-raise .
+namespace import -force tcltest::makeFile
+namespace import -force tcltest::removeFile
canvas .c -width 400 -height 300 -bd 2 -relief sunken
.c create rectangle 20 20 80 80 -fill red
@@ -97,9 +97,7 @@ test canvPs-2.4 {test writing to channel and file, same output} {pcOnly} {
# cleanup
removeFile foo.ps
removeFile bar.ps
-foreach i [winfo children .] {
- destroy $i
-}
+deleteWindows
::tcltest::cleanupTests
return
diff --git a/tests/canvRect.test b/tests/canvRect.test
index 64d7de3..a08679d 100644
--- a/tests/canvRect.test
+++ b/tests/canvRect.test
@@ -6,17 +6,14 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: canvRect.test,v 1.4 1999/12/14 06:53:12 hobbs Exp $
+# RCS: @(#) $Id: canvRect.test,v 1.5 2002/07/14 05:48:46 dgp Exp $
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-
-foreach i [winfo children .] {
- destroy $i
-}
-wm geometry . {}
-raise .
+package require tcltest 2.1
+namespace import -force tcltest::configure
+namespace import -force tcltest::testsDirectory
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
canvas .c -width 400 -height 300 -bd 2 -relief sunken
pack .c
diff --git a/tests/canvText.test b/tests/canvText.test
index a6316c0..c23f949 100644
--- a/tests/canvText.test
+++ b/tests/canvText.test
@@ -6,17 +6,14 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: canvText.test,v 1.10 2002/06/25 16:27:44 a_kovalenko Exp $
-
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-
-foreach i [winfo children .] {
- destroy $i
-}
-wm geometry . {}
-raise .
+# RCS: @(#) $Id: canvText.test,v 1.11 2002/07/14 05:48:46 dgp Exp $
+
+package require tcltest 2.1
+namespace import -force tcltest::configure
+namespace import -force tcltest::testsDirectory
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
canvas .c -width 400 -height 300 -bd 2 -relief sunken
pack .c
diff --git a/tests/canvWind.test b/tests/canvWind.test
index 76db55c..e8077cb 100644
--- a/tests/canvWind.test
+++ b/tests/canvWind.test
@@ -6,17 +6,14 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: canvWind.test,v 1.3 1999/04/16 01:51:35 stanton Exp $
-
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-
-foreach i [winfo children .] {
- destroy $i
-}
-wm geometry . {}
-raise .
+# RCS: @(#) $Id: canvWind.test,v 1.4 2002/07/14 05:48:46 dgp Exp $
+
+package require tcltest 2.1
+namespace import -force tcltest::configure
+namespace import -force tcltest::testsDirectory
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
test canvWind-1.1 {DisplayWinItem, windows off-screen vertically} {
catch {destroy .t}
diff --git a/tests/canvas.test b/tests/canvas.test
index 15cd806..84e7c62 100644
--- a/tests/canvas.test
+++ b/tests/canvas.test
@@ -6,17 +6,14 @@
# Copyright (c) 1998-2000 Ajuba Solutions.
# All rights reserved.
#
-# RCS: @(#) $Id: canvas.test,v 1.13 2001/07/04 00:40:11 hobbs Exp $
+# RCS: @(#) $Id: canvas.test,v 1.14 2002/07/14 05:48:46 dgp Exp $
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-
-foreach i [winfo children .] {
- destroy $i
-}
-wm geometry . {}
-raise .
+package require tcltest 2.1
+namespace import -force tcltest::configure
+namespace import -force tcltest::testsDirectory
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
# XXX - This test file is woefully incomplete. At present, only a
# few of the features are tested.
@@ -135,7 +132,7 @@ test canvas-3.2 {CanvasWidgetCmd, yview option} {
} {{0 0.5} {0.1 0.6}}
test canvas-4.1 {ButtonEventProc procedure} {
- eval destroy [winfo children .]
+ deleteWindows
canvas .c1 -bg #543210
rename .c1 .c2
set x {}
@@ -146,7 +143,7 @@ test canvas-4.1 {ButtonEventProc procedure} {
} {.c1 #543210 {} {}}
test canvas-5.1 {ButtonCmdDeletedProc procedure} {
- eval destroy [winfo children .]
+ deleteWindows
canvas .c1
rename .c1 {}
list [info command .c*] [winfo children .]
@@ -196,7 +193,7 @@ test canvas-6.5 {CanvasSetOrigin procedure} {
} {55.0}
set l [interp hidden]
-eval destroy [winfo children .]
+deleteWindows
test canvas-7.1 {canvas widget vs hidden commands} {
catch {destroy .c}
diff --git a/tests/choosedir.test b/tests/choosedir.test
index 6e03266..e8da6a3 100644
--- a/tests/choosedir.test
+++ b/tests/choosedir.test
@@ -5,13 +5,17 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: choosedir.test,v 1.9 2000/04/10 22:43:13 ericm Exp $
+# RCS: @(#) $Id: choosedir.test,v 1.10 2002/07/14 05:48:46 dgp Exp $
#
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
+package require tcltest 2.1
+namespace import -force tcltest::configure
+namespace import -force tcltest::testsDirectory
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
+
+namespace import -force tcltest::makeDirectory
#----------------------------------------------------------------------
#
diff --git a/tests/clipboard.test b/tests/clipboard.test
index 02c3fa2..ba937fc 100644
--- a/tests/clipboard.test
+++ b/tests/clipboard.test
@@ -6,18 +6,19 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: clipboard.test,v 1.5 2000/08/01 18:52:45 ericm Exp $
+# RCS: @(#) $Id: clipboard.test,v 1.6 2002/07/14 05:48:46 dgp Exp $
#
# Note: Multiple display clipboard handling will only be tested if the
# environment variable TK_ALT_DISPLAY is set to an alternate display.
#
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-
-eval destroy [winfo child .]
+package require tcltest 2.1
+namespace import -force tcltest::configure
+namespace import -force tcltest::testsDirectory
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
# set up a very large buffer to test INCR retrievals
set longValue ""
diff --git a/tests/clrpick.test b/tests/clrpick.test
index 2259fe7..77dce58 100644
--- a/tests/clrpick.test
+++ b/tests/clrpick.test
@@ -5,18 +5,15 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: clrpick.test,v 1.6 2001/08/01 16:21:12 dgp Exp $
+# RCS: @(#) $Id: clrpick.test,v 1.7 2002/07/14 05:48:46 dgp Exp $
#
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-
-# Some tests require user interaction on non-unix platform
-
-set ::tcltest::testConfig(nonUnixUserInteraction) \
- [expr {$::tcltest::testConfig(userInteraction) || \
- $::tcltest::testConfig(unixOnly)}]
+package require tcltest 2.1
+namespace import -force tcltest::configure
+namespace import -force tcltest::testsDirectory
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
test clrpick-1.1 {tk_chooseColor command} {
list [catch {tk_chooseColor -foo} msg] $msg
@@ -140,7 +137,7 @@ set verylongstring $verylongstring$verylongstring
# machines with small color palettes still fail.
# some tests will be skipped if there are no more colors
set numcolors 32
-set ::tcltest::testConfig(colorsLeftover) 1
+testConstraint colorsLeftover 1
set i 0
canvas .c
pack .c -expand 1 -fill both
@@ -158,7 +155,7 @@ while {$i<$numcolors} {
set g [expr $g/256]
set b [expr $b/256]
if {"$color" != "#[format %02x%02x%02x $r $g $b]"} {
- set ::tcltest::testConfig(colorsLeftover) 0
+ testConstraint colorsLeftover 0
}
}
.c delete $i
diff --git a/tests/cmds.test b/tests/cmds.test
index c6301d9..87871b3 100644
--- a/tests/cmds.test
+++ b/tests/cmds.test
@@ -5,14 +5,15 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: cmds.test,v 1.3 1999/04/16 01:51:35 stanton Exp $
+# RCS: @(#) $Id: cmds.test,v 1.4 2002/07/14 05:48:46 dgp Exp $
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
+package require tcltest 2.1
+namespace import -force tcltest::configure
+namespace import -force tcltest::testsDirectory
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
-eval destroy [winfo child .]
-wm geometry . {}
update
test cmds-1.1 {tkwait visibility, argument errors} {
diff --git a/tests/color.test b/tests/color.test
index b7fed15..fec3748 100644
--- a/tests/color.test
+++ b/tests/color.test
@@ -5,21 +5,16 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: color.test,v 1.5 2000/11/02 01:18:35 hobbs Exp $
+# RCS: @(#) $Id: color.test,v 1.6 2002/07/14 05:48:46 dgp Exp $
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-
-if {[info commands testcolor] != "testcolor"} {
- puts "testcolor command not available; skipping tests"
- ::tcltest::cleanupTests
- return
-}
+package require tcltest 2.1
+namespace import -force tcltest::configure
+namespace import -force tcltest::testsDirectory
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
-eval destroy [winfo children .]
-wm geometry . {}
-raise .
+testConstraint testcolor [llength [info commands testcolor]]
# cname --
# Returns a proper name for a color, given its intensities.
@@ -102,39 +97,24 @@ proc colorsFree {w {red 31} {green 245} {blue 192}} {
&& ([lindex $vals 2]/256 == $blue)
}
-# Create a top-level with its own colormap (so we can test under
-# controlled conditions), then check to make sure that the visual
-# is color-mapped with 256 colors. If not, just skip this whole
-# test file.
+if {[testConstraint psuedocolor8]} {
+ toplevel .t -visual {pseudocolor 8} -colormap new
+ wm geom .t +0+0
+ mkColors .t.c 40 6 0 0 0 0 6 0 0 0 40
+ pack .t.c
+ update
-if [catch {toplevel .t -visual {pseudocolor 8} -colormap new}] {
- ::tcltest::cleanupTests
- return
-}
-wm geom .t +0+0
-if {[winfo depth .t] != 8} {
- destroy .t
- ::tcltest::cleanupTests
- return
-}
-mkColors .t.c 40 6 0 0 0 0 6 0 0 0 40
-pack .t.c
-update
-if ![colorsFree .t.c 101 233 17] {
- destroy .t
- ::tcltest::cleanupTests
- return
-}
-mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0
-pack .t.c2
-if [colorsFree .t.c] {
- destroy .t
- ::tcltest::cleanupTests
- return
+ testConstraint colorsFree [colorsFree .t.c 101 233 17]
+
+ if {[testConstraint colorsFree]} {
+ mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0
+ pack .t.c2
+ testConstraint colorsFree [expr {![colorsFree .t.c]}]
+ }
+ destroy .t.c .t.c2
}
-destroy .t.c .t.c2
-test color-1.1 {Tk_AllocColorFromObj - converting internal reps} {
+test color-1.1 {Tk_AllocColorFromObj - converting internal reps} colorsFree {
set x green
lindex $x 0
destroy .b1
@@ -142,7 +122,7 @@ test color-1.1 {Tk_AllocColorFromObj - converting internal reps} {
lindex $x 0
testcolor green
} {{1 0}}
-test color-1.2 {Tk_AllocColorFromObj - discard stale color} {
+test color-1.2 {Tk_AllocColorFromObj - discard stale color} colorsFree {
set x green
destroy .b1 .b2
button .b1 -foreground $x -text First
@@ -152,7 +132,7 @@ test color-1.2 {Tk_AllocColorFromObj - discard stale color} {
button .b2 -foreground $x -text Second
lappend result [testcolor green]
} {{} {{1 1}}}
-test color-1.3 {Tk_AllocColorFromObj - reuse existing color} {
+test color-1.3 {Tk_AllocColorFromObj - reuse existing color} colorsFree {
set x green
destroy .b1 .b2
button .b1 -foreground $x -text First
@@ -162,7 +142,7 @@ test color-1.3 {Tk_AllocColorFromObj - reuse existing color} {
pack .b1 .b2 -side top
lappend result [testcolor green]
} {{{1 1}} {{2 1}}}
-test color-1.4 {Tk_AllocColorFromObj - try other colors in list} {
+test color-1.4 {Tk_AllocColorFromObj - try other colors in list} colorsFree {
set x purple
destroy .b1 .b2 .t.b
button .b1 -foreground $x -text First
@@ -177,30 +157,30 @@ test color-1.4 {Tk_AllocColorFromObj - try other colors in list} {
lappend result [testcolor purple]
} {{{1 1}} {{1 1} {1 0}} {{1 0} {2 1}}}
-test color-2.1 {Tk_GetColor procedure} {
+test color-2.1 {Tk_GetColor procedure} colorsFree {
c255 [winfo rgb .t #FF0000]
} {255 0 0}
-test color-2.2 {Tk_GetColor procedure} {
+test color-2.2 {Tk_GetColor procedure} colorsFree {
list [catch {winfo rgb .t noname} msg] $msg
} {1 {unknown color name "noname"}}
-test color-2.3 {Tk_GetColor procedure} {
+test color-2.3 {Tk_GetColor procedure} colorsFree {
c255 [winfo rgb .t #123456]
} {18 52 86}
-test color-2.4 {Tk_GetColor procedure} {
+test color-2.4 {Tk_GetColor procedure} colorsFree {
list [catch {winfo rgb .t #xyz} msg] $msg
} {1 {invalid color name "#xyz"}}
-test color-2.5 {Tk_GetColor procedure} {
+test color-2.5 {Tk_GetColor procedure} colorsFree {
winfo rgb .t #00FF00
} {0 65535 0}
-test color-2.6 {Tk_GetColor procedure} {nonPortable} {
+test color-2.6 {Tk_GetColor procedure} {colorsFree nonPortable} {
# Red doesn't always map to *pure* red
winfo rgb .t red
} {65535 0 0}
-test color-2.7 {Tk_GetColor procedure} {
+test color-2.7 {Tk_GetColor procedure} colorsFree {
winfo rgb .t #ff0000
} {65535 0 0}
-test color-3.1 {Tk_FreeColor procedure, reference counting} {
+test color-3.1 {Tk_FreeColor procedure, reference counting} colorsFree {
eval destroy [winfo child .t]
mkColors .t.c 40 6 0 240 240 0 -6 0 0 0 -40
pack .t.c
@@ -214,7 +194,7 @@ test color-3.1 {Tk_FreeColor procedure, reference counting} {
.t.c2 delete $last
lappend result [colorsFree .t]
} {0 1}
-test color-3.2 {Tk_FreeColor procedure, flushing stressed cmap information} {
+test color-3.2 {Tk_FreeColor procedure, flushing stressed cmap information} colorsFree {
eval destroy [winfo child .t]
mkColors .t.c 40 6 0 240 240 0 -6 0 0 0 -40
pack .t.c
@@ -224,7 +204,7 @@ test color-3.2 {Tk_FreeColor procedure, flushing stressed cmap information} {
update
closest .t 241 241 1
} {240 240 0}
-test color-3.3 {Tk_FreeColorFromObj - reference counts} {
+test color-3.3 {Tk_FreeColorFromObj - reference counts} colorsFree {
set x purple
destroy .b1 .b2 .t.b
button .b1 -foreground $x -text First
@@ -242,7 +222,7 @@ test color-3.3 {Tk_FreeColorFromObj - reference counts} {
destroy .t.b
lappend result [testcolor purple]
} {{{1 0} {2 1}} {{1 0} {1 1}} {{1 0}} {}}
-test color-3.4 {Tk_FreeColorFromObj - unlinking from list} {
+test color-3.4 {Tk_FreeColorFromObj - unlinking from list} colorsFree {
destroy .b .t.b .t2 .t3
toplevel .t2 -visual {pseudocolor 8} -colormap new
toplevel .t3 -visual {pseudocolor 8} -colormap new
@@ -269,7 +249,7 @@ test color-3.4 {Tk_FreeColorFromObj - unlinking from list} {
lappend result [testcolor purple]
} {{{4 1} {3 0} {2 0} {1 0}} {{4 1} {2 0} {1 0}} {{4 1} {2 0}} {{2 0}} {}}
-test color-4.1 {FreeColorObjProc} {
+test color-4.1 {FreeColorObjProc} colorsFree {
destroy .b
set x [format purple]
button .b -foreground $x -text .b1
diff --git a/tests/config.test b/tests/config.test
index 34c81fd..df9c0c4 100644
--- a/tests/config.test
+++ b/tests/config.test
@@ -6,19 +6,16 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: config.test,v 1.5 2001/08/29 23:22:24 hobbs Exp $
+# RCS: @(#) $Id: config.test,v 1.6 2002/07/14 05:48:46 dgp Exp $
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
+package require tcltest 2.1
+namespace import -force tcltest::configure
+namespace import -force tcltest::testsDirectory
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
-if {[info command testobjconfig] != "testobjconfig"} {
- puts "This application hasn't been compiled with the \"testobjconfig\""
- puts "command, so I can't run this test. Are you sure you're using"
- puts "tktest instead of wish?"
- ::tcltest::cleanupTests
- return
-}
+testConstraint testobjconfig [llength [info commands testobjconfig]]
proc killTables {} {
# Note: it's important to delete chain2 before chain1, because
@@ -33,79 +30,76 @@ proc killTables {} {
}
}
-foreach i [winfo children .] {
- destroy $i
+if {[testConstraint testobjconfig]} {
+ killTables
}
-killTables
-wm geometry . {}
-raise .
-test config-1.1 {Tk_CreateOptionTable - reference counts} {
- eval destroy [winfo children .]
+test config-1.1 {Tk_CreateOptionTable - reference counts} testobjconfig {
+ deleteWindows
killTables
set x {}
testobjconfig alltypes .a
lappend x [testobjconfig info alltypes]
testobjconfig alltypes .b
lappend x [testobjconfig info alltypes]
- eval destroy [winfo children .]
+ deleteWindows
set x
} {{1 16 -boolean} {2 16 -boolean}}
-test config-1.2 {Tk_CreateOptionTable - synonym initialization} {
- eval destroy [winfo children .]
+test config-1.2 {Tk_CreateOptionTable - synonym initialization} testobjconfig {
+ deleteWindows
testobjconfig alltypes .a -synonym green
.a cget -color
} {green}
-test config-1.3 {Tk_CreateOptionTable - option database initialization} {
- eval destroy [winfo children .]
+test config-1.3 {Tk_CreateOptionTable - option database initialization} testobjconfig {
+ deleteWindows
option clear
testobjconfig alltypes .a
option add *b.string different
testobjconfig alltypes .b
list [.a cget -string] [.b cget -string]
} {foo different}
-test config-1.4 {Tk_CreateOptionTable - option database initialization} {
- eval destroy [winfo children .]
+test config-1.4 {Tk_CreateOptionTable - option database initialization} testobjconfig {
+ deleteWindows
option clear
testobjconfig alltypes .a
option add *b.String bar
testobjconfig alltypes .b
list [.a cget -string] [.b cget -string]
} {foo bar}
-test config-1.5 {Tk_CreateOptionTable - default initialization} {
- eval destroy [winfo children .]
+test config-1.5 {Tk_CreateOptionTable - default initialization} testobjconfig {
+ deleteWindows
testobjconfig alltypes .a
.a cget -relief
} {raised}
-test config-1.6 {Tk_CreateOptionTable - chained tables} {
- eval destroy [winfo children .]
+test config-1.6 {Tk_CreateOptionTable - chained tables} testobjconfig {
+ deleteWindows
killTables
testobjconfig chain1 .a
testobjconfig chain2 .b
testobjconfig info chain2
} {1 4 -three 2 2 -one}
-test config-1.7 {Tk_CreateOptionTable - chained tables} {
- eval destroy [winfo children .]
+test config-1.7 {Tk_CreateOptionTable - chained tables} testobjconfig {
+ deleteWindows
killTables
testobjconfig chain2 .b
testobjconfig chain1 .a
testobjconfig info chain2
} {1 4 -three 2 2 -one}
-test config-1.8 {Tk_CreateOptionTable - chained tables} {
- eval destroy [winfo children .]
+test config-1.8 {Tk_CreateOptionTable - chained tables} testobjconfig {
+ deleteWindows
testobjconfig chain1 .a
testobjconfig chain2 .b
list [catch {.a cget -four} msg] $msg [.a cget -one] \
[.b cget -four] [.b cget -one]
} {1 {unknown option "-four"} one four one}
-test config-2.1 {Tk_DeleteOptionTable - reference counts} {
- eval destroy [winfo children .]
+test config-2.1 {Tk_DeleteOptionTable - reference counts} testobjconfig {
+ deleteWindows
killTables
testobjconfig chain1 .a
testobjconfig chain2 .b
testobjconfig chain2 .c
- eval destroy [winfo children .]
+ deleteWindows
set x {}
testobjconfig delete chain2
lappend x [testobjconfig info chain2] [testobjconfig info chain1]
@@ -115,38 +109,38 @@ test config-2.1 {Tk_DeleteOptionTable - reference counts} {
# No tests for DestroyOptionHashTable; couldn't figure out how to test.
-test config-3.1 {Tk_InitOptions - priority of chained tables} {
- eval destroy [winfo children .]
+test config-3.1 {Tk_InitOptions - priority of chained tables} testobjconfig {
+ deleteWindows
testobjconfig chain1 .a
testobjconfig chain2 .b
list [.a cget -two] [.b cget -two]
} {two {two and a half}}
-test config-3.2 {Tk_InitOptions - initialize from database} {
- eval destroy [winfo children .]
+test config-3.2 {Tk_InitOptions - initialize from database} testobjconfig {
+ deleteWindows
option clear
option add *a.color blue
testobjconfig alltypes .a
list [.a cget -color]
} {blue}
-test config-3.3 {Tk_InitOptions - initialize from database} {
- eval destroy [winfo children .]
+test config-3.3 {Tk_InitOptions - initialize from database} testobjconfig {
+ deleteWindows
option clear
option add *a.justify bogus
testobjconfig alltypes .a
list [.a cget -justify]
} {left}
-test config-3.4 {Tk_InitOptions - initialize from widget class} {
- eval destroy [winfo children .]
+test config-3.4 {Tk_InitOptions - initialize from widget class} testobjconfig {
+ deleteWindows
testobjconfig alltypes .a
list [.a cget -color]
} {red}
-test config-3.5 {Tk_InitOptions - no initial value} {
- eval destroy [winfo children .]
+test config-3.5 {Tk_InitOptions - no initial value} testobjconfig {
+ deleteWindows
testobjconfig alltypes .a
.a cget -anchor
} {}
-test config-3.6 {Tk_InitOptions - bad initial value} {
- eval destroy [winfo children .]
+test config-3.6 {Tk_InitOptions - bad initial value} testobjconfig {
+ deleteWindows
option clear
option add *a.color non-existent
list [catch {testobjconfig alltypes .a} msg] $msg $errorInfo
@@ -155,8 +149,8 @@ test config-3.6 {Tk_InitOptions - bad initial value} {
invoked from within
"testobjconfig alltypes .a"}}
option clear
-test config-3.7 {Tk_InitOptions - bad initial value} {
- eval destroy [winfo children .]
+test config-3.7 {Tk_InitOptions - bad initial value} testobjconfig {
+ deleteWindows
list [catch {testobjconfig configerror} msg] $msg $errorInfo
} {1 {expected integer but got "bogus"} {expected integer but got "bogus"
(default value for "-int")
@@ -164,280 +158,280 @@ test config-3.7 {Tk_InitOptions - bad initial value} {
"testobjconfig configerror"}}
option clear
-test config-4.1 {DoObjConfig - boolean} {
+test config-4.1 {DoObjConfig - boolean} testobjconfig {
catch {rename .foo {}}
list [catch {testobjconfig alltypes .foo -boolean 0} msg] $msg [catch {.foo cget -boolean} result] $result [catch {rename .foo {}}]
} {0 .foo 0 0 0}
-test config-4.2 {DoObjConfig - boolean} {
+test config-4.2 {DoObjConfig - boolean} testobjconfig {
catch {rename .foo {}}
list [catch {testobjconfig alltypes .foo -boolean 1} msg] $msg [catch {.foo cget -boolean} result] $result [catch {rename .foo {}}]
} {0 .foo 0 1 0}
-test config-4.3 {DoObjConfig - invalid boolean} {
+test config-4.3 {DoObjConfig - invalid boolean} testobjconfig {
catch {rename .foo {}}
list [catch {testobjconfig alltypes .foo -boolean {}} msg] $msg
} {1 {expected boolean value but got ""}}
-test config-4.4 {DoObjConfig - boolean internal value} {
+test config-4.4 {DoObjConfig - boolean internal value} testobjconfig {
catch {rename .foo {}}
testobjconfig internal .foo -boolean 0
.foo cget -boolean
} {0}
-test config-4.5 {DoObjConfig - integer} {
+test config-4.5 {DoObjConfig - integer} testobjconfig {
catch {rename .foo {}}
list [catch {testobjconfig alltypes .foo -integer 3} msg] $msg [catch {.foo cget -integer} result] $result [catch {rename .foo {}}]
} {0 .foo 0 3 0}
-test config-4.6 {DoObjConfig - invalid integer} {
+test config-4.6 {DoObjConfig - invalid integer} testobjconfig {
catch {rename .foo {}}
list [catch {testobjconfig alltypes .foo -integer bar} msg] $msg
} {1 {expected integer but got "bar"}}
-test config-4.7 {DoObjConfig - integer internal value} {
+test config-4.7 {DoObjConfig - integer internal value} testobjconfig {
catch {rename .foo {}}
testobjconfig internal .foo -integer 421
.foo cget -integer
} {421}
-test config-4.8 {DoObjConfig - double} {
+test config-4.8 {DoObjConfig - double} testobjconfig {
catch {rename .foo {}}
list [catch {testobjconfig alltypes .foo -double 3.14} msg] $msg [catch {.foo cget -double} result] $result [catch {rename .foo {}}]
} {0 .foo 0 3.14 0}
-test config-4.9 {DoObjConfig - invalid double} {
+test config-4.9 {DoObjConfig - invalid double} testobjconfig {
catch {rename .foo {}}
list [catch {testobjconfig alltypes .foo -double bar} msg] $msg
} {1 {expected floating-point number but got "bar"}}
-test config-4.10 {DoObjConfig - double internal value} {
+test config-4.10 {DoObjConfig - double internal value} testobjconfig {
catch {rename .foo {}}
testobjconfig internal .foo -double 62.75
.foo cget -double
} {62.75}
-test config-4.11 {DoObjConfig - string} {
+test config-4.11 {DoObjConfig - string} testobjconfig {
catch {destroy .foo}
list [catch {testobjconfig alltypes .foo -string test} msg] $msg [catch {.foo cget -string} result] $result [destroy .foo]
} {0 .foo 0 test {}}
-test config-4.12 {DoObjConfig - null string} {
+test config-4.12 {DoObjConfig - null string} testobjconfig {
catch {destroy .foo}
list [catch {testobjconfig alltypes .foo -string {}} msg] $msg [catch {.foo cget -string} result] $result [destroy .foo]
} {0 .foo 0 {} {}}
-test config-4.13 {DoObjConfig - string internal value} {
+test config-4.13 {DoObjConfig - string internal value} testobjconfig {
catch {rename .foo {}}
testobjconfig internal .foo -string "this is a test"
.foo cget -string
} {this is a test}
-test config-4.14 {DoObjConfig - string table} {
+test config-4.14 {DoObjConfig - string table} testobjconfig {
catch {destroy .foo}
list [catch {testobjconfig alltypes .foo -stringtable two} msg] $msg [catch {.foo cget -stringtable} result] $result [destroy .foo]
} {0 .foo 0 two {}}
-test config-4.15 {DoObjConfig - invalid string table} {
+test config-4.15 {DoObjConfig - invalid string table} testobjconfig {
catch {destroy .foo}
list [catch {testobjconfig alltypes .foo -stringtable foo} msg] $msg
} {1 {bad stringtable "foo": must be one, two, three, or four}}
-test config-4.16 {DoObjConfig - new string table} {
+test config-4.16 {DoObjConfig - new string table} testobjconfig {
catch {destroy .foo}
testobjconfig alltypes .foo -stringtable two
list [catch {.foo configure -stringtable three} msg] $msg [catch {.foo cget -stringtable} result] $result [destroy .foo]
} {0 16 0 three {}}
-test config-4.17 {DoObjConfig - stringtable internal value} {
+test config-4.17 {DoObjConfig - stringtable internal value} testobjconfig {
catch {rename .foo {}}
testobjconfig internal .foo -stringtable "four"
.foo cget -stringtable
} {four}
-test config-4.18 {DoObjConfig - color} {
+test config-4.18 {DoObjConfig - color} testobjconfig {
catch {rename .foo {}}
list [catch {testobjconfig alltypes .foo -color blue} msg] $msg [catch {.foo cget -color} result] $result [destroy .foo]
} {0 .foo 0 blue {}}
-test config-4.19 {DoObjConfig - invalid color} {
+test config-4.19 {DoObjConfig - invalid color} testobjconfig {
catch {destroy .foo}
list [catch {testobjconfig alltypes .foo -color xxx} msg] $msg
} {1 {unknown color name "xxx"}}
-test config-4.20 {DoObjConfig - color internal value} {
+test config-4.20 {DoObjConfig - color internal value} testobjconfig {
catch {rename .foo {}}
testobjconfig internal .foo -color purple
.foo cget -color
} {purple}
-test config-4.21 {DoObjConfig - null color} {
+test config-4.21 {DoObjConfig - null color} testobjconfig {
catch {rename .foo {}}
list [catch {testobjconfig alltypes .foo -color {}} msg] $msg [catch {.foo cget -color} result] $result [destroy .foo]
} {0 .foo 0 {} {}}
-test config-4.22 {DoObjConfig - getting rid of old color} {
+test config-4.22 {DoObjConfig - getting rid of old color} testobjconfig {
catch {destroy .foo}
testobjconfig alltypes .foo -color #333333
list [catch {.foo configure -color #444444} msg] $msg [catch {.foo cget -color} result] $result [destroy .foo]
} {0 32 0 #444444 {}}
-test config-4.23 {DoObjConfig - font} {
+test config-4.23 {DoObjConfig - font} testobjconfig {
catch {rename .foo {}}
list [catch {testobjconfig alltypes .foo -font {Helvetica 72}} msg] $msg [catch {.foo cget -font} result] $result [destroy .foo]
} {0 .foo 0 {Helvetica 72} {}}
-test config-4.24 {DoObjConfig - new font} {
+test config-4.24 {DoObjConfig - new font} testobjconfig {
catch {rename .foo {}}
testobjconfig alltypes .foo -font {Courier 12}
list [catch {.foo configure -font {Helvetica 72}} msg] $msg [catch {.foo cget -font} result] $result [destroy .foo]
} {0 64 0 {Helvetica 72} {}}
-test config-4.25 {DoObjConfig - invalid font} {
+test config-4.25 {DoObjConfig - invalid font} testobjconfig {
catch {rename .foo {}}
list [catch {testobjconfig alltypes .foo -font {Helvetica 12 foo}} msg] $msg
} {1 {unknown font style "foo"}}
-test config-4.26 {DoObjConfig - null font} {
+test config-4.26 {DoObjConfig - null font} testobjconfig {
catch {rename .foo {}}
list [catch {testobjconfig alltypes .foo -font {}} msg] $msg [catch {.foo cget -font} result] $result [destroy .foo]
} {0 .foo 0 {} {}}
-test config-4.27 {DoObjConfig - font internal value} {
+test config-4.27 {DoObjConfig - font internal value} testobjconfig {
catch {rename .foo {}}
testobjconfig internal .foo -font {Times 16}
.foo cget -font
} {Times 16}
-test config-4.28 {DoObjConfig - bitmap} {
+test config-4.28 {DoObjConfig - bitmap} testobjconfig {
catch {destroy .foo}
list [catch {testobjconfig alltypes .foo -bitmap gray75} msg] $msg [catch {.foo cget -bitmap} result] $result [destroy .foo]
} {0 .foo 0 gray75 {}}
-test config-4.29 {DoObjConfig - new bitmap} {
+test config-4.29 {DoObjConfig - new bitmap} testobjconfig {
catch {destroy .foo}
testobjconfig alltypes .foo -bitmap gray75
list [catch {.foo configure -bitmap gray50} msg] $msg [catch {.foo cget -bitmap} result] $result [destroy .foo]
} {0 128 0 gray50 {}}
-test config-4.30 {DoObjConfig - invalid bitmap} {
+test config-4.30 {DoObjConfig - invalid bitmap} testobjconfig {
catch {destroy .foo}
list [catch {testobjconfig alltypes .foo -bitmap foo} msg] $msg
} {1 {bitmap "foo" not defined}}
-test config-4.31 {DoObjConfig - null bitmap} {
+test config-4.31 {DoObjConfig - null bitmap} testobjconfig {
catch {destroy .foo}
list [catch {testobjconfig alltypes .foo -bitmap {}} msg] $msg [catch {.foo cget -bitmap} result] $result [destroy .foo]
} {0 .foo 0 {} {}}
-test config-4.32 {DoObjConfig - bitmap internal value} {
+test config-4.32 {DoObjConfig - bitmap internal value} testobjconfig {
catch {rename .foo {}}
testobjconfig internal .foo -bitmap gray25
.foo cget -bitmap
} {gray25}
-test config-4.33 {DoObjConfig - border} {
+test config-4.33 {DoObjConfig - border} testobjconfig {
catch {rename .foo {}}
list [catch {testobjconfig alltypes .foo -border green} msg] $msg [catch {.foo cget -border} result] $result [destroy .foo]
} {0 .foo 0 green {}}
-test config-4.34 {DoObjConfig - invalid border} {
+test config-4.34 {DoObjConfig - invalid border} testobjconfig {
catch {destroy .foo}
list [catch {testobjconfig alltypes .foo -border xxx} msg] $msg
} {1 {unknown color name "xxx"}}
-test config-4.35 {DoObjConfig - null border} {
+test config-4.35 {DoObjConfig - null border} testobjconfig {
catch {rename .foo {}}
list [catch {testobjconfig alltypes .foo -border {}} msg] $msg [catch {.foo cget -border} result] $result [destroy .foo]
} {0 .foo 0 {} {}}
-test config-4.36 {DoObjConfig - border internal value} {
+test config-4.36 {DoObjConfig - border internal value} testobjconfig {
catch {rename .foo {}}
testobjconfig internal .foo -border #123456
.foo cget -border
} {#123456}
-test config-4.37 {DoObjConfig - getting rid of old border} {
+test config-4.37 {DoObjConfig - getting rid of old border} testobjconfig {
catch {destroy .foo}
testobjconfig alltypes .foo -border #333333
list [catch {.foo configure -border #444444} msg] $msg [catch {.foo cget -border} result] $result [destroy .foo]
} {0 256 0 #444444 {}}
-test config-4.38 {DoObjConfig - relief} {
+test config-4.38 {DoObjConfig - relief} testobjconfig {
catch {destroy .foo}
list [catch {testobjconfig alltypes .foo -relief flat} msg] $msg [catch {.foo cget -relief} result] $result [destroy .foo]
} {0 .foo 0 flat {}}
-test config-4.39 {DoObjConfig - invalid relief} {
+test config-4.39 {DoObjConfig - invalid relief} testobjconfig {
catch {destroy .foo}
list [catch {testobjconfig alltypes .foo -relief foo} msg] $msg
} {1 {bad relief "foo": must be flat, groove, raised, ridge, solid, or sunken}}
-test config-4.40 {DoObjConfig - new relief} {
+test config-4.40 {DoObjConfig - new relief} testobjconfig {
catch {destroy .foo}
testobjconfig alltypes .foo -relief raised
list [catch {.foo configure -relief flat} msg] $msg [catch {.foo cget -relief} result] $result [destroy .foo]
} {0 512 0 flat {}}
-test config-4.41 {DoObjConfig - relief internal value} {
+test config-4.41 {DoObjConfig - relief internal value} testobjconfig {
catch {rename .foo {}}
testobjconfig internal .foo -relief ridge
.foo cget -relief
} {ridge}
-test config-4.42 {DoObjConfig - cursor} {
+test config-4.42 {DoObjConfig - cursor} testobjconfig {
catch {destroy .foo}
list [catch {testobjconfig alltypes .foo -cursor arrow} msg] $msg [catch {.foo cget -cursor} result] $result [destroy .foo]
} {0 .foo 0 arrow {}}
-test config-4.43 {DoObjConfig - invalid cursor} {
+test config-4.43 {DoObjConfig - invalid cursor} testobjconfig {
catch {destroy .foo}
list [catch {testobjconfig alltypes .foo -cursor foo} msg] $msg
} {1 {bad cursor spec "foo"}}
-test config-4.44 {DoObjConfig - null cursor} {
+test config-4.44 {DoObjConfig - null cursor} testobjconfig {
catch {destroy .foo}
list [catch {testobjconfig alltypes .foo -cursor {}} msg] $msg [catch {.foo cget -cursor} result] $result [destroy .foo]
} {0 .foo 0 {} {}}
-test config-4.45 {DoObjConfig - new cursor} {
+test config-4.45 {DoObjConfig - new cursor} testobjconfig {
catch {destroy .foo}
testobjconfig alltypes .foo -cursor xterm
list [catch {.foo configure -cursor arrow} msg] $msg [catch {.foo cget -cursor} result] $result [destroy .foo]
} {0 1024 0 arrow {}}
-test config-4.46 {DoObjConfig - cursor internal value} {
+test config-4.46 {DoObjConfig - cursor internal value} testobjconfig {
catch {rename .foo {}}
testobjconfig internal .foo -cursor watch
.foo cget -cursor
} {watch}
-test config-4.47 {DoObjConfig - justify} {
+test config-4.47 {DoObjConfig - justify} testobjconfig {
catch {destroy .foo}
list [catch {testobjconfig alltypes .foo -justify center} msg] $msg [catch {.foo cget -justify} result] $result [destroy .foo]
} {0 .foo 0 center {}}
-test config-4.48 {DoObjConfig - invalid justify} {
+test config-4.48 {DoObjConfig - invalid justify} testobjconfig {
catch {destroy .foo}
list [catch {testobjconfig alltypes .foo -justify foo} msg] $msg
} {1 {bad justification "foo": must be left, right, or center}}
-test config-4.49 {DoObjConfig - new justify} {
+test config-4.49 {DoObjConfig - new justify} testobjconfig {
catch {destroy .foo}
testobjconfig alltypes .foo -justify left
list [catch {.foo configure -justify right} msg] $msg [catch {.foo cget -justify} result] $result [destroy .foo]
} {0 2048 0 right {}}
-test config-4.50 {DoObjConfig - justify internal value} {
+test config-4.50 {DoObjConfig - justify internal value} testobjconfig {
catch {rename .foo {}}
testobjconfig internal .foo -justify center
.foo cget -justify
} {center}
-test config-4.51 {DoObjConfig - anchor} {
+test config-4.51 {DoObjConfig - anchor} testobjconfig {
catch {destroy .foo}
list [catch {testobjconfig alltypes .foo -anchor center} msg] $msg [catch {.foo cget -anchor} result] $result [destroy .foo]
} {0 .foo 0 center {}}
-test config-4.52 {DoObjConfig - invalid anchor} {
+test config-4.52 {DoObjConfig - invalid anchor} testobjconfig {
catch {destroy .foo}
list [catch {testobjconfig alltypes .foo -anchor foo} msg] $msg
} {1 {bad anchor "foo": must be n, ne, e, se, s, sw, w, nw, or center}}
-test config-4.53 {DoObjConfig - new anchor} {
+test config-4.53 {DoObjConfig - new anchor} testobjconfig {
catch {destroy .foo}
testobjconfig alltypes .foo -anchor e
list [catch {.foo configure -anchor n} msg] $msg [catch {.foo cget -anchor} result] $result [destroy .foo]
} {0 4096 0 n {}}
-test config-4.54 {DoObjConfig - anchor internal value} {
+test config-4.54 {DoObjConfig - anchor internal value} testobjconfig {
catch {rename .foo {}}
testobjconfig internal .foo -anchor sw
.foo cget -anchor
} {sw}
-test config-4.55 {DoObjConfig - pixel} {
+test config-4.55 {DoObjConfig - pixel} testobjconfig {
catch {destroy .foo}
list [catch {testobjconfig alltypes .foo -pixel 42} msg] $msg [catch {.foo cget -pixel} result] $result [destroy .foo]
} {0 .foo 0 42 {}}
-test config-4.56 {DoObjConfig - invalid pixel} {
+test config-4.56 {DoObjConfig - invalid pixel} testobjconfig {
catch {destroy .foo}
list [catch {testobjconfig alltypes .foo -pixel foo} msg] $msg
} {1 {bad screen distance "foo"}}
-test config-4.57 {DoObjConfig - new pixel} {
+test config-4.57 {DoObjConfig - new pixel} testobjconfig {
catch {destroy .foo}
testobjconfig alltypes .foo -pixel 42m
list [catch {.foo configure -pixel 3c} msg] $msg [catch {.foo cget -pixel} result] $result [destroy .foo]
} {0 8192 0 3c {}}
-test config-4.58 {DoObjConfig - pixel internal value} {
+test config-4.58 {DoObjConfig - pixel internal value} testobjconfig {
catch {rename .foo {}}
testobjconfig internal .foo -pixel [winfo screenmmwidth .]m
.foo cget -pixel
} [winfo screenwidth .]
-test config-4.59 {DoObjConfig - window} {
+test config-4.59 {DoObjConfig - window} testobjconfig {
catch {destroy .foo}
catch {destroy .bar}
toplevel .bar
list [catch {testobjconfig twowindows .foo -window .bar} msg] $msg [catch {.foo cget -window} result] $result [destroy .foo] [destroy .bar]
} {0 .foo 0 .bar {} {}}
-test config-4.60 {DoObjConfig - invalid window} {
+test config-4.60 {DoObjConfig - invalid window} testobjconfig {
catch {destroy .foo}
toplevel .bar
list [catch {testobjconfig twowindows .foo -window foo} msg] $msg [destroy .bar]
} {1 {bad window path name "foo"} {}}
-test config-4.61 {DoObjConfig - null window} {
+test config-4.61 {DoObjConfig - null window} testobjconfig {
catch {destroy .foo}
catch {destroy .bar}
toplevel .bar
list [catch {testobjconfig twowindows .foo -window {}} msg] $msg [catch {.foo cget -window} result] $result [destroy .foo]
} {0 .foo 0 {} {}}
-test config-4.62 {DoObjConfig - new window} {
+test config-4.62 {DoObjConfig - new window} testobjconfig {
catch {destroy .foo}
catch {destroy .bar}
catch {destroy .blamph}
@@ -446,12 +440,12 @@ test config-4.62 {DoObjConfig - new window} {
testobjconfig twowindows .foo -window .bar
list [catch {.foo configure -window .blamph} msg] $msg [catch {.foo cget -window} result] $result [destroy .foo] [destroy .bar] [destroy .blamph]
} {0 0 0 .blamph {} {} {}}
-test config-4.63 {DoObjConfig - window internal value} {
+test config-4.63 {DoObjConfig - window internal value} testobjconfig {
catch {rename .foo {}}
testobjconfig internal .foo -window .
.foo cget -window
} {.}
-test config-4.64 {DoObjConfig - releasing old values} {
+test config-4.64 {DoObjConfig - releasing old values} testobjconfig {
# This test doesn't generate a useful value to check; if an
# error occurs, it will be detected only by memory checking software
# such as Purify or Tcl's built-in checker.
@@ -465,7 +459,7 @@ test config-4.64 {DoObjConfig - releasing old values} {
-custom barbaz
concat {}
} {}
-test config-4.65 {DoObjConfig - releasing old values} {
+test config-4.65 {DoObjConfig - releasing old values} testobjconfig {
# This test doesn't generate a useful value to check; if an
# error occurs, it will be detected only by memory checking software
# such as Purify or Tcl's built-in checker.
@@ -479,188 +473,192 @@ test config-4.65 {DoObjConfig - releasing old values} {
-custom barbaz
concat {}
} {}
-test config-4.66 {DoObjConfig - custom} {
+test config-4.66 {DoObjConfig - custom} testobjconfig {
catch {destroy .foo}
list [catch {testobjconfig alltypes .foo -custom test} msg] $msg [catch {.foo cget -custom} result] $result [destroy .foo]
} {0 .foo 0 TEST {}}
-test config-4.67 {DoObjConfig - null custom} {
+test config-4.67 {DoObjConfig - null custom} testobjconfig {
catch {destroy .foo}
list [catch {testobjconfig alltypes .foo -custom {}} msg] $msg [catch {.foo cget -custom} result] $result [destroy .foo]
} {0 .foo 0 {} {}}
-test config-4.68 {DoObjConfig - custom internal value} {
+test config-4.68 {DoObjConfig - custom internal value} testobjconfig {
catch {rename .foo {}}
testobjconfig internal .foo -custom "this is a test"
.foo cget -custom
} {THIS IS A TEST}
-test config-5.1 {ObjectIsEmpty - object is already string} {
+test config-5.1 {ObjectIsEmpty - object is already string} testobjconfig {
catch {destroy .foo}
testobjconfig alltypes .foo -color [format ""]
.foo cget -color
} {}
-test config-5.2 {ObjectIsEmpty - object is already string} {
+test config-5.2 {ObjectIsEmpty - object is already string} testobjconfig {
catch {destroy .foo}
list [catch {testobjconfig alltypes .foo -color [format " "]} msg] $msg
} {1 {unknown color name " "}}
-test config-5.3 {ObjectIsEmpty - must convert back to string} {
+test config-5.3 {ObjectIsEmpty - must convert back to string} testobjconfig {
catch {destroy .foo}
testobjconfig alltypes .foo -color [list]
.foo cget -color
} {}
-eval destroy [winfo children .]
-testobjconfig chain2 .a
-testobjconfig alltypes .b
-test config-6.1 {GetOptionFromObj - cached answer} {
+deleteWindows
+if {[testConstraint testobjconfig]} {
+ testobjconfig chain2 .a
+ testobjconfig alltypes .b
+}
+test config-6.1 {GetOptionFromObj - cached answer} testobjconfig {
list [.a cget -three] [.a cget -three]
} {three three}
-test config-6.2 {GetOptionFromObj - exact match} {
+test config-6.2 {GetOptionFromObj - exact match} testobjconfig {
.a cget -one
} {one}
-test config-6.3 {GetOptionFromObj - abbreviation} {
+test config-6.3 {GetOptionFromObj - abbreviation} testobjconfig {
.a cget -fo
} {four}
-test config-6.4 {GetOptionFromObj - ambiguous abbreviation} {
+test config-6.4 {GetOptionFromObj - ambiguous abbreviation} testobjconfig {
list [catch {.a cget -on} msg] $msg
} {1 {unknown option "-on"}}
-test config-6.5 {GetOptionFromObj - duplicate options in different tables} {
+test config-6.5 {GetOptionFromObj - duplicate options in different tables} testobjconfig {
.a cget -tw
} {two and a half}
-test config-6.6 {GetOptionFromObj - synonym} {
+test config-6.6 {GetOptionFromObj - synonym} testobjconfig {
.b cget -synonym
} {red}
-eval destroy [winfo children .]
-testobjconfig alltypes .a
-test config-7.1 {Tk_SetOptions - basics} {
+deleteWindows
+if {[testConstraint testobjconfig]} {
+ testobjconfig alltypes .a
+}
+test config-7.1 {Tk_SetOptions - basics} testobjconfig {
.a configure -color green -rel sunken
list [.a cget -color] [.a cget -relief]
} {green sunken}
-test config-7.2 {Tk_SetOptions - bogus option name} {
+test config-7.2 {Tk_SetOptions - bogus option name} testobjconfig {
list [catch {.a configure -bogus} msg] $msg
} {1 {unknown option "-bogus"}}
-test config-7.3 {Tk_SetOptions - synonym} {
+test config-7.3 {Tk_SetOptions - synonym} testobjconfig {
.a configure -synonym blue
.a cget -color
} {blue}
-test config-7.4 {Tk_SetOptions - missing value} {
+test config-7.4 {Tk_SetOptions - missing value} testobjconfig {
list [catch {.a configure -color green -relief} msg] $msg [.a cget -color]
} {1 {value for "-relief" missing} green}
-test config-7.5 {Tk_SetOptions - saving old values} {
+test config-7.5 {Tk_SetOptions - saving old values} testobjconfig {
.a configure -color red -int 7 -relief raised -double 3.14159
list [catch {.a csave -color green -int 432 -relief sunken \
-double 2.0 -color bogus} msg] $msg [.a cget -color] \
[.a cget -int] [.a cget -relief] [.a cget -double]
} {1 {unknown color name "bogus"} red 7 raised 3.14159}
-test config-7.6 {Tk_SetOptions - error in DoObjConfig call} {
+test config-7.6 {Tk_SetOptions - error in DoObjConfig call} testobjconfig {
list [catch {.a configure -color bogus} msg] $msg $errorInfo
} {1 {unknown color name "bogus"} {unknown color name "bogus"
(processing "-color" option)
invoked from within
".a configure -color bogus"}}
-test config-7.7 {Tk_SetOptions - synonym name in error message} {
+test config-7.7 {Tk_SetOptions - synonym name in error message} testobjconfig {
list [catch {.a configure -synonym bogus} msg] $msg $errorInfo
} {1 {unknown color name "bogus"} {unknown color name "bogus"
(processing "-synonym" option)
invoked from within
".a configure -synonym bogus"}}
-test config-7.8 {Tk_SetOptions - returning mask} {
+test config-7.8 {Tk_SetOptions - returning mask} testobjconfig {
format %x [.a configure -color red -int 7 -relief raised -double 3.14159]
} {226}
-test config-7.9 {Tk_SetOptions - error in DoObjConfig with custom option} {
+test config-7.9 {Tk_SetOptions - error in DoObjConfig with custom option} testobjconfig {
list [catch {.a configure -custom bad} msg] $msg $errorInfo
} {1 {expected good value, got "BAD"} {expected good value, got "BAD"
(processing "-custom" option)
invoked from within
".a configure -custom bad"}}
-test config-8.1 {Tk_RestoreSavedOptions - restore in proper order} {
- eval destroy [winfo children .]
+test config-8.1 {Tk_RestoreSavedOptions - restore in proper order} testobjconfig {
+ deleteWindows
testobjconfig alltypes .a
list [catch {.a csave -color green -color black -color blue \
-color #ffff00 -color #ff00ff -color bogus} msg] $msg \
[.a cget -color]
} {1 {unknown color name "bogus"} red}
-test config-8.2 {Tk_RestoreSavedOptions - freeing object memory} {
- eval destroy [winfo children .]
+test config-8.2 {Tk_RestoreSavedOptions - freeing object memory} testobjconfig {
+ deleteWindows
testobjconfig alltypes .a
.a csave -color green -color black -color blue -color #ffff00 \
-color #ff00ff
} {32}
-test config-8.3 {Tk_RestoreSavedOptions - boolean internal form} {
- eval destroy [winfo children .]
+test config-8.3 {Tk_RestoreSavedOptions - boolean internal form} testobjconfig {
+ deleteWindows
testobjconfig internal .a
list [catch {.a csave -boolean 0 -color bogus}] [.a cget -boolean]
} {1 1}
-test config-8.4 {Tk_RestoreSavedOptions - integer internal form} {
- eval destroy [winfo children .]
+test config-8.4 {Tk_RestoreSavedOptions - integer internal form} testobjconfig {
+ deleteWindows
testobjconfig internal .a
list [catch {.a csave -integer 24 -color bogus}] [.a cget -integer]
} {1 148962237}
-test config-8.5 {Tk_RestoreSavedOptions - double internal form} {
- eval destroy [winfo children .]
+test config-8.5 {Tk_RestoreSavedOptions - double internal form} testobjconfig {
+ deleteWindows
testobjconfig internal .a
list [catch {.a csave -double 62.4 -color bogus}] [.a cget -double]
} {1 3.14159}
-test config-8.6 {Tk_RestoreSavedOptions - string internal form} {
- eval destroy [winfo children .]
+test config-8.6 {Tk_RestoreSavedOptions - string internal form} testobjconfig {
+ deleteWindows
testobjconfig internal .a
list [catch {.a csave -string "A long string" -color bogus}] \
[.a cget -string]
} {1 foo}
-test config-8.7 {Tk_RestoreSavedOptions - string table internal form} {
- eval destroy [winfo children .]
+test config-8.7 {Tk_RestoreSavedOptions - string table internal form} testobjconfig {
+ deleteWindows
testobjconfig internal .a
list [catch {.a csave -stringtable three -color bogus}] \
[.a cget -stringtable]
} {1 one}
-test config-8.8 {Tk_RestoreSavedOptions - color internal form} {
- eval destroy [winfo children .]
+test config-8.8 {Tk_RestoreSavedOptions - color internal form} testobjconfig {
+ deleteWindows
testobjconfig internal .a
list [catch {.a csave -color green -color bogus}] [.a cget -color]
} {1 red}
-test config-8.9 {Tk_RestoreSavedOptions - font internal form} {nonPortable} {
- eval destroy [winfo children .]
+test config-8.9 {Tk_RestoreSavedOptions - font internal form} {testobjconfig nonPortable} {
+ deleteWindows
testobjconfig internal .a
list [catch {.a csave -font {Times 12} -color bogus}] [.a cget -font]
} {1 {Helvetica 12}}
-test config-8.10 {Tk_RestoreSavedOptions - bitmap internal form} {
- eval destroy [winfo children .]
+test config-8.10 {Tk_RestoreSavedOptions - bitmap internal form} testobjconfig {
+ deleteWindows
testobjconfig internal .a
list [catch {.a csave -bitmap questhead -color bogus}] [.a cget -bitmap]
} {1 gray50}
-test config-8.11 {Tk_RestoreSavedOptions - border internal form} {
- eval destroy [winfo children .]
+test config-8.11 {Tk_RestoreSavedOptions - border internal form} testobjconfig {
+ deleteWindows
testobjconfig internal .a
list [catch {.a csave -border brown -color bogus}] [.a cget -border]
} {1 blue}
-test config-8.12 {Tk_RestoreSavedOptions - relief internal form} {
- eval destroy [winfo children .]
+test config-8.12 {Tk_RestoreSavedOptions - relief internal form} testobjconfig {
+ deleteWindows
testobjconfig internal .a
list [catch {.a csave -relief sunken -color bogus}] [.a cget -relief]
} {1 raised}
-test config-8.13 {Tk_RestoreSavedOptions - cursor internal form} {
- eval destroy [winfo children .]
+test config-8.13 {Tk_RestoreSavedOptions - cursor internal form} testobjconfig {
+ deleteWindows
testobjconfig internal .a
list [catch {.a csave -cursor watch -color bogus}] [.a cget -cursor]
} {1 xterm}
-test config-8.14 {Tk_RestoreSavedOptions - justify internal form} {
- eval destroy [winfo children .]
+test config-8.14 {Tk_RestoreSavedOptions - justify internal form} testobjconfig {
+ deleteWindows
testobjconfig internal .a
list [catch {.a csave -justify right -color bogus}] [.a cget -justify]
} {1 left}
-test config-8.15 {Tk_RestoreSavedOptions - anchor internal form} {
- eval destroy [winfo children .]
+test config-8.15 {Tk_RestoreSavedOptions - anchor internal form} testobjconfig {
+ deleteWindows
testobjconfig internal .a
list [catch {.a csave -anchor center -color bogus}] [.a cget -anchor]
} {1 n}
-test config-8.16 {Tk_RestoreSavedOptions - window internal form} {
- eval destroy [winfo children .]
+test config-8.16 {Tk_RestoreSavedOptions - window internal form} testobjconfig {
+ deleteWindows
testobjconfig internal .a -window .a
list [catch {.a csave -window .a -color bogus}] [.a cget -window]
} {1 .a}
-test config-8.17 {Tk_RestoreSavedOptions - custom internal form} {
- eval destroy [winfo children .]
+test config-8.17 {Tk_RestoreSavedOptions - custom internal form} testobjconfig {
+ deleteWindows
testobjconfig internal .a -custom "foobar"
list [catch {.a csave -custom "barbaz" -color bogus}] [.a cget -custom]
} {1 FOOBAR}
@@ -669,187 +667,191 @@ test config-8.17 {Tk_RestoreSavedOptions - custom internal form} {
# problem. This may not be evident unless the tests are run in
# conjunction with a memory usage analyzer such as Purify.
-test config-9.1 {Tk_FreeConfigOptions/FreeResources - string internal form} {
+test config-9.1 {Tk_FreeConfigOptions/FreeResources - string internal form} testobjconfig {
catch {destroy .foo}
testobjconfig internal .foo
.foo configure -string "two words"
destroy .foo
} {}
-test config-9.2 {Tk_FreeConfigOptions/FreeResources - color internal form} {
+test config-9.2 {Tk_FreeConfigOptions/FreeResources - color internal form} testobjconfig {
catch {destroy .foo}
testobjconfig internal .foo
.foo configure -color yellow
destroy .foo
} {}
-test config-9.3 {Tk_FreeConfigOptions/FreeResources - color} {
+test config-9.3 {Tk_FreeConfigOptions/FreeResources - color} testobjconfig {
catch {destroy .foo}
testobjconfig alltypes .foo
.foo configure -color [format blue]
destroy .foo
} {}
-test config-9.4 {Tk_FreeConfigOptions/FreeResources - font internal form} {
+test config-9.4 {Tk_FreeConfigOptions/FreeResources - font internal form} testobjconfig {
catch {destroy .foo}
testobjconfig internal .foo
.foo configure -font {Courier 20}
destroy .foo
} {}
-test config-9.5 {Tk_FreeConfigOptions/FreeResources - font} {
+test config-9.5 {Tk_FreeConfigOptions/FreeResources - font} testobjconfig {
catch {destroy .foo}
testobjconfig alltypes .foo
.foo configure -font [format {Courier 24}]
destroy .foo
} {}
-test config-9.6 {Tk_FreeConfigOptions/FreeResources - bitmap internal form} {
+test config-9.6 {Tk_FreeConfigOptions/FreeResources - bitmap internal form} testobjconfig {
catch {destroy .foo}
testobjconfig internal .foo
.foo configure -bitmap gray75
destroy .foo
} {}
-test config-9.7 {Tk_FreeConfigOptions/FreeResources - bitmap} {
+test config-9.7 {Tk_FreeConfigOptions/FreeResources - bitmap} testobjconfig {
catch {destroy .foo}
testobjconfig alltypes .foo
.foo configure -bitmap [format gray75]
destroy .foo
} {}
-test config-9.8 {Tk_FreeConfigOptions/FreeResources - border internal form} {
+test config-9.8 {Tk_FreeConfigOptions/FreeResources - border internal form} testobjconfig {
catch {destroy .foo}
testobjconfig internal .foo
.foo configure -border orange
destroy .foo
} {}
-test config-9.9 {Tk_FreeConfigOptions/FreeResources - border} {
+test config-9.9 {Tk_FreeConfigOptions/FreeResources - border} testobjconfig {
catch {destroy .foo}
testobjconfig alltypes .foo
.foo configure -border [format blue]
destroy .foo
} {}
-test config-9.10 {Tk_FreeConfigOptions/FreeResources - cursor internal form} {
+test config-9.10 {Tk_FreeConfigOptions/FreeResources - cursor internal form} testobjconfig {
catch {destroy .foo}
testobjconfig internal .foo
.foo configure -cursor cross
destroy .foo
} {}
-test config-9.11 {Tk_FreeConfigOptions/FreeResources - cursor} {
+test config-9.11 {Tk_FreeConfigOptions/FreeResources - cursor} testobjconfig {
catch {destroy .foo}
testobjconfig alltypes .foo
.foo configure -cursor [format watch]
destroy .foo
} {}
-test config-9.12 {Tk_FreeConfigOptions/FreeResources - not special} {
+test config-9.12 {Tk_FreeConfigOptions/FreeResources - not special} testobjconfig {
catch {destroy .foo}
testobjconfig alltypes .foo
.foo configure -integer [format 27]
destroy .foo
} {}
-test config-9.13 {Tk_FreeConfigOptions/FreeResources - custom internal form} {
+test config-9.13 {Tk_FreeConfigOptions/FreeResources - custom internal form} testobjconfig {
catch {destroy .fpp}
testobjconfig internal .foo
.foo configure -custom "foobar"
destroy .foo
} {}
-test config-10.1 {Tk_GetOptionInfo - one item} {
+test config-10.1 {Tk_GetOptionInfo - one item} testobjconfig {
catch {destroy .foo}
testobjconfig alltypes .foo
.foo configure -relief groove
.foo configure -relief
} {-relief relief Relief raised groove}
-test config-10.2 {Tk_GetOptionInfo - one item, synonym} {
+test config-10.2 {Tk_GetOptionInfo - one item, synonym} testobjconfig {
catch {destroy .foo}
testobjconfig alltypes .foo
.foo configure -color black
.foo configure -synonym
} {-color color Color red black}
-test config-10.3 {Tk_GetOptionInfo - all items} {
+test config-10.3 {Tk_GetOptionInfo - all items} testobjconfig {
catch {destroy .foo}
testobjconfig alltypes .foo -font {Helvetica 18} -integer 13563
.foo configure
} {{-boolean boolean Boolean 1 1} {-integer integer Integer 7 13563} {-double double Double 3.14159 3.14159} {-string string String foo foo} {-stringtable StringTable stringTable one one} {-color color Color red red} {-font font Font {Helvetica 12} {Helvetica 18}} {-bitmap bitmap Bitmap gray50 gray50} {-border border Border blue blue} {-relief relief Relief raised raised} {-cursor cursor Cursor xterm xterm} {-justify {} {} left left} {-anchor anchor Anchor {} {}} {-pixel pixel Pixel 1 1} {-custom {} {} {} {}} {-synonym -color}}
-test config-10.4 {Tk_GetOptionInfo - chaining through tables} {
+test config-10.4 {Tk_GetOptionInfo - chaining through tables} testobjconfig {
catch {destroy .foo}
testobjconfig chain2 .foo -one asdf -three xyzzy
.foo configure
} {{-three three Three three xyzzy} {-four four Four four four} {-two two Two {two and a half} {two and a half}} {-oneAgain oneAgain OneAgain {one again} {one again}} {-one one One one asdf} {-two two Two two {two and a half}}}
-eval destroy [winfo children .]
-testobjconfig alltypes .a
-test config-11.1 {GetConfigList - synonym} {
+deleteWindows
+if {[testConstraint testobjconfig]} {
+ testobjconfig alltypes .a
+}
+test config-11.1 {GetConfigList - synonym} testobjconfig {
lindex [.a configure] end
} {-synonym -color}
-test config-11.2 {GetConfigList - null database names} {
+test config-11.2 {GetConfigList - null database names} testobjconfig {
.a configure -justify
} {-justify {} {} left left}
-test config-11.3 {GetConfigList - null default and current value} {
+test config-11.3 {GetConfigList - null default and current value} testobjconfig {
.a configure -anchor
} {-anchor anchor Anchor {} {}}
-eval destroy [winfo children .]
-testobjconfig internal .a
-test config-12.1 {GetObjectForOption - boolean} {
+deleteWindows
+if {[testConstraint testobjconfig]} {
+ testobjconfig internal .a
+}
+test config-12.1 {GetObjectForOption - boolean} testobjconfig {
.a configure -boolean 0
.a cget -boolean
} {0}
-test config-12.2 {GetObjectForOption - integer} {
+test config-12.2 {GetObjectForOption - integer} testobjconfig {
.a configure -integer 1247
.a cget -integer
} {1247}
-test config-12.3 {GetObjectForOption - double} {
+test config-12.3 {GetObjectForOption - double} testobjconfig {
.a configure -double -88.82
.a cget -double
} {-88.82}
-test config-12.4 {GetObjectForOption - string} {
+test config-12.4 {GetObjectForOption - string} testobjconfig {
.a configure -string "test value"
.a cget -string
} {test value}
-test config-12.5 {GetObjectForOption - stringTable} {
+test config-12.5 {GetObjectForOption - stringTable} testobjconfig {
.a configure -stringtable "two"
.a cget -stringtable
} {two}
-test config-12.6 {GetObjectForOption - color} {
+test config-12.6 {GetObjectForOption - color} testobjconfig {
.a configure -color "green"
.a cget -color
} {green}
-test config-12.7 {GetObjectForOption - font} {
+test config-12.7 {GetObjectForOption - font} testobjconfig {
.a configure -font {Times 36}
.a cget -font
} {Times 36}
-test config-12.8 {GetObjectForOption - bitmap} {
+test config-12.8 {GetObjectForOption - bitmap} testobjconfig {
.a configure -bitmap "questhead"
.a cget -bitmap
} {questhead}
-test config-12.9 {GetObjectForOption - border} {
+test config-12.9 {GetObjectForOption - border} testobjconfig {
.a configure -border #33217c
.a cget -border
} {#33217c}
-test config-12.10 {GetObjectForOption - relief} {
+test config-12.10 {GetObjectForOption - relief} testobjconfig {
.a configure -relief groove
.a cget -relief
} {groove}
-test config-12.11 {GetObjectForOption - cursor} {
+test config-12.11 {GetObjectForOption - cursor} testobjconfig {
.a configure -cursor watch
.a cget -cursor
} {watch}
-test config-12.12 {GetObjectForOption - justify} {
+test config-12.12 {GetObjectForOption - justify} testobjconfig {
.a configure -justify right
.a cget -justify
} {right}
-test config-12.13 {GetObjectForOption - anchor} {
+test config-12.13 {GetObjectForOption - anchor} testobjconfig {
.a configure -anchor e
.a cget -anchor
} {e}
-test config-12.14 {GetObjectForOption - pixels} {
+test config-12.14 {GetObjectForOption - pixels} testobjconfig {
.a configure -pixel 193.2
.a cget -pixel
} {193}
-test config-12.15 {GetObjectForOption - window} {
+test config-12.15 {GetObjectForOption - window} testobjconfig {
.a configure -window .a
.a cget -window
} {.a}
-test config-12.16 {GetObjectForOption -custom} {
+test config-12.16 {GetObjectForOption -custom} testobjconfig {
.a configure -custom foobar
.a cget -custom
} {FOOBAR}
-test config-12.17 {GetObjectForOption - null values} {
+test config-12.17 {GetObjectForOption - null values} testobjconfig {
.a configure -string {} -color {} -font {} -bitmap {} -border {} \
-cursor {} -window {} -custom {}
list [.a cget -string] [.a cget -color] [.a cget -font] \
@@ -868,7 +870,7 @@ test config-13.1 {proper cleanup of options with widget destroy} {
}
} {}
-eval destroy [winfo children .]
+deleteWindows
test config-14.1 {Tk_CreateOptionTable - use with namespace import} {
namespace export -clear *
@@ -887,7 +889,9 @@ test config-14.1 {Tk_CreateOptionTable - use with namespace import} {
} {}
# cleanup
-eval destroy [winfo children .]
-killTables
+deleteWindows
+if {[testConstraint testobjconfig]} {
+ killTables
+}
::tcltest::cleanupTests
return
diff --git a/tests/constraints.tcl b/tests/constraints.tcl
index 196c216..3c28b3a 100644
--- a/tests/constraints.tcl
+++ b/tests/constraints.tcl
@@ -1,15 +1,27 @@
+if {[namespace exists tk::test]} {
+ deleteWindows
+ wm geometry . {}
+ raise .
+ return
+}
+
package require Tcl 8.4
package require Tk 8.4
tk appname tktest
wm title . tktest
+# 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
+}
package require tcltest 2.1
namespace eval tk {
- if {[namespace exists test]} {
- namespace delete test
- }
namespace eval test {
namespace eval bg {
# Manage a background process.
@@ -96,6 +108,19 @@ namespace eval tk {
proc deleteWindows {} {
eval destroy [winfo children .]
}
+
+ namespace export fixfocus
+ 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
+ }
}
}
@@ -111,6 +136,7 @@ testConstraint noExceed [expr {![testConstraint unix]
testConstraint testImageType [expr {[lsearch [image types] test] >= 0}]
testConstraint testembed [llength [info commands testembed]]
testConstraint testwrapper [llength [info commands testwrapper]]
+testConstraint testfont [llength [info commands testfont]]
testConstraint fonts 1
destroy .e
entry .e -width 0 -font {Helvetica -12} -bd 1
@@ -129,6 +155,19 @@ destroy .t
if {![string match {{22 3 6 15} {31 18 [34] 15}} $x]} {
testConstraint fonts 0
}
+testConstraint pseudocolor8 [expr {([catch {
+ toplevel .t -visual {pseudocolor 8} -colormap new
+ }] == 0) && ([winfo depth .t] == 8)}]
+destroy .t
+setupbg
+set app [dobg {tk appname}]
+testConstraint secureserver 1
+if {[catch {send $app set a 0} msg] == 1} {
+ if {[string match "X server insecure *" $msg]} {
+ testConstraint secureserver 0
+ }
+}
+cleanupbg
eval tcltest::configure $argv
namespace import -force tcltest::test
diff --git a/tests/cursor.test b/tests/cursor.test
index 11e23aa..3753bab 100644
--- a/tests/cursor.test
+++ b/tests/cursor.test
@@ -6,17 +6,16 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: cursor.test,v 1.5 2002/06/13 15:31:39 dgp Exp $
+# RCS: @(#) $Id: cursor.test,v 1.6 2002/07/14 05:48:46 dgp Exp $
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-
-set ::tcltest::testConfig(testcursor) [llength [info commands testcursor]]
+package require tcltest 2.1
+namespace import -force tcltest::configure
+namespace import -force tcltest::testsDirectory
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
-eval destroy [winfo children .]
-wm geometry . {}
-raise .
+testConstraint testcursor [llength [info commands testcursor]]
test cursor-1.1 {Tk_AllocCursorFromObj - converting internal reps} {testcursor} {
set x watch
diff --git a/tests/dialog.test b/tests/dialog.test
index 2fa194b..a10eb44 100644
--- a/tests/dialog.test
+++ b/tests/dialog.test
@@ -1,18 +1,15 @@
# This file is a Tcl script to test out Tk's "tk_dialog" command.
# It is organized in the standard fashion for Tcl tests.
#
-# RCS: @(#) $Id: dialog.test,v 1.2 2001/08/22 17:29:23 hobbs Exp $
+# RCS: @(#) $Id: dialog.test,v 1.3 2002/07/14 05:48:46 dgp Exp $
#
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-
-# Some tests require user interaction on non-unix platform
-
-set ::tcltest::testConfig(nonUnixUserInteraction) \
- [expr {$::tcltest::testConfig(userInteraction) || \
- $::tcltest::testConfig(unixOnly)}]
+package require tcltest 2.1
+namespace import -force tcltest::configure
+namespace import -force tcltest::testsDirectory
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
test dialog-1.1 {tk_dialog command} {
list [catch {tk_dialog} msg] $msg
@@ -63,4 +60,5 @@ test dialog-2.2 {tk_dialog operation} {
set res
} {-1}
-
+tcltest::cleanupTests
+return
diff --git a/tests/embed.test b/tests/embed.test
index f19583a..92a21b5 100644
--- a/tests/embed.test
+++ b/tests/embed.test
@@ -4,17 +4,14 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: embed.test,v 1.1 2002/05/27 17:33:26 mdejong Exp $
+# RCS: @(#) $Id: embed.test,v 1.2 2002/07/14 05:48:46 dgp Exp $
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-
-proc deleteWindows {} {
- foreach i [winfo children .] {
- destroy $i
- }
-}
+package require tcltest 2.1
+namespace import -force tcltest::configure
+namespace import -force tcltest::testsDirectory
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
test embed-1.1 {TkpUseWindow procedure, bad window identifier} {
deleteWindows
@@ -49,3 +46,6 @@ test embed-1.5 {TkpUseWindow procedure, -container must be set} {
# FIXME: test cases common to unixEmbed.test and macEmbed.test should
# be moved here.
+
+tcltest::cleanupTests
+return
diff --git a/tests/entry.test b/tests/entry.test
index fd4d7e3..5c6265f 100644
--- a/tests/entry.test
+++ b/tests/entry.test
@@ -6,17 +6,14 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: entry.test,v 1.11 2001/04/03 04:40:50 hobbs Exp $
+# RCS: @(#) $Id: entry.test,v 1.12 2002/07/14 05:48:46 dgp Exp $
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-
-foreach i [winfo children .] {
- destroy $i
-}
-wm geometry . {}
-raise .
+package require tcltest 2.1
+namespace import -force tcltest::configure
+namespace import -force tcltest::testsDirectory
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
proc scroll args {
global scrollInfo
@@ -1140,7 +1137,7 @@ test entry-11.1 {EntryEventProc procedure} {
update
} {}
test entry-11.2 {EntryEventProc procedure} {
- eval destroy [winfo children .]
+ deleteWindows
entry .e1 -fg #112233
rename .e1 .e2
set x {}
@@ -1151,7 +1148,7 @@ test entry-11.2 {EntryEventProc procedure} {
} {.e1 #112233 {} {}}
test entry-12.1 {EntryCmdDeletedProc procedure} {
- eval destroy [winfo children .]
+ deleteWindows
button .e1 -text "xyz_123"
rename .e1 {}
list [info command .e*] [winfo children .]
@@ -1380,7 +1377,7 @@ test entry-17.4 {EntryUpdateScrollbar procedure} {
(horizontal scrolling command executed by .e)}}
set l [interp hidden]
-eval destroy [winfo children .]
+deleteWindows
test entry-18.1 {Entry widget vs hiding} {
destroy .e
diff --git a/tests/event.test b/tests/event.test
index 67c5afb..9637acd 100644
--- a/tests/event.test
+++ b/tests/event.test
@@ -6,24 +6,19 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: event.test,v 1.9 2002/02/15 05:48:08 mdejong Exp $
+# RCS: @(#) $Id: event.test,v 1.10 2002/07/14 05:48:46 dgp Exp $
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-
-foreach i [winfo children .] {
- destroy $i
-}
-wm geometry . {}
-raise .
+package require tcltest 2.1
+namespace import -force tcltest::configure
+namespace import -force tcltest::testsDirectory
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
# XXX This test file is woefully incomplete. Right now it only tests
# a few of the procedures in tkEvent.c. Please add more tests whenever
# possible.
-
-
# Setup table used to query key events.
proc _init_keypress_lookup { } {
diff --git a/tests/filebox.test b/tests/filebox.test
index c4485bf..6cd1937 100644
--- a/tests/filebox.test
+++ b/tests/filebox.test
@@ -6,20 +6,20 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: filebox.test,v 1.12 2002/02/25 15:26:20 dkf Exp $
+# RCS: @(#) $Id: filebox.test,v 1.13 2002/07/14 05:48:46 dgp Exp $
#
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-
-set tk_strictMotif_old $tk_strictMotif
+package require tcltest 2.1
+namespace import -force tcltest::configure
+namespace import -force tcltest::testsDirectory
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
-# Some tests require user interaction on non-unix platform
+namespace import -force tcltest::makeFile
+namespace import -force tcltest::removeFile
-set ::tcltest::testConfig(nonUnixUserInteraction) \
- [expr {$::tcltest::testConfig(userInteraction) || \
- $::tcltest::testConfig(unixOnly)}]
+set tk_strictMotif_old $tk_strictMotif
#----------------------------------------------------------------------
#
diff --git a/tests/focus.test b/tests/focus.test
index 2e95945..25cd932 100644
--- a/tests/focus.test
+++ b/tests/focus.test
@@ -6,15 +6,14 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: focus.test,v 1.7 2001/03/28 17:27:10 dgp Exp $
+# RCS: @(#) $Id: focus.test,v 1.8 2002/07/14 05:48:46 dgp Exp $
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-
-eval destroy [winfo children .]
-wm geometry . {}
-raise .
+package require tcltest 2.1
+namespace import -force tcltest::configure
+namespace import -force tcltest::testsDirectory
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
button .b -text .b -relief raised -bd 2
pack .b
@@ -59,8 +58,7 @@ proc focusClear {} {
}
focusSetup
-set ::tcltest::testConfig(altDisplay) [info exists env(TK_ALT_DISPLAY)]
-if {$::tcltest::testConfig(altDisplay)} {
+if {[testConstraint altDisplay]} {
focusSetupAlt
}
update
@@ -188,11 +186,6 @@ test focus-1.25 {Tk_FocusCmd procedure} {unixOnly} {
list [catch {focus -unknown} msg] $msg
} {1 {bad option "-unknown": must be -displayof, -force, or -lastfor}}
-# Some tests require the testwrapper command
-
-set ::tcltest::testConfig(testwrapper) \
- [expr {[info commands testwrapper] != {}}]
-
test focus-2.1 {TkFocusFilterEvent procedure} {unixOnly nonPortable testwrapper} {
focus -force .b
destroy .t
@@ -524,21 +517,9 @@ test focus-4.4 {TkFocusDeadWindow procedure} {unixOnly testwrapper} {
# I don't know how to test most of the remaining procedures of this file
# explicitly; they've already been exercised by the preceding tests.
-# If send is disabled because of inadequate security, don't run any
-# of these tests at all.
-
-setupbg
-set app [dobg {tk appname}]
-set ::tcltest::testConfig(secureServer) 1
-if {[catch {send $app set a 0} msg] == 1} {
- if [string match "X server insecure *" $msg] {
- set ::tcltest::testConfig(secureServer) 0
- }
-}
-cleanupbg
setupbg
test focus-5.1 {ChangeXFocus procedure, don't take focus unless have it} \
- {unixOnly testwrapper secureServer} {
+ {unixOnly testwrapper secureserver} {
focusSetup
focus -force .t
update
@@ -657,7 +638,7 @@ test focus-6.2 {miscellaneous - embedded application in different process} \
set result
} {{.t.f2.e1 {} {focus out .t.f2.e1 NotifyNonlinear} {focus out .t.f2 NotifyNonlinearVirtual} {focus in .t.f1 NotifyNonlinear} | {focus out .t.f1 NotifyNonlinear} {focus in .t.f2 NotifyNonlinearVirtual} {focus in .t.f2.e1 NotifyNonlinear}} {{focus in . NotifyVirtual} {focus in .e1 NotifyAncestor} | {focus out .e1 NotifyAncestor} {focus out . NotifyVirtual}}}
-eval destroy [winfo children .]
+deleteWindows
bind all <FocusIn> {}
bind all <FocusOut> {}
diff --git a/tests/focusTcl.test b/tests/focusTcl.test
index 0d223cf..decc824 100644
--- a/tests/focusTcl.test
+++ b/tests/focusTcl.test
@@ -7,15 +7,14 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: focusTcl.test,v 1.3 1999/04/16 01:51:37 stanton Exp $
+# RCS: @(#) $Id: focusTcl.test,v 1.4 2002/07/14 05:48:46 dgp Exp $
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-
-eval destroy [winfo children .]
-wm geometry . {}
-raise .
+package require tcltest 2.1
+namespace import -force tcltest::configure
+namespace import -force tcltest::testsDirectory
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
proc setup1 w {
if {$w == "."} {
@@ -30,7 +29,9 @@ proc setup1 w {
button $w.b.$i -text "Button $w.b.$i"
pack $w.b.$i -side left
}
- tkwait visibility $w.b.z
+ if {[winfo ismapped $w.b.z]} {
+ tkwait visibility $w.b.z
+ }
}
option add *takeFocus 1
@@ -74,7 +75,7 @@ test focusTcl-1.11 {tk_focusNext procedure, basic tree traversal} {
tk_focusNext .b.z
} {.}
test focusTcl-1.12 {tk_focusNext procedure, basic tree traversal} {
- eval destroy [winfo child .]
+ deleteWindows
setup1 .
update
. configure -takefocus 0
@@ -82,7 +83,7 @@ test focusTcl-1.12 {tk_focusNext procedure, basic tree traversal} {
} {.a}
. configure -takefocus 1
-eval destroy [winfo child .]
+deleteWindows
setup1 .
toplevel .t
wm geom .t +0+0
@@ -107,7 +108,7 @@ test focusTcl-2.5 {tk_focusNext procedure, toplevels} {
tk_focusNext .t.b.z
} {.t}
-eval destroy [winfo child .]
+deleteWindows
test focusTcl-3.1 {tk_focusPrev procedure, no children} {
tk_focusPrev .
} {.}
@@ -137,7 +138,7 @@ test focusTcl-3.9 {tk_focusPrev procedure, basic tree traversal} {
tk_focusPrev .a
} {.}
-eval destroy [winfo child .]
+deleteWindows
setup1 .
toplevel .t
wm geom .t +0+0
@@ -164,15 +165,15 @@ test focusTcl-4.5 {tk_focusPrev procedure, toplevels} {
tk_focusPrev .t.a
} {.t.b.z}
-eval destroy [winfo child .]
+deleteWindows
test focusTcl-5.1 {tkFocusOK procedure, -takefocus 0} {
- eval destroy [winfo child .]
+ deleteWindows
setup1 .
.b.x configure -takefocus 0
tk_focusNext .b
} {.b.y}
test focusTcl-5.2 {tkFocusOK procedure, -takefocus 1} {
- eval destroy [winfo child .]
+ deleteWindows
setup1 .
pack forget .b
update
@@ -190,7 +191,7 @@ test focusTcl-5.3 {tkFocusOK procedure, -takefocus procedure} {
}
return 0
}
- eval destroy [winfo child .]
+ deleteWindows
setup1 .
pack forget .b.y
update
@@ -201,14 +202,14 @@ test focusTcl-5.3 {tkFocusOK procedure, -takefocus procedure} {
list [tk_focusNext .a] [tk_focusNext .b.x]
} {.b.x .d}
test focusTcl-5.4 {tkFocusOK procedure, -takefocus ""} {
- eval destroy [winfo child .]
+ deleteWindows
setup1 .
.b.x configure -takefocus ""
update
tk_focusNext .b
} {.b.x}
test focusTcl-5.5 {tkFocusOK procedure, -takefocus "", not mapped} {
- eval destroy [winfo child .]
+ deleteWindows
setup1 .
.b.x configure -takefocus ""
pack unpack .b.x
@@ -216,7 +217,7 @@ test focusTcl-5.5 {tkFocusOK procedure, -takefocus "", not mapped} {
tk_focusNext .b
} {.b.y}
test focusTcl-5.6 {tkFocusOK procedure, -takefocus "", not mapped} {
- eval destroy [winfo child .]
+ deleteWindows
setup1 .
foreach w {.b.x .b.y .b.z} {
$w configure -takefocus ""
@@ -226,7 +227,7 @@ test focusTcl-5.6 {tkFocusOK procedure, -takefocus "", not mapped} {
tk_focusNext .b
} {.c}
test focusTcl-5.7 {tkFocusOK procedure, -takefocus "", not mapped} {
- eval destroy [winfo child .]
+ deleteWindows
setup1 .
.b.y configure -takefocus 1
pack unpack .b.y
@@ -235,7 +236,7 @@ test focusTcl-5.7 {tkFocusOK procedure, -takefocus "", not mapped} {
} {.b.z}
test focusTcl-5.8 {tkFocusOK procedure, -takefocus "", not mapped} {
proc always args {return 1}
- eval destroy [winfo child .]
+ deleteWindows
setup1 .
.b.y configure -takefocus always
pack unpack .b.y
@@ -243,7 +244,7 @@ test focusTcl-5.8 {tkFocusOK procedure, -takefocus "", not mapped} {
tk_focusNext .b.x
} {.b.y}
test focusTcl-5.9 {tkFocusOK procedure, -takefocus "", window disabled} {
- eval destroy [winfo child .]
+ deleteWindows
setup1 .
foreach w {.b.x .b.y .b.z} {
$w configure -takefocus ""
@@ -253,7 +254,7 @@ test focusTcl-5.9 {tkFocusOK procedure, -takefocus "", window disabled} {
tk_focusNext .b
} {.b.y}
test focusTcl-5.10 {tkFocusOK procedure, -takefocus "", check for bindings} {
- eval destroy [winfo child .]
+ deleteWindows
setup1 .
foreach w {.a .b .c .d} {
$w configure -takefocus ""
@@ -263,7 +264,7 @@ test focusTcl-5.10 {tkFocusOK procedure, -takefocus "", check for bindings} {
list [tk_focusNext .] [tk_focusNext .a]
} {.a .b.x}
test focusTcl-5.11 {tkFocusOK procedure, -takefocus "", check for bindings} {
- eval destroy [winfo child .]
+ deleteWindows
setup1 .
foreach w {.a .b .c .d} {
$w configure -takefocus ""
diff --git a/tests/font.test b/tests/font.test
index 07ab5cb..f16d895 100644
--- a/tests/font.test
+++ b/tests/font.test
@@ -6,17 +6,14 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: font.test,v 1.7 2002/06/26 08:22:54 a_kovalenko Exp $
+# RCS: @(#) $Id: font.test,v 1.8 2002/07/14 05:48:46 dgp Exp $
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-
-if {[info commands testfont] != "testfont"} {
- puts "testfont command not available; skipping tests"
- ::tcltest::cleanupTests
- return
-}
+package require tcltest 2.1
+namespace import -force tcltest::configure
+namespace import -force tcltest::testsDirectory
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
catch {destroy .b}
toplevel .b
@@ -458,7 +455,7 @@ test font-13.4 {CreateNamedFont: recreate "deleted" font} {
test font-14.1 {Tk_GetFont procedure} {
} {}
-test font-15.1 {Tk_AllocFontFromObj - converting internal reps} {
+test font-15.1 {Tk_AllocFontFromObj - converting internal reps} testfont {
set x {Times 16}
lindex $x 0
destroy .b1 .b2
@@ -466,7 +463,7 @@ test font-15.1 {Tk_AllocFontFromObj - converting internal reps} {
lindex $x 0
testfont counts {Times 16}
} {{1 0}}
-test font-15.2 {Tk_AllocFontFromObj - discard stale font} {
+test font-15.2 {Tk_AllocFontFromObj - discard stale font} testfont {
set x {Times 16}
destroy .b1 .b2
button .b1 -font $x
@@ -476,7 +473,7 @@ test font-15.2 {Tk_AllocFontFromObj - discard stale font} {
button .b2 -font $x
lappend result [testfont counts {Times 16}]
} {{} {{1 1}}}
-test font-15.3 {Tk_AllocFontFromObj - reuse existing font} {
+test font-15.3 {Tk_AllocFontFromObj - reuse existing font} testfont {
set x {Times 16}
destroy .b1 .b2
button .b1 -font $x
@@ -551,7 +548,7 @@ test font-16.1 {Tk_NameOfFont procedure} {
.b.f cget -font
} {-family fixed}
-test font-17.1 {Tk_FreeFontFromObj - reference counts} {
+test font-17.1 {Tk_FreeFontFromObj - reference counts} testfont {
set x {Courier 12}
destroy .b1 .b2 .b3
button .b1 -font $x
@@ -611,7 +608,7 @@ test font-17.6 {Tk_FreeFont procedure: named font not deleted yet} {
list [lindex [font actual xyz] 0] [lindex $x 0]
} {-family -family}
-test font-18.1 {FreeFontObjProc} {
+test font-18.1 {FreeFontObjProc} testfont {
destroy .b1
set x [format {Courier 12}]
button .b1 -font $x
diff --git a/tests/frame.test b/tests/frame.test
index 7e7746c..4acd84b 100644
--- a/tests/frame.test
+++ b/tests/frame.test
@@ -7,17 +7,14 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: frame.test,v 1.6 2001/09/26 21:36:19 pspjuth Exp $
+# RCS: @(#) $Id: frame.test,v 1.7 2002/07/14 05:48:46 dgp Exp $
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-
-foreach i [winfo children .] {
- catch {destroy $i}
-}
-wm geometry . {}
-raise .
+package require tcltest 2.1
+namespace import -force tcltest::configure
+namespace import -force tcltest::testsDirectory
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
# eatColors --
# Creates a toplevel window and allocates enough colors in it to
@@ -532,7 +529,7 @@ test frame-7.1 {FrameEventProc procedure} {
lappend result [info commands .frame2]
} {.frame2 {}}
test frame-7.2 {FrameEventProc procedure} {
- eval destroy [winfo children .]
+ deleteWindows
frame .f1 -bg #543210
rename .f1 .f2
set x {}
@@ -543,13 +540,13 @@ test frame-7.2 {FrameEventProc procedure} {
} {.f1 #543210 {} {}}
test frame-8.1 {FrameCmdDeletedProc procedure} {
- eval destroy [winfo children .]
+ deleteWindows
frame .f1
rename .f1 {}
list [info command .f*] [winfo children .]
} {{} {}}
test frame-8.2 {FrameCmdDeletedProc procedure} {
- eval destroy [winfo children .]
+ deleteWindows
toplevel .f1 -menu .m
wm geometry .f1 +0+0
update
@@ -604,7 +601,7 @@ test frame-9.3 {MapFrame procedure, window deleted while mapping} {
} {0}
set l [interp hidden]
-eval destroy [winfo children .]
+deleteWindows
test frame-10.1 {frame widget vs hidden commands} {
catch {destroy .t}
diff --git a/tests/imgPhoto.test b/tests/imgPhoto.test
index f1101e6..63e697a 100644
--- a/tests/imgPhoto.test
+++ b/tests/imgPhoto.test
@@ -9,7 +9,7 @@
#
# Author: Paul Mackerras (paulus@cs.anu.edu.au)
#
-# RCS: @(#) $Id: imgPhoto.test,v 1.12 2002/07/13 21:52:34 dgp Exp $
+# RCS: @(#) $Id: imgPhoto.test,v 1.13 2002/07/14 05:48:46 dgp Exp $
package require tcltest 2.1
namespace import -force tcltest::configure
@@ -53,7 +53,7 @@ test imgPhoto-1.2 {options for photo images} {
list [catch {image create photo p1 -file no.such.file} err] \
[string tolower $err]
} {1 {couldn't open "no.such.file": no such file or directory}}
-test imgPhoto-1.3 {options for photo images} hasTeapotPhoto hasTeapotPhoto {
+test imgPhoto-1.3 {options for photo images} hasTeapotPhoto {
list [catch {image create photo p1 -file $teapotPhotoFile \
-format no.such.format} err] $err
} {1 {image file format "no.such.format" is not supported}}
diff --git a/tests/listbox.test b/tests/listbox.test
index 3c8069d..5e69d64 100644
--- a/tests/listbox.test
+++ b/tests/listbox.test
@@ -6,7 +6,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: listbox.test,v 1.19 2002/07/13 21:52:34 dgp Exp $
+# RCS: @(#) $Id: listbox.test,v 1.20 2002/07/14 05:48:46 dgp Exp $
package require tcltest 2.1
namespace import -force tcltest::configure
@@ -1295,7 +1295,7 @@ test listbox-8.2 {ListboxEventProc procedure} {fonts} {
list [.l xview] [.l yview]
} {{0 0.222222} {0 0.333333}}
test listbox-8.3 {ListboxEventProc procedure} {
- eval destroy [winfo children .]
+ deleteWindows
listbox .l1 -bg #543210
rename .l1 .l2
set x {}
@@ -1306,7 +1306,7 @@ test listbox-8.3 {ListboxEventProc procedure} {
} {.l1 #543210 {} {}}
test listbox-9.1 {ListboxCmdDeletedProc procedure} {
- eval destroy [winfo children .]
+ deleteWindows
listbox .l1
rename .l1 {}
list [info command .l*] [winfo children .]
@@ -1749,7 +1749,7 @@ test listbox-19.2 {ListboxUpdateVScrollbar procedure} {
(horizontal scrolling command executed by listbox)}}
set l [interp hidden]
-eval destroy [winfo children .]
+deleteWindows
test listbox-20.1 {listbox vs hidden commands} {
catch {destroy .l}
@@ -2133,7 +2133,7 @@ test listbox-28.3 {listbox -activestyle} {
} dotbox
resetGridInfo
-eval destroy [winfo children .]
+deleteWindows
option clear
# cleanup
diff --git a/tests/macEmbed.test b/tests/macEmbed.test
index e5a7bab..fe68f21 100644
--- a/tests/macEmbed.test
+++ b/tests/macEmbed.test
@@ -6,7 +6,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: macEmbed.test,v 1.7 2002/07/13 21:52:34 dgp Exp $
+# RCS: @(#) $Id: macEmbed.test,v 1.8 2002/07/14 05:48:46 dgp Exp $
package require tcltest 2.1
namespace import -force tcltest::configure
@@ -33,7 +33,7 @@ test macEmbed-1.3 {TkpUseWindow procedure, creating Container records} {testembe
toplevel .t -use $w
list [testembed] [expr [lindex [lindex [testembed all] 1] 0] - $w]
} {{{XXX .f2 {} {}} {XXX .f1 XXX .t}} 0}
-test macEmbed-1.4 {TkpUseWindow procedure, creating Container records} {testembed macOnly} testembed {
+test macEmbed-1.4 {TkpUseWindow procedure, creating Container records} {testembed macOnly} {
deleteWindows
frame .f1 -container 1 -width 200 -height 50
frame .f2 -container 1 -width 200 -height 50
diff --git a/tests/macFont.test b/tests/macFont.test
index f4e3083..0ba293e 100644
--- a/tests/macFont.test
+++ b/tests/macFont.test
@@ -10,7 +10,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: macFont.test,v 1.5 2002/07/13 20:28:35 dgp Exp $
+# RCS: @(#) $Id: macFont.test,v 1.6 2002/07/14 05:48:46 dgp Exp $
package require tcltest 2.1
namespace import -force tcltest::configure
@@ -128,7 +128,7 @@ test macFont-5.1 {TkpGetFontFamilies} {macOnly} {
expr {[lsearch [font families] Geneva] > 0}
} {1}
-test macFont-6.1 {TkpGetSubFonts} {gothic macOnly} {
+test macFont-6.1 {TkpGetSubFonts} {testfont gothic macOnly} {
.b.l config -text "abc\u4e4e"
update
set x [testfont subfonts $fixed]
diff --git a/tests/menu.test b/tests/menu.test
index 5c157f3..a9652bf 100644
--- a/tests/menu.test
+++ b/tests/menu.test
@@ -5,7 +5,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: menu.test,v 1.12 2002/07/13 20:28:35 dgp Exp $
+# RCS: @(#) $Id: menu.test,v 1.13 2002/07/14 05:48:46 dgp Exp $
package require tcltest 2.1
namespace import -force tcltest::configure
@@ -2461,7 +2461,7 @@ test menu-32.9 {Ensure deleting of clones doesn't corrupt menu refs} {
} {.menubar.cascade .#menubar.#menubar#test.#menubar#cascade .menubar.cascade .#menubar.#menubar#test.#menubar#cascade}
set l [interp hidden]
-eval destroy [winfo children .]
+deleteWindows
test menu-33.1 {menu vs command hiding} {
catch {destroy .m}
diff --git a/tests/send.test b/tests/send.test
index c69815f..a40eb98 100644
--- a/tests/send.test
+++ b/tests/send.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: send.test,v 1.7 2002/07/13 20:28:35 dgp Exp $
+# RCS: @(#) $Id: send.test,v 1.8 2002/07/14 05:48:46 dgp Exp $
package require tcltest 2.1
namespace import -force tcltest::configure
@@ -22,19 +22,6 @@ tcltest::loadTestedCommands
testConstraint xhost [llength [auto_execok xhost]]
testConstraint testsend [llength [info commands testsend]]
-# If send is disabled because of inadequate security, don't run any
-# of these tests at all.
-
-setupbg
-set app [dobg {tk appname}]
-testConstraint send 1
-if {[catch {send $app set a 0} msg] == 1} {
- if {[string match "X server insecure *" $msg]} {
- testConstraint send 0
- }
-}
-cleanupbg
-
# Compute a script that will load Tk into a child interpreter.
foreach pkg [info loaded] {
@@ -63,19 +50,19 @@ tk appname tktest
catch {send t_s_1 destroy .}
catch {send t_s_2 destroy .}
-test send-1.1 {RegOpen procedure, bogus property} {send testsend} {
+test send-1.1 {RegOpen procedure, bogus property} {secureserver testsend} {
testsend bogus
set result [winfo interps]
tk appname tktest
list $result [winfo interps]
} {{} tktest}
-test send-1.2 {RegOpen procedure, bogus property} {send testsend} {
+test send-1.2 {RegOpen procedure, bogus property} {secureserver testsend} {
testsend prop root InterpRegistry {}
set result [winfo interps]
tk appname tktest
list $result [winfo interps]
} {{} tktest}
-test send-1.3 {RegOpen procedure, bogus property} {send testsend} {
+test send-1.3 {RegOpen procedure, bogus property} {secureserver testsend} {
testsend prop root InterpRegistry abcdefg
tk appname tktest
set x [testsend prop root InterpRegistry]
@@ -84,52 +71,52 @@ test send-1.3 {RegOpen procedure, bogus property} {send testsend} {
frame .f -width 1 -height 1
set id [string range [winfo id .f] 2 end]
-test send-2.1 {RegFindName procedure} {send testsend} {
+test send-2.1 {RegFindName procedure} {secureserver testsend} {
testsend prop root InterpRegistry {}
list [catch {send foo bar} msg] $msg
} {1 {no application named "foo"}}
-test send-2.2 {RegFindName procedure} {send testsend} {
+test send-2.2 {RegFindName procedure} {secureserver testsend} {
testsend prop root InterpRegistry " abc\n def\nghi\n\n$id foo\n"
tk appname foo
} {foo #2}
-test send-2.3 {RegFindName procedure} {send testsend} {
+test send-2.3 {RegFindName procedure} {secureserver testsend} {
testsend prop root InterpRegistry "gyz foo\n"
tk appname foo
} {foo}
-test send-2.4 {RegFindName procedure} {send testsend} {
+test send-2.4 {RegFindName procedure} {secureserver testsend} {
testsend prop root InterpRegistry "${id}z foo\n"
tk appname foo
} {foo}
-test send-3.1 {RegDeleteName procedure} {send testsend} {
+test send-3.1 {RegDeleteName procedure} {secureserver testsend} {
tk appname tktest
testsend prop root InterpRegistry "012345 gorp\n12345 foo\n12345 tktest"
tk appname x
set x [testsend prop root InterpRegistry]
string range $x [string first " " $x] end
} " x\n012345 gorp\n12345 foo\n"
-test send-3.2 {RegDeleteName procedure} {send testsend} {
+test send-3.2 {RegDeleteName procedure} {secureserver testsend} {
tk appname tktest
testsend prop root InterpRegistry "012345 gorp\n12345 tktest\n23456 tktest"
tk appname x
set x [testsend prop root InterpRegistry]
string range $x [string first " " $x] end
} " x\n012345 gorp\n23456 tktest\n"
-test send-3.3 {RegDeleteName procedure} {send testsend} {
+test send-3.3 {RegDeleteName procedure} {secureserver testsend} {
tk appname tktest
testsend prop root InterpRegistry "012345 tktest\n12345 bar\n23456 tktest"
tk appname x
set x [testsend prop root InterpRegistry]
string range $x [string first " " $x] end
} " x\n12345 bar\n23456 tktest\n"
-test send-3.4 {RegDeleteName procedure} {send testsend} {
+test send-3.4 {RegDeleteName procedure} {secureserver testsend} {
tk appname tktest
testsend prop root InterpRegistry "foo"
tk appname x
set x [testsend prop root InterpRegistry]
string range $x [string first " " $x] end
} " x\nfoo\n"
-test send-3.5 {RegDeleteName procedure} {send testsend} {
+test send-3.5 {RegDeleteName procedure} {secureserver testsend} {
tk appname tktest
testsend prop root InterpRegistry ""
tk appname x
@@ -137,12 +124,12 @@ test send-3.5 {RegDeleteName procedure} {send testsend} {
string range $x [string first " " $x] end
} " x\n"
-test send-4.1 {RegAddName procedure} {send testsend} {
+test send-4.1 {RegAddName procedure} {secureserver testsend} {
testsend prop root InterpRegistry ""
tk appname bar
testsend prop root InterpRegistry
} "$commId bar\n"
-test send-4.2 {RegAddName procedure} {send testsend} {
+test send-4.2 {RegAddName procedure} {secureserver testsend} {
testsend prop root InterpRegistry "abc def"
tk appname bar
tk appname foo
@@ -151,19 +138,19 @@ test send-4.2 {RegAddName procedure} {send testsend} {
# Previous checks should already cover the Regclose procedure.
-test send-5.1 {ValidateName procedure} {send testsend} {
+test send-5.1 {ValidateName procedure} {secureserver testsend} {
testsend prop root InterpRegistry "123 abc\n"
winfo interps
} {}
-test send-5.2 {ValidateName procedure} {send testsend} {
+test send-5.2 {ValidateName procedure} {secureserver testsend} {
testsend prop root InterpRegistry "$id Hi there"
winfo interps
} {{Hi there}}
-test send-5.3 {ValidateName procedure} {send testsend} {
+test send-5.3 {ValidateName procedure} {secureserver testsend} {
testsend prop root InterpRegistry "$id Bogus"
list [catch {send Bogus set a 44} msg] $msg
} {1 {target application died or uses a Tk version before 4.0}}
-test send-5.4 {ValidateName procedure} {send testsend} {
+test send-5.4 {ValidateName procedure} {secureserver testsend} {
tk appname test
testsend prop root InterpRegistry "$commId Bogus\n$commId test\n"
winfo interps
@@ -180,43 +167,43 @@ if {[testConstraint xhost]} {
}
}
-test send-6.1 {ServerSecure procedure} {nonPortable send } {
+test send-6.1 {ServerSecure procedure} {nonPortable secureserver} {
set a 44
list [dobg [list send [tk appname] set a 55]] $a
} {55 55}
-test send-6.2 {ServerSecure procedure} {nonPortable send } {
+test send-6.2 {ServerSecure procedure} {nonPortable secureserver} {
set a 22
exec xhost [exec hostname]
list [catch {dobg [list send [tk appname] set a 33]} msg] $a $msg
} {0 22 {X server insecure (must use xauth-style authorization); command ignored}}
-test send-6.3 {ServerSecure procedure} {nonPortable send } {
+test send-6.3 {ServerSecure procedure} {nonPortable secureserver} {
set a abc
exec xhost - [exec hostname]
list [dobg [list send [tk appname] set a new]] $a
} {new new}
cleanupbg
-test send-7.1 {Tk_SetAppName procedure} {send testsend} {
+test send-7.1 {Tk_SetAppName procedure} {secureserver testsend} {
testsend prop root InterpRegistry ""
tk appname newName
list [tk appname oldName] [testsend prop root InterpRegistry]
} "oldName {$commId oldName\n}"
-test send-7.2 {Tk_SetAppName procedure, name not in use} {send testsend} {
+test send-7.2 {Tk_SetAppName procedure, name not in use} {secureserver testsend} {
testsend prop root InterpRegistry ""
list [tk appname gorp] [testsend prop root InterpRegistry]
} "gorp {$commId gorp\n}"
-test send-7.3 {Tk_SetAppName procedure, name in use by us} {send testsend} {
+test send-7.3 {Tk_SetAppName procedure, name in use by us} {secureserver testsend} {
tk appname name1
testsend prop root InterpRegistry "$commId name2\n"
list [tk appname name2] [testsend prop root InterpRegistry]
} "name2 {$commId name2\n}"
-test send-7.4 {Tk_SetAppName procedure, name in use} {send testsend} {
+test send-7.4 {Tk_SetAppName procedure, name in use} {secureserver testsend} {
tk appname name1
testsend prop root InterpRegistry "$id foo\n$id foo #2\n$id foo #3\n"
list [tk appname foo] [testsend prop root InterpRegistry]
} "{foo #4} {$commId foo #4\n$id foo\n$id foo #2\n$id foo #3\n}"
-test send-8.1 {Tk_SendCmd procedure, options} {send } {
+test send-8.1 {Tk_SendCmd procedure, options} {secureserver} {
setupbg
set app [dobg {tk appname}]
set a 66
@@ -227,7 +214,7 @@ test send-8.1 {Tk_SendCmd procedure, options} {send } {
cleanupbg
lappend result $a
} {66 77}
-test send-8.2 {Tk_SendCmd procedure, options} {send altDisplay} {
+test send-8.2 {Tk_SendCmd procedure, options} {secureserver altDisplay} {
setupbg -display $env(TK_ALT_DISPLAY)
tk appname xyzgorp
set a homeDisplay
@@ -241,29 +228,29 @@ test send-8.2 {Tk_SendCmd procedure, options} {send altDisplay} {
cleanupbg
set result
} {altDisplay homeDisplay}
-test send-8.3 {Tk_SendCmd procedure, options} {send } {
+test send-8.3 {Tk_SendCmd procedure, options} {secureserver} {
list [catch {send -- -async foo bar baz} msg] $msg
} {1 {no application named "-async"}}
-test send-8.4 {Tk_SendCmd procedure, options} {send } {
+test send-8.4 {Tk_SendCmd procedure, options} {secureserver} {
list [catch {send -gorp foo bar baz} msg] $msg
} {1 {bad option "-gorp": must be -async, -displayof, or --}}
-test send-8.5 {Tk_SendCmd procedure, options} {send } {
+test send-8.5 {Tk_SendCmd procedure, options} {secureserver} {
list [catch {send -async foo} msg] $msg
} {1 {wrong # args: should be "send ?options? interpName arg ?arg ...?"}}
-test send-8.6 {Tk_SendCmd procedure, options} {send } {
+test send-8.6 {Tk_SendCmd procedure, options} {secureserver} {
list [catch {send foo} msg] $msg
} {1 {wrong # args: should be "send ?options? interpName arg ?arg ...?"}}
-test send-8.7 {Tk_SendCmd procedure, local execution} {send } {
+test send-8.7 {Tk_SendCmd procedure, local execution} {secureserver} {
set a initial
send [tk appname] {set a new}
set a
} {new}
-test send-8.8 {Tk_SendCmd procedure, local execution} {send } {
+test send-8.8 {Tk_SendCmd procedure, local execution} {secureserver} {
set a initial
send [tk appname] set a new
set a
} {new}
-test send-8.9 {Tk_SendCmd procedure, local execution} {send } {
+test send-8.9 {Tk_SendCmd procedure, local execution} {secureserver} {
set a initial
string tolower [list [catch {send [tk appname] open bad_file} msg] \
$msg $errorInfo $errorCode]
@@ -272,7 +259,7 @@ test send-8.9 {Tk_SendCmd procedure, local execution} {send } {
"open bad_file"
invoked from within
"send [tk appname] open bad_file"} {posix enoent {no such file or directory}}}
-test send-8.10 {Tk_SendCmd procedure, no such interpreter} {send } {
+test send-8.10 {Tk_SendCmd procedure, no such interpreter} {secureserver} {
list [catch {send bogus_name bogus_command} msg] $msg
} {1 {no application named "bogus_name"}}
@@ -281,29 +268,29 @@ catch {
t_s_1 eval wm withdraw .
}
-test send-8.11 {Tk_SendCmd procedure, local execution, different interp} {send testsend} {
+test send-8.11 {Tk_SendCmd procedure, local execution, different interp} {secureserver testsend} {
set a us
send t_s_1 set a them
list $a [send t_s_1 set a]
} {us them}
-test send-8.12 {Tk_SendCmd procedure, local execution, different interp} {send testsend} {
+test send-8.12 {Tk_SendCmd procedure, local execution, different interp} {secureserver testsend} {
set a us
send t_s_1 {set a them}
list $a [send t_s_1 {set a}]
} {us them}
-test send-8.13 {Tk_SendCmd procedure, local execution, different interp} {send testsend} {
+test send-8.13 {Tk_SendCmd procedure, local execution, different interp} {secureserver testsend} {
set a us
send t_s_1 {set a them}
list $a [send t_s_1 {set a}]
} {us them}
-test send-8.14 {Tk_SendCmd procedure, local interp killed by send} {send testsend} {
+test send-8.14 {Tk_SendCmd procedure, local interp killed by send} {secureserver testsend} {
newApp "" t_s_2 Test
list [catch {send t_s_2 {destroy .; concat result}} msg] $msg
} {0 result}
catch {interp delete t_s_2}
-test send-8.15 {Tk_SendCmd procedure, local interp, error info} {send testsend} {
+test send-8.15 {Tk_SendCmd procedure, local interp, error info} {secureserver testsend} {
catch {error foo}
list [catch {send t_s_1 {if 1 {open bogus_file_name}}} msg] $msg $errorInfo $errorCode
} {1 {couldn't open "bogus_file_name": no such file or directory} {couldn't open "bogus_file_name": no such file or directory
@@ -313,7 +300,7 @@ test send-8.15 {Tk_SendCmd procedure, local interp, error info} {send testsend}
"if 1 {open bogus_file_name}"
invoked from within
"send t_s_1 {if 1 {open bogus_file_name}}"} {POSIX ENOENT {no such file or directory}}}
-test send-8.16 {Tk_SendCmd procedure, bogusCommWindow} {send testsend} {
+test send-8.16 {Tk_SendCmd procedure, bogusCommWindow} {secureserver testsend} {
testsend prop root InterpRegistry "10234 bogus\n"
set result [list [catch {send bogus bogus command} msg] $msg]
winfo interps
@@ -323,7 +310,7 @@ test send-8.16 {Tk_SendCmd procedure, bogusCommWindow} {send testsend} {
catch {interp delete t_s_1}
-test send-8.17 {Tk_SendCmd procedure, deferring events} {send nonPortable} {
+test send-8.17 {Tk_SendCmd procedure, deferring events} {secureserver nonPortable} {
# Non-portable because some window managers ignore "raise"
# requests so can't guarantee that new app's window won't
# obscure .f, thereby masking the Expose event.
@@ -343,7 +330,7 @@ test send-8.17 {Tk_SendCmd procedure, deferring events} {send nonPortable} {
cleanupbg
lappend result $a
} {{no event yet} {no event yet} exposed}
-test send-8.18 {Tk_SendCmd procedure, error in remote app} {send } {
+test send-8.18 {Tk_SendCmd procedure, error in remote app} {secureserver} {
setupbg
set app [dobg {tk appname}]
set result [string tolower [list [catch {send $app open bad_name} msg] \
@@ -355,7 +342,7 @@ test send-8.18 {Tk_SendCmd procedure, error in remote app} {send } {
"open bad_name"
invoked from within
"send $app open bad_name"} {posix enoent {no such file or directory}}}
-test send-8.19 {Tk_SendCmd, using modal timeouts} {send } {
+test send-8.19 {Tk_SendCmd, using modal timeouts} {secureserver} {
setupbg
set app [dobg {tk appname}]
set x no
@@ -373,30 +360,30 @@ catch {destroy .f}
frame .f
set id [string range [winfo id .f] 2 end]
-test send-9.1 {Tk_GetInterpNames procedure} {send testsend} {
+test send-9.1 {Tk_GetInterpNames procedure} {secureserver testsend} {
testsend prop root InterpRegistry \
"$commId tktest\nfoo bar\n$commId tktest\n$id frame .f\n\n\n"
list [winfo interps] [testsend prop root InterpRegistry]
} "{tktest tktest {frame .f}} {$commId tktest\n$commId tktest\n$id frame .f
}"
-test send-9.2 {Tk_GetInterpNames procedure} {send testsend} {
+test send-9.2 {Tk_GetInterpNames procedure} {secureserver testsend} {
testsend prop root InterpRegistry \
"$commId tktest\nfoobar\n$commId gorp\n"
list [winfo interps] [testsend prop root InterpRegistry]
} "tktest {$commId tktest\n}"
-test send-9.3 {Tk_GetInterpNames procedure} {send testsend} {
+test send-9.3 {Tk_GetInterpNames procedure} {secureserver testsend} {
testsend prop root InterpRegistry {}
list [winfo interps] [testsend prop root InterpRegistry]
} {{} {}}
catch {testsend prop root InterpRegistry "$commId tktest\n$id dummy\n"}
-test send-10.1 {SendEventProc procedure, bogus comm property} {send testsend} {
+test send-10.1 {SendEventProc procedure, bogus comm property} {secureserver testsend} {
testsend prop comm Comm {abc def}
testsend prop comm Comm {}
update
} {}
-test send-10.2 {SendEventProc procedure, simultaneous messages} {send testsend} {
+test send-10.2 {SendEventProc procedure, simultaneous messages} {secureserver testsend} {
testsend prop comm Comm \
"c\n-n tktest\n-s set a 44\nc\n-n tktest\n-s set b 45\n"
set a null
@@ -404,7 +391,7 @@ test send-10.2 {SendEventProc procedure, simultaneous messages} {send testsend}
update
list $a $b
} {44 45}
-test send-10.3 {SendEventProc procedure, simultaneous messages} {send testsend} {
+test send-10.3 {SendEventProc procedure, simultaneous messages} {secureserver testsend} {
testsend prop comm Comm \
"c\n-n tktest\n-s set a newA\nr\n-s [testsend serial]\n-r 12345\nc\n-n tktest\n-s set b newB\n"
set a null
@@ -412,21 +399,21 @@ test send-10.3 {SendEventProc procedure, simultaneous messages} {send testsend}
set x [send dummy bogus]
list $x $a $b
} {12345 newA newB}
-test send-10.4 {SendEventProc procedure, leading nulls, bogus commands} {send testsend} {
+test send-10.4 {SendEventProc procedure, leading nulls, bogus commands} {secureserver testsend} {
testsend prop comm Comm \
"\n\nx\n-bogus\n\nc\n-n tktest\n-s set a 44\n"
set a null
update
set a
} {44}
-test send-10.5 {SendEventProc procedure, extraneous command options} {send testsend} {
+test send-10.5 {SendEventProc procedure, extraneous command options} {secureserver testsend} {
testsend prop comm Comm \
"c\n-n tktest\n-x miscellanous\n-y who knows?\n-s set a new\n"
set a null
update
set a
} {new}
-test send-10.6 {SendEventProc procedure, unknown interpreter} {send testsend} {
+test send-10.6 {SendEventProc procedure, unknown interpreter} {secureserver testsend} {
testsend prop [winfo id .f] Comm {}
testsend prop comm Comm \
"c\n-n unknown\n-r $id 44\n-s set a new\n"
@@ -434,7 +421,7 @@ test send-10.6 {SendEventProc procedure, unknown interpreter} {send testsend} {
update
list [testsend prop [winfo id .f] Comm] $a
} "{\nr\n-s 44\n-r receiver never heard of interpreter \"unknown\"\n-c 1\n} null"
-test send-10.7 {SendEventProc procedure, error in script} {send testsend} {
+test send-10.7 {SendEventProc procedure, error in script} {secureserver testsend} {
testsend prop [winfo id .f] Comm {}
testsend prop comm Comm \
"c\n-n tktest\n-r $id 62\n-s foreach i {1 2 3} {error {test error} {Initial errorInfo} {test code}}\n"
@@ -451,7 +438,7 @@ r
-e test code
-c 1
}
-test send-10.8 {SendEventProc procedure, exceptional return} {send testsend} {
+test send-10.8 {SendEventProc procedure, exceptional return} {secureserver testsend} {
testsend prop [winfo id .f] Comm {}
testsend prop comm Comm \
"c\n-n tktest\n-r $id 62\n-s break\n"
@@ -463,7 +450,7 @@ r
-r
-c 3
}
-test send-10.9 {SendEventProc procedure, empty return} {send testsend} {
+test send-10.9 {SendEventProc procedure, empty return} {secureserver testsend} {
testsend prop [winfo id .f] Comm {}
testsend prop comm Comm \
"c\n-n tktest\n-r $id 62\n-s concat\n"
@@ -474,64 +461,64 @@ r
-s 62
-r
}
-test send-10.10 {SendEventProc procedure, asynchronous calls} {send testsend} {
+test send-10.10 {SendEventProc procedure, asynchronous calls} {secureserver testsend} {
testsend prop [winfo id .f] Comm {}
testsend prop comm Comm \
"c\n-n tktest\n-s foreach i {1 2 3} {error {test error} {Initial errorInfo} {test code}}\n"
update
testsend prop [winfo id .f] Comm
} {}
-test send-10.11 {SendEventProc procedure, exceptional return} {send testsend} {
+test send-10.11 {SendEventProc procedure, exceptional return} {secureserver testsend} {
testsend prop [winfo id .f] Comm {}
testsend prop comm Comm \
"c\n-n tktest\n-s break\n"
update
testsend prop [winfo id .f] Comm
} {}
-test send-10.12 {SendEventProc procedure, empty return} {send testsend} {
+test send-10.12 {SendEventProc procedure, empty return} {secureserver testsend} {
testsend prop [winfo id .f] Comm {}
testsend prop comm Comm \
"c\n-n tktest\n-s concat\n"
update
testsend prop [winfo id .f] Comm
} {}
-test send-10.13 {SendEventProc procedure, return processing} {send testsend} {
+test send-10.13 {SendEventProc procedure, return processing} {secureserver testsend} {
testsend prop comm Comm \
"r\n-c 1\n-e test1\n-i test2\n-r test3\n-s [testsend serial]\n"
list [catch {send dummy foo} msg] $msg $errorInfo $errorCode
} {1 test3 {test2
invoked from within
"send dummy foo"} test1}
-test send-10.14 {SendEventProc procedure, extraneous return options} {send testsend} {
+test send-10.14 {SendEventProc procedure, extraneous return options} {secureserver testsend} {
testsend prop comm Comm \
"r\n-x test1\n-y test2\n-r result\n-s [testsend serial]\n"
list [catch {send dummy foo} msg] $msg
} {0 result}
-test send-10.15 {SendEventProc procedure, serial number} {send testsend} {
+test send-10.15 {SendEventProc procedure, serial number} {secureserver testsend} {
testsend prop comm Comm \
"r\n-r response\n"
list [catch {send dummy foo} msg] $msg
} {1 {target application died or uses a Tk version before 4.0}}
-test send-10.16 {SendEventProc procedure, serial number} {send testsend} {
+test send-10.16 {SendEventProc procedure, serial number} {secureserver testsend} {
testsend prop comm Comm \
"r\n-r response\n\n-s 0"
list [catch {send dummy foo} msg] $msg
} {1 {target application died or uses a Tk version before 4.0}}
-test send-10.17 {SendEventProc procedure, errorCode and errorInfo} {send testsend} {
+test send-10.17 {SendEventProc procedure, errorCode and errorInfo} {secureserver testsend} {
testsend prop comm Comm \
"r\n-i test1\n-e test2\n-c 4\n-s [testsend serial]\n"
set errorCode oldErrorCode
set errorInfo oldErrorInfo
list [catch {send dummy foo} msg] $msg $errorInfo $errorCode
} {4 {} oldErrorInfo oldErrorCode}
-test send-10.18 {SendEventProc procedure, send kills application} {send testsend} {
+test send-10.18 {SendEventProc procedure, send kills application} {secureserver testsend} {
setupbg
dobg {tk appname t_s_3}
set x [list [catch {send t_s_3 destroy .} msg] $msg]
cleanupbg
set x
} {0 {}}
-test send-10.19 {SendEventProc procedure, send exits} {send testsend} {
+test send-10.19 {SendEventProc procedure, send exits} {secureserver testsend} {
setupbg
dobg {tk appname t_s_3}
set x [list [catch {send t_s_3 exit} msg] $msg]
@@ -539,11 +526,11 @@ test send-10.19 {SendEventProc procedure, send exits} {send testsend} {
set x
} {1 {target application died}}
-test send-11.1 {AppendPropCarefully and AppendErrorProc procedures} {send testsend} {
+test send-11.1 {AppendPropCarefully and AppendErrorProc procedures} {secureserver testsend} {
testsend prop root InterpRegistry "0x21447 dummy\n"
list [catch {send dummy foo} msg] $msg
} {1 {no application named "dummy"}}
-test send-11.2 {AppendPropCarefully and AppendErrorProc procedures} {send testsend} {
+test send-11.2 {AppendPropCarefully and AppendErrorProc procedures} {secureserver testsend} {
testsend prop comm Comm "c\n-r0x123 44\n-n tktest\n-s concat a b c\n"
update
} {}
@@ -554,14 +541,14 @@ catch {destroy .f}
frame .f
set id [string range [winfo id .f] 2 end]
-test send-12.1 {TimeoutProc procedure} {send testsend} {
+test send-12.1 {TimeoutProc procedure} {secureserver testsend} {
testsend prop root InterpRegistry "$id dummy\n"
list [catch {send dummy foo} msg] $msg
} {1 {target application died or uses a Tk version before 4.0}}
catch {testsend prop root InterpRegistry ""}
-test send-12.2 {TimeoutProc procedure} {send } {
+test send-12.2 {TimeoutProc procedure} {secureserver} {
winfo interps
tk appname tktest
update
@@ -578,14 +565,14 @@ test send-12.2 {TimeoutProc procedure} {send } {
winfo interps
tk appname tktest
-test send-13.1 {DeleteProc procedure} {send } {
+test send-13.1 {DeleteProc procedure} {secureserver} {
setupbg
set app [dobg {rename send {}; tk appname}]
set result [list [catch {send $app foo} msg] $msg [winfo interps]]
cleanupbg
set result
} {1 {no application named "tktest #2"} tktest}
-test send-13.2 {DeleteProc procedure} {send } {
+test send-13.2 {DeleteProc procedure} {secureserver} {
winfo interps
tk appname tktest
rename send {}
@@ -595,7 +582,7 @@ test send-13.2 {DeleteProc procedure} {send } {
lappend result [winfo interps] [info commands send]
} {{} {} foo send}
-test send-14.1 {SendRestrictProc procedure, sends crossing from different displays} {send altDisplay} {
+test send-14.1 {SendRestrictProc procedure, sends crossing from different displays} {secureserver altDisplay} {
setupbg -display $env(TK_ALT_DISPLAY)
set result [dobg "
toplevel .t -screen [winfo screen .]
@@ -618,7 +605,7 @@ catch {
testsend prop root InterpRegister $registry
tk appname tktest
}
-test send-15.1 {UpdateCommWindow procedure} {send testsend} {
+test send-15.1 {UpdateCommWindow procedure} {secureserver testsend} {
set x [list [testsend prop comm TK_APPLICATION]]
newApp "" t_s_1 Test
send t_s_1 wm withdraw .
diff --git a/tests/visual.test b/tests/visual.test
index 28b2d22..ee13af2 100644
--- a/tests/visual.test
+++ b/tests/visual.test
@@ -7,7 +7,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: visual.test,v 1.5 2002/07/13 20:28:36 dgp Exp $
+# RCS: @(#) $Id: visual.test,v 1.6 2002/07/14 05:48:46 dgp Exp $
package require tcltest 2.1
namespace import -force tcltest::configure
@@ -270,9 +270,7 @@ if {([winfo visual .] == "pseudocolor") && ([winfo depth .] == 8)} {
}
test visual-8.1 {Tk_FreeColormap procedure} {
- foreach w [winfo child .] {
- destroy $w
- }
+ deleteWindows
toplevel .t1 -width 300 -height 180 -colormap new
wm geometry .t1 +0+0
foreach i {.t2 .t3 .t4} {
@@ -286,9 +284,7 @@ test visual-8.1 {Tk_FreeColormap procedure} {
} {}
if {$other != {}} {
test visual-8.2 {Tk_FreeColormap procedure} {
- foreach w [winfo child .] {
- destroy $w
- }
+ deleteWindows
toplevel .t1 -width 300 -height 180 -visual $other
wm geometry .t1 +0+0
foreach i {.t2 .t3 .t4} {
diff --git a/unix/Makefile.in b/unix/Makefile.in
index d3fddeb..045c1e6 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -5,7 +5,7 @@
# "autoconf" program (constructs like "@foo@" will get replaced in the
# actual Makefile.
#
-# RCS: @(#) $Id: Makefile.in,v 1.75 2002/07/12 13:41:01 dgp Exp $
+# RCS: @(#) $Id: Makefile.in,v 1.76 2002/07/14 05:48:46 dgp Exp $
# Current Tk version; used in various names.
@@ -442,7 +442,7 @@ xttest: test.o tkTest.o tkSquare.o $(TK_LIB_FILE)
test: tktest
TCL_LIBRARY=@TCL_SRC_DIR@/library; export TCL_LIBRARY; \
TK_LIBRARY=@TK_SRC_DIR@/library; export TK_LIBRARY; \
- ./tktest $(TOP_DIR)/tests/all.tcl -geometry +0+0 -match \* \
+ ./tktest $(TOP_DIR)/tests/all.tcl -geometry +0+0 \
$(TESTFLAGS) $(TCLTESTARGS)
# Tests with different languages
@@ -452,7 +452,7 @@ testlang: tktest
for lang in $(LOCALES) ; \
do \
LANG=$(lang); export LANG; \
- ./tktest $(TOP_DIR)/tests/all.tcl -geometry +0+0 -match \* \
+ ./tktest $(TOP_DIR)/tests/all.tcl -geometry +0+0 \
$(TESTFLAGS) $(TCLTESTARGS); \
done