summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog7
-rw-r--r--tests/canvPsImg.tcl4
-rw-r--r--tests/constraints.tcl104
-rw-r--r--tests/unixButton.test53
-rw-r--r--tests/unixEmbed.test96
-rw-r--r--tests/unixFont.test141
-rw-r--r--tests/unixMenu.test258
-rw-r--r--tests/unixSelect.test21
-rw-r--r--tests/unixWm.test22
-rw-r--r--tests/util.test8
-rw-r--r--tests/visual.test8
-rw-r--r--tests/visual_bb.test27
-rw-r--r--tests/winButton.test8
-rw-r--r--tests/winClipboard.test13
-rw-r--r--tests/winDialog.test13
-rw-r--r--tests/winFont.test9
-rw-r--r--tests/winMenu.test9
-rw-r--r--tests/winSend.test167
-rw-r--r--tests/winWm.test9
-rw-r--r--tests/window.test12
-rw-r--r--tests/winfo.test16
-rw-r--r--tests/wm.test14
-rw-r--r--tests/xmfbox.test10
-rw-r--r--unix/Makefile.in6
24 files changed, 562 insertions, 473 deletions
diff --git a/ChangeLog b/ChangeLog
index 61cb31a..50f421b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2002-07-11 Don Porter <dgp@users.sf.net>
+
+ * tests/canvPsImg.tcl: Converted several files in the
+ * tests/constraints.tcl (new file): Tk test suite for testing by
+ * tests/[u-x]*.test: tcltest 2.1.
+ * unix/Makefile.in:
+
2002-07-11 Jeff Hobbs <jeffh@ActiveState.com>
* win/tkWinDialog.c (Tk_ChooseDirectoryObjCmd): initialize
diff --git a/tests/canvPsImg.tcl b/tests/canvPsImg.tcl
index d460d03..054be90 100644
--- a/tests/canvPsImg.tcl
+++ b/tests/canvPsImg.tcl
@@ -2,7 +2,7 @@
# for images in canvases. It is part of the Tk visual test suite,
# which is invoked via the "visual" script.
#
-# RCS: @(#) $Id: canvPsImg.tcl,v 1.1 1999/12/14 06:53:12 hobbs Exp $
+# RCS: @(#) $Id: canvPsImg.tcl,v 1.2 2002/07/12 13:40:59 dgp Exp $
# Build a test image in a canvas
proc BuildTestImage {} {
@@ -69,7 +69,7 @@ foreach l { monochrome gray color } {
pack .t.$l -in .t.top.r -anchor w
}
-set BitmapImage [image create bitmap -file $tk_library/demos/images/face \
+set BitmapImage [image create bitmap -file $tk_library/demos/images/face.bmp \
-background white -foreground black]
set PhotoImage [image create photo -file $tk_library/demos/images/teapot.ppm]
diff --git a/tests/constraints.tcl b/tests/constraints.tcl
new file mode 100644
index 0000000..a6c52da
--- /dev/null
+++ b/tests/constraints.tcl
@@ -0,0 +1,104 @@
+package require Tcl 8.4
+package require Tk 8.4
+package require tcltest 2.1
+namespace import -force tcltest::testConstraint
+testConstraint userInteraction 0
+testConstraint noExceed [expr {![testConstraint unix]
+ || [catch {font actual "\{xyz"}]}]
+testConstraint testImageType [expr {[lsearch [image types] test] >= 0}]
+testConstraint fonts 1
+destroy .e
+entry .e -width 0 -font {Helvetica -12} -bd 1
+.e insert end a.bcd
+if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} {
+ testConstraint fonts 0
+}
+destroy .e
+text .t -width 80 -height 20 -font {Times -14} -bd 1
+pack .t
+.t insert end "This is\na dot."
+update
+set x [list [.t bbox 1.3] [.t bbox 2.5]]
+destroy .t
+if {![string match {{22 3 6 15} {31 18 [34] 15}} $x]} {
+ testConstraint fonts 0
+}
+
+namespace eval ::tk {
+ if {[namespace exists test]} {
+ namespace delete test
+ }
+ namespace eval test {
+ namespace eval bg {
+ # Manage a background process.
+ # Replace with slave interp or thread?
+ namespace import ::tcltest::interpreter
+ namespace export setup cleanup do
+
+ proc cleanup {} {
+ variable fd
+ catch {
+ puts $fd exit
+ close $fd
+ }
+ set fd ""
+ }
+ proc setup args {
+ variable fd
+ if {[info exists fd] && [string length $fd]} {
+ cleanup
+ }
+ set fd [open "|[list [interpreter] \
+ -geometry +0+0 -name tktest] $args" r+]
+ puts $fd "puts foo; flush stdout"
+ flush $fd
+ if {[gets $fd data] < 0} {
+ error "unexpected EOF from \"[interpreter]\""
+ }
+ if {$data ne "foo"} {
+ error "unexpected output from\
+ background process: \"$data\""
+ }
+ fileevent $fd readable [namespace code Ready]
+ }
+ proc Ready {} {
+ variable fd
+ variable Data
+ variable Done
+ set x [gets $fd]
+ if {[eof $fd]} {
+ fileevent $fd readable {}
+ set Done 1
+ } elseif {$x eq "**DONE**"} {
+ set Done 1
+ } else {
+ append Data $x
+ }
+ }
+ proc do {cmd} {
+ variable fd
+ variable Data
+ variable Done
+ puts $fd "[list catch $cmd msg]; update; puts \$msg;\
+ puts **DONE**; flush stdout"
+ flush $fd
+ set Done 0
+ set Data {}
+ vwait [namespace which -variable Done]
+ return $Data
+ }
+ }
+
+ proc Export {internal as external} {
+ uplevel 1 [list namespace import $internal]
+ uplevel 1 [list rename [namespace tail $internal] $external]
+ uplevel 1 [list namespace export $external]
+ }
+ Export bg::setup as setupbg
+ Export bg::cleanup as cleanupbg
+ Export bg::do as dobg
+ }
+}
+
+namespace import -force ::tk::test::*
+
diff --git a/tests/unixButton.test b/tests/unixButton.test
index 6604e36..6b1bcbb 100644
--- a/tests/unixButton.test
+++ b/tests/unixButton.test
@@ -8,25 +8,17 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: unixButton.test,v 1.3 1999/04/16 01:51:41 stanton Exp $
-
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-
-if {$tcl_platform(platform)!="unix"} {
- puts "skipping: Unix only tests..."
- ::tcltest::cleanupTests
- return
-}
-
-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
-}
+# RCS: @(#) $Id: unixButton.test,v 1.4 2002/07/12 13:40:59 dgp Exp $
+
+package require tcltest 2.1
+namespace import -force tcltest::test
+namespace import -force tcltest::testConstraint
+namespace import -force tcltest::testsDirectory
+namespace import -force tcltest::configure
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
+eval configure $argv
foreach i [winfo children .] {
destroy $i
@@ -58,7 +50,6 @@ catch {unset value}
catch {unset value2}
eval image delete [image names]
-image create test image1
label .l -text Label
button .b -text Button
checkbutton .c -text Checkbutton
@@ -66,7 +57,7 @@ radiobutton .r -text Radiobutton
pack .l .b .c .r
update
-test unixbutton-1.1 {TkpComputeButtonGeometry procedure} {
+test unixbutton-1.1 {TkpComputeButtonGeometry procedure} {unix testImageType} {
eval destroy [winfo children .]
image create test image1
image1 changed 0 0 0 0 60 40
@@ -81,7 +72,7 @@ test unixbutton-1.1 {TkpComputeButtonGeometry procedure} {
[winfo reqwidth .b3] [winfo reqheight .b3] \
[winfo reqwidth .b4] [winfo reqheight .b4]
} {68 48 74 54 112 52 112 52}
-test unixbutton-1.2 {TkpComputeButtonGeometry procedure} {
+test unixbutton-1.2 {TkpComputeButtonGeometry procedure} unix {
eval destroy [winfo children .]
label .b1 -bitmap question -bd 3 -padx 0 -pady 2
button .b2 -bitmap question -bd 3 -padx 0 -pady 2
@@ -94,7 +85,7 @@ test unixbutton-1.2 {TkpComputeButtonGeometry procedure} {
[winfo reqwidth .b3] [winfo reqheight .b3] \
[winfo reqwidth .b4] [winfo reqheight .b4]
} {23 33 29 39 54 37 54 37}
-test unixbutton-1.3 {TkpComputeButtonGeometry procedure} {
+test unixbutton-1.3 {TkpComputeButtonGeometry procedure} unix {
eval destroy [winfo children .]
label .b1 -bitmap question -bd 3 -highlightthickness 4
button .b2 -bitmap question -bd 3 -highlightthickness 0
@@ -109,7 +100,7 @@ test unixbutton-1.3 {TkpComputeButtonGeometry procedure} {
[winfo reqwidth .b3] [winfo reqheight .b3] \
[winfo reqwidth .b4] [winfo reqheight .b4]
} {31 41 25 35 25 35 25 35}
-test unixbutton-1.4 {TkpComputeButtonGeometry procedure} {nonPortable fonts} {
+test unixbutton-1.4 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts} {
eval destroy [winfo children .]
label .b1 -text Xagqpim -padx 0 -pady 2 -font {Helvetica -18 bold}
button .b2 -text Xagqpim -padx 0 -pady 2 -font {Helvetica -18 bold}
@@ -122,21 +113,21 @@ test unixbutton-1.4 {TkpComputeButtonGeometry procedure} {nonPortable fonts} {
[winfo reqwidth .b3] [winfo reqheight .b3] \
[winfo reqwidth .b4] [winfo reqheight .b4]
} {82 29 88 35 114 31 121 29}
-test unixbutton-1.5 {TkpComputeButtonGeometry procedure} {nonPortable fonts} {
+test unixbutton-1.5 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts} {
eval destroy [winfo children .]
label .l1 -text "This is a long string that will wrap around on several lines.\n\nIt also has a blank line (above)." -wraplength 1.5i -padx 0 -pady 0
pack .l1
update
list [winfo reqwidth .l1] [winfo reqheight .l1]
} {136 88}
-test unixbutton-1.6 {TkpComputeButtonGeometry procedure} {nonPortable fonts} {
+test unixbutton-1.6 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts} {
eval destroy [winfo children .]
label .l1 -text "This is a long string without wrapping.\n\nIt also has a blank line (above)." -padx 0 -pady 0
pack .l1
update
list [winfo reqwidth .l1] [winfo reqheight .l1]
} {231 46}
-test unixbutton-1.7 {TkpComputeButtonGeometry procedure} {nonPortable fonts} {
+test unixbutton-1.7 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts} {
eval destroy [winfo children .]
label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 -width 10
button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 -height 5
@@ -149,7 +140,7 @@ test unixbutton-1.7 {TkpComputeButtonGeometry procedure} {nonPortable fonts} {
[winfo reqwidth .b3] [winfo reqheight .b3] \
[winfo reqwidth .b4] [winfo reqheight .b4]
} {74 22 60 84 168 38 61 22}
-test unixbutton-1.8 {TkpComputeButtonGeometry procedure} {nonPortable fonts} {
+test unixbutton-1.8 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts} {
eval destroy [winfo children .]
label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 \
-highlightthickness 4
@@ -165,17 +156,17 @@ test unixbutton-1.8 {TkpComputeButtonGeometry procedure} {nonPortable fonts} {
[winfo reqwidth .b3] [winfo reqheight .b3] \
[winfo reqwidth .b4] [winfo reqheight .b4]
} {62 30 56 24 58 22 62 22}
-test unixbutton-1.9 {TkpComputeButtonGeometry procedure} {
+test unixbutton-1.9 {TkpComputeButtonGeometry procedure} unix {
eval destroy [winfo children .]
button .b2 -bitmap question -default active
list [winfo reqwidth .b2] [winfo reqheight .b2]
} {37 47}
-test unixbutton-1.10 {TkpComputeButtonGeometry procedure} {
+test unixbutton-1.10 {TkpComputeButtonGeometry procedure} unix {
eval destroy [winfo children .]
button .b2 -bitmap question -default normal
list [winfo reqwidth .b2] [winfo reqheight .b2]
} {37 47}
-test unixbutton-1.11 {TkpComputeButtonGeometry procedure} {
+test unixbutton-1.11 {TkpComputeButtonGeometry procedure} unix {
eval destroy [winfo children .]
button .b2 -bitmap question -default disabled
list [winfo reqwidth .b2] [winfo reqheight .b2]
diff --git a/tests/unixEmbed.test b/tests/unixEmbed.test
index cbc7d96..851cba6 100644
--- a/tests/unixEmbed.test
+++ b/tests/unixEmbed.test
@@ -6,17 +6,17 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: unixEmbed.test,v 1.8 2001/03/28 17:27:10 dgp Exp $
-
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-
-if {$tcl_platform(platform) != "unix"} {
- puts "skipping: Unix only tests..."
- ::tcltest::cleanupTests
- return
-}
+# RCS: @(#) $Id: unixEmbed.test,v 1.9 2002/07/12 13:40:59 dgp Exp $
+
+package require tcltest 2.1
+namespace import -force tcltest::test
+namespace import -force tcltest::testConstraint
+namespace import -force tcltest::testsDirectory
+namespace import -force tcltest::configure
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
+eval configure $argv
eval destroy [winfo children .]
wm geometry . {}
@@ -65,15 +65,15 @@ proc colorsFree {w {red 31} {green 245} {blue 192}} {
&& ([lindex $vals 2]/256 == $blue)
}
-test unixEmbed-1.1 {TkpUseWindow procedure, bad window identifier} {
+test unixEmbed-1.1 {TkpUseWindow procedure, bad window identifier} unix {
catch {destroy .t}
list [catch {toplevel .t -use xyz} msg] $msg
} {1 {expected integer but got "xyz"}}
-test unixEmbed-1.2 {TkpUseWindow procedure, bad window identifier} {
+test unixEmbed-1.2 {TkpUseWindow procedure, bad window identifier} unix {
catch {destroy .t}
list [catch {toplevel .t -use 47} msg] $msg
} {1 {couldn't create child of window "47"}}
-test unixEmbed-1.3 {TkpUseWindow procedure, inheriting colormap} {nonPortable} {
+test unixEmbed-1.3 {TkpUseWindow procedure, inheriting colormap} {unix nonPortable} {
catch {destroy .t}
catch {destroy .x}
toplevel .t -colormap new
@@ -85,7 +85,7 @@ test unixEmbed-1.3 {TkpUseWindow procedure, inheriting colormap} {nonPortable} {
destroy .t
set result
} {0}
-test unixEmbed-1.4 {TkpUseWindow procedure, inheriting colormap} {nonPortable} {
+test unixEmbed-1.4 {TkpUseWindow procedure, inheriting colormap} {unix nonPortable} {
catch {destroy .t}
catch {destroy .t2}
catch {destroy .x}
@@ -98,15 +98,9 @@ test unixEmbed-1.4 {TkpUseWindow procedure, inheriting colormap} {nonPortable} {
set result
} {1}
-if {[string compare testembed [info commands testembed]] != 0} {
- puts "This application hasn't been compiled with the testembed command,"
- puts "therefore I am skipping all of these tests."
- cleanupbg
- ::tcltest::cleanupTests
- return
-}
+testConstraint testembed [llength [info commands testembed]]
-test unixEmbed-1.5 {TkpUseWindow procedure, creating Container records} {
+test unixEmbed-1.5 {TkpUseWindow procedure, creating Container records} {unix testembed} {
eval destroy [winfo child .]
frame .f1 -container 1 -width 200 -height 50
frame .f2 -container 1 -width 200 -height 50
@@ -118,7 +112,7 @@ test unixEmbed-1.5 {TkpUseWindow procedure, creating Container records} {
list [testembed] [expr [lindex [lindex [testembed all] 0] 0] - $w]
}
} {{{XXX {} {} .t}} 0}
-test unixEmbed-1.6 {TkpUseWindow procedure, creating Container records} {
+test unixEmbed-1.6 {TkpUseWindow procedure, creating Container records} {unix testembed} {
eval destroy [winfo child .]
frame .f1 -container 1 -width 200 -height 50
frame .f2 -container 1 -width 200 -height 50
@@ -132,7 +126,7 @@ test unixEmbed-1.6 {TkpUseWindow procedure, creating Container records} {
testembed
}
} {{XXX {} {} .t2} {XXX {} {} .t1}}
-test unixEmbed-1.7 {TkpUseWindow procedure, container and embedded in same app} {
+test unixEmbed-1.7 {TkpUseWindow procedure, container and embedded in same app} {unix testembed} {
eval destroy [winfo child .]
frame .f1 -container 1 -width 200 -height 50
frame .f2 -container 1 -width 200 -height 50
@@ -145,7 +139,7 @@ test unixEmbed-1.7 {TkpUseWindow procedure, container and embedded in same app}
# Can't think of any way to test the procedures TkpMakeWindow,
# TkpMakeContainer, or EmbedErrorProc.
-test unixEmbed-2.1 {EmbeddedEventProc procedure} {
+test unixEmbed-2.1 {EmbeddedEventProc procedure} {unix testembed} {
foreach w [winfo child .] {
catch {destroy $w}
}
@@ -163,7 +157,7 @@ test unixEmbed-2.1 {EmbeddedEventProc procedure} {
testembed
}
} {}
-test unixEmbed-2.2 {EmbeddedEventProc procedure} {
+test unixEmbed-2.2 {EmbeddedEventProc procedure} {unix testembed} {
foreach w [winfo child .] {
catch {destroy $w}
}
@@ -178,7 +172,7 @@ test unixEmbed-2.2 {EmbeddedEventProc procedure} {
testembed
}
} {}
-test unixEmbed-2.3 {EmbeddedEventProc procedure} {
+test unixEmbed-2.3 {EmbeddedEventProc procedure} {unix testembed} {
foreach w [winfo child .] {
catch {destroy $w}
}
@@ -189,7 +183,7 @@ test unixEmbed-2.3 {EmbeddedEventProc procedure} {
destroy .f1
testembed
} {}
-test unixEmbed-2.4 {EmbeddedEventProc procedure} {
+test unixEmbed-2.4 {EmbeddedEventProc procedure} {unix testembed} {
foreach w [winfo child .] {
catch {destroy $w}
}
@@ -204,7 +198,7 @@ test unixEmbed-2.4 {EmbeddedEventProc procedure} {
} {{{XXX .f1 {} {}}} {}}
test unixEmbed-3.1 {ContainerEventProc procedure, detect creation} \
- {nonPortable} {
+ {unix testembed nonPortable} {
foreach w [winfo child .] {
catch {destroy $w}
}
@@ -219,7 +213,7 @@ test unixEmbed-3.1 {ContainerEventProc procedure, detect creation} \
}
list $x [testembed]
} {{{XXX .f1 {} {}}} {{XXX .f1 XXX {}}}}
-test unixEmbed-3.2 {ContainerEventProc procedure, set size on creation} {
+test unixEmbed-3.2 {ContainerEventProc procedure, set size on creation} unix {
foreach w [winfo child .] {
catch {destroy $w}
}
@@ -229,7 +223,7 @@ test unixEmbed-3.2 {ContainerEventProc procedure, set size on creation} {
update
wm geometry .t2
} {200x200+0+0}
-test unixEmbed-3.2 {ContainerEventProc procedure, disallow position changes} {
+test unixEmbed-3.2 {ContainerEventProc procedure, disallow position changes} unix {
foreach w [winfo child .] {
catch {destroy $w}
}
@@ -247,7 +241,7 @@ test unixEmbed-3.2 {ContainerEventProc procedure, disallow position changes} {
wm geometry .t1
}
} {200x200+0+0}
-test unixEmbed-3.3 {ContainerEventProc procedure, disallow position changes} {
+test unixEmbed-3.3 {ContainerEventProc procedure, disallow position changes} unix {
foreach w [winfo child .] {
catch {destroy $w}
}
@@ -265,7 +259,7 @@ test unixEmbed-3.3 {ContainerEventProc procedure, disallow position changes} {
wm geometry .t1
}
} {300x100+0+0}
-test unixEmbed-3.4 {ContainerEventProc procedure, geometry requests} {
+test unixEmbed-3.4 {ContainerEventProc procedure, geometry requests} unix {
foreach w [winfo child .] {
catch {destroy $w}
}
@@ -283,7 +277,7 @@ test unixEmbed-3.4 {ContainerEventProc procedure, geometry requests} {
update
list [winfo width .f1] [winfo height .f1] [dobg {wm geometry .t1}]
} {300 80 300x80+0+0}
-test unixEmbed-3.5 {ContainerEventProc procedure, map requests} {
+test unixEmbed-3.5 {ContainerEventProc procedure, map requests} unix {
foreach w [winfo child .] {
catch {destroy $w}
}
@@ -303,7 +297,7 @@ test unixEmbed-3.5 {ContainerEventProc procedure, map requests} {
set x
}
} {mapped}
-test unixEmbed-3.6 {ContainerEventProc procedure, destroy events} {
+test unixEmbed-3.6 {ContainerEventProc procedure, destroy events} unix {
foreach w [winfo child .] {
catch {destroy $w}
}
@@ -324,7 +318,7 @@ test unixEmbed-3.6 {ContainerEventProc procedure, destroy events} {
list $x [winfo exists .f1]
} {dead 0}
-test unixEmbed-4.1 {EmbedStructureProc procedure, configure events} {
+test unixEmbed-4.1 {EmbedStructureProc procedure, configure events} unix {
foreach w [winfo child .] {
catch {destroy $w}
}
@@ -344,7 +338,7 @@ test unixEmbed-4.1 {EmbedStructureProc procedure, configure events} {
winfo geometry .t1
}
} {180x100+0+0}
-test unixEmbed-4.2 {EmbedStructureProc procedure, destroy events} {
+test unixEmbed-4.2 {EmbedStructureProc procedure, destroy events} {unix testembed} {
foreach w [winfo child .] {
catch {destroy $w}
}
@@ -361,7 +355,7 @@ test unixEmbed-4.2 {EmbedStructureProc procedure, destroy events} {
list $x [testembed]
} {{{XXX .f1 XXX {}}} {}}
-test unixEmbed-5.1 {EmbedFocusProc procedure, FocusIn events} {
+test unixEmbed-5.1 {EmbedFocusProc procedure, FocusIn events} unix {
foreach w [winfo child .] {
catch {destroy $w}
}
@@ -379,7 +373,7 @@ test unixEmbed-5.1 {EmbedFocusProc procedure, FocusIn events} {
update
dobg {set x}
} {{focus in .t1}}
-test unixEmbed-5.2 {EmbedFocusProc procedure, focusing on dead window} {
+test unixEmbed-5.2 {EmbedFocusProc procedure, focusing on dead window} unix {
foreach w [winfo child .] {
catch {destroy $w}
}
@@ -398,7 +392,7 @@ test unixEmbed-5.2 {EmbedFocusProc procedure, focusing on dead window} {
focus -force .f1
update
} {}
-test unixEmbed-5.3 {EmbedFocusProc procedure, FocusOut events} {
+test unixEmbed-5.3 {EmbedFocusProc procedure, FocusOut events} unix {
foreach w [winfo child .] {
catch {destroy $w}
}
@@ -420,7 +414,7 @@ test unixEmbed-5.3 {EmbedFocusProc procedure, FocusOut events} {
list $x [dobg {update; set x}]
} {{{focus in .t1}} {{focus in .t1} {focus out .t1}}}
-test unixEmbed-6.1 {EmbedGeometryRequest procedure, window changes size} {
+test unixEmbed-6.1 {EmbedGeometryRequest procedure, window changes size} unix {
foreach w [winfo child .] {
catch {destroy $w}
}
@@ -440,7 +434,7 @@ test unixEmbed-6.1 {EmbedGeometryRequest procedure, window changes size} {
list $x [winfo geom .t1]
}
} {{{configure .t1 300 120}} 300x120+0+0}
-test unixEmbed-6.2 {EmbedGeometryRequest procedure, window changes size} {
+test unixEmbed-6.2 {EmbedGeometryRequest procedure, window changes size} unix {
foreach w [winfo child .] {
catch {destroy $w}
}
@@ -464,7 +458,7 @@ test unixEmbed-6.2 {EmbedGeometryRequest procedure, window changes size} {
# Can't think up any tests for TkpGetOtherWindow procedure.
-test unixEmbed-7.1 {TkpRedirectKeyEvent procedure, forward keystroke} {
+test unixEmbed-7.1 {TkpRedirectKeyEvent procedure, forward keystroke} unix {
foreach w [winfo child .] {
catch {destroy $w}
}
@@ -489,7 +483,7 @@ test unixEmbed-7.1 {TkpRedirectKeyEvent procedure, forward keystroke} {
bind . <KeyPress> {}
list $x $y
} {{{key a 1}} {}}
-test unixEmbed-7.2 {TkpRedirectKeyEvent procedure, don't forward keystroke width} {
+test unixEmbed-7.2 {TkpRedirectKeyEvent procedure, don't forward keystroke width} unix {
foreach w [winfo child .] {
catch {destroy $w}
}
@@ -517,7 +511,7 @@ test unixEmbed-7.2 {TkpRedirectKeyEvent procedure, don't forward keystroke width
list $x $y
} {{} {{key b}}}
-test unixEmbed-8.1 {TkpClaimFocus procedure} {
+test unixEmbed-8.1 {TkpClaimFocus procedure} unix {
foreach w [winfo child .] {
catch {destroy $w}
}
@@ -540,7 +534,7 @@ test unixEmbed-8.1 {TkpClaimFocus procedure} {
lappend x [focus]
}] [focus]
} {{{} .t1} .f1}
-test unixEmbed-8.2 {TkpClaimFocus procedure} {
+test unixEmbed-8.2 {TkpClaimFocus procedure} unix {
catch {interp delete child}
foreach w [winfo child .] {
catch {destroy $w}
@@ -565,7 +559,7 @@ test unixEmbed-8.2 {TkpClaimFocus procedure} {
} {{{} .} .f1}
catch {interp delete child}
-test unixEmbed-9.1 {EmbedWindowDeleted procedure, check parentPtr} {
+test unixEmbed-9.1 {EmbedWindowDeleted procedure, check parentPtr} {unix testembed} {
foreach w [winfo child .] {
catch {destroy $w}
}
@@ -582,7 +576,7 @@ test unixEmbed-9.1 {EmbedWindowDeleted procedure, check parentPtr} {
}
set x
} {{{XXX .f4 {} {}} {XXX .f3 {} {}} {XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f4 {} {}} {XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f2 {} {}}} {}}
-test unixEmbed-9.2 {EmbedWindowDeleted procedure, check embeddedPtr} {
+test unixEmbed-9.2 {EmbedWindowDeleted procedure, check embeddedPtr} {unix testembed} {
foreach w [winfo child .] {
catch {destroy $w}
}
@@ -599,7 +593,7 @@ test unixEmbed-9.2 {EmbedWindowDeleted procedure, check embeddedPtr} {
}
} {{{XXX {} {} .t1}} {}}
-test unixEmbed-10.1 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} {
+test unixEmbed-10.1 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} unix {
foreach w [winfo child .] {
catch {destroy $w}
}
@@ -611,7 +605,7 @@ test unixEmbed-10.1 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} {
update
wm geometry .t1
} {150x80+0+0}
-test unixEmbed-10.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} {
+test unixEmbed-10.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} unix {
foreach w [winfo child .] {
catch {destroy $w}
}
diff --git a/tests/unixFont.test b/tests/unixFont.test
index 34f0040..16d2bf8 100644
--- a/tests/unixFont.test
+++ b/tests/unixFont.test
@@ -12,33 +12,34 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: unixFont.test,v 1.5 2001/08/22 01:25:53 hobbs Exp $
-
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-
-if {$tcl_platform(platform) != "unix"} {
- puts "skipping: Unix only tests..."
- ::tcltest::cleanupTests
- return
-}
-
-set ::tcltest::testConfig(hasArial) 1
-set ::tcltest::testConfig(hasCourierNew) 1
-set ::tcltest::testConfig(hasTimesNew) 1
+# RCS: @(#) $Id: unixFont.test,v 1.6 2002/07/12 13:40:59 dgp Exp $
+
+package require tcltest 2.1
+namespace import -force tcltest::test
+namespace import -force tcltest::testConstraint
+namespace import -force tcltest::testsDirectory
+namespace import -force tcltest::configure
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
+eval configure $argv
+
+testConstraint hasArial 1
+testConstraint hasCourierNew 1
+testConstraint hasTimesNew 1
set xlsf [auto_execok xlsfonts]
-if {$xlsf != ""} {
+if {[llength $xlsf]} {
foreach {constraint font} {
hasArial arial
hasCourierNew "courier new"
hasTimesNew "times new roman"
} {
- if {![catch {exec $xlsf *-$font-*} res] \
- && ![string match "*unmatched*" $res]} {
- # Newer Unix systems have more default fonts installed, so we can't
- # rely on fallbacks for fonts to need to fall back on anything.
- set ::tcltest::testConfig($constraint) 0
+ if {![catch {eval exec $xlsf [list *-$font-*]} res]
+ && ![string match *unmatched* $res]} {
+ # Newer Unix systems have more default fonts installed,
+ # so we can't rely on fallbacks for fonts to need to
+ # fall back on anything.
+ testConstraint $constraint 0
}
}
}
@@ -69,58 +70,58 @@ proc getsize {} {
return "[winfo reqwidth .b.l] [winfo reqheight .b.l]"
}
-test unixfont-1.1 {TkpGetNativeFont procedure: not native} {noExceed} {
+test unixfont-1.1 {TkpGetNativeFont procedure: not native} {unix noExceed} {
list [catch {font measure {} xyz} msg] $msg
} {1 {font "" doesn't exist}}
-test unixfont-1.2 {TkpGetNativeFont procedure: native} {
+test unixfont-1.2 {TkpGetNativeFont procedure: native} unix {
font measure fixed 0
} {6}
-test unixfont-2.1 {TkpGetFontFromAttributes procedure: no family} {
+test unixfont-2.1 {TkpGetFontFromAttributes procedure: no family} unix {
font actual {-size 10}
set x {}
} {}
test unixfont-2.2 {TkpGetFontFromAttributes procedure: Times relatives} \
- {noExceed hasTimesNew} {
+ {unix noExceed hasTimesNew} {
set x {}
lappend x [lindex [font actual {-family "Times New Roman"}] 1]
lappend x [lindex [font actual {-family "New York"}] 1]
lappend x [lindex [font actual {-family "Times"}] 1]
} {times times times}
test unixfont-2.3 {TkpGetFontFromAttributes procedure: Courier relatives} \
- {noExceed hasCourierNew} {
+ {unix noExceed hasCourierNew} {
set x {}
lappend x [lindex [font actual {-family "Courier New"}] 1]
lappend x [lindex [font actual {-family "Monaco"}] 1]
lappend x [lindex [font actual {-family "Courier"}] 1]
} {courier courier courier}
test unixfont-2.4 {TkpGetFontFromAttributes procedure: Helvetica relatives} \
- {noExceed hasArial} {
+ {unix noExceed hasArial} {
set x {}
lappend x [lindex [font actual {-family "Arial"}] 1]
lappend x [lindex [font actual {-family "Geneva"}] 1]
lappend x [lindex [font actual {-family "Helvetica"}] 1]
} {helvetica helvetica helvetica}
-test unixfont-2.5 {TkpGetFontFromAttributes procedure: fallback} {
+test unixfont-2.5 {TkpGetFontFromAttributes procedure: fallback} unix {
font actual {-xyz-xyz-*-*-*-*-*-*-*-*-*-*-*-*}
set x {}
} {}
-test unixfont-2.6 {TkpGetFontFromAttributes: fallback to fixed family} {
+test unixfont-2.6 {TkpGetFontFromAttributes: fallback to fixed family} unix {
lindex [font actual {-family fixed -size 10}] 1
} {fixed}
-test unixfont-2.7 {TkpGetFontFromAttributes: fixed family not available!} {
+test unixfont-2.7 {TkpGetFontFromAttributes: fixed family not available!} unix {
# no test available
} {}
-test unixfont-2.8 {TkpGetFontFromAttributes: loop over returned font names} {
+test unixfont-2.8 {TkpGetFontFromAttributes: loop over returned font names} unix {
lindex [font actual {-family fixed -size 31}] 1
} {fixed}
-test unixfont-2.9 {TkpGetFontFromAttributes: reject adobe courier if possible} {noExceed} {
+test unixfont-2.9 {TkpGetFontFromAttributes: reject adobe courier if possible} {unix noExceed} {
lindex [font actual {-family courier}] 1
} {courier}
-test unixfont-2.10 {TkpGetFontFromAttributes: scalable font found} {
+test unixfont-2.10 {TkpGetFontFromAttributes: scalable font found} unix {
lindex [font actual {-family courier -size 37}] 3
} {37}
-test unixfont-2.11 {TkpGetFontFromAttributes: font cannot be loaded} {
+test unixfont-2.11 {TkpGetFontFromAttributes: font cannot be loaded} unix {
# On Linux, XListFonts() was returning names for fonts that do not
# actually exist, causing the subsequent XLoadQueryFont() to fail
# unexpectedly. Now falls back to another font if that happens.
@@ -129,114 +130,114 @@ test unixfont-2.11 {TkpGetFontFromAttributes: font cannot be loaded} {
set x {}
} {}
-test unixfont-3.1 {TkpDeleteFont procedure} {
+test unixfont-3.1 {TkpDeleteFont procedure} unix {
font actual {-family xyz}
set x {}
} {}
-test unixfont-4.1 {TkpGetFontFamilies procedure} {
+test unixfont-4.1 {TkpGetFontFamilies procedure} unix {
font families
set x {}
} {}
-test unixfont-5.1 {Tk_MeasureChars procedure: no chars to be measured} {
+test unixfont-5.1 {Tk_MeasureChars procedure: no chars to be measured} unix {
.b.l config -text "000000" -wrap [expr $ax*3]
.b.l config -wrap 0
} {}
-test unixfont-5.2 {Tk_MeasureChars procedure: no right margin} {
+test unixfont-5.2 {Tk_MeasureChars procedure: no right margin} unix {
.b.l config -text "000000"
} {}
-test unixfont-5.3 {Tk_MeasureChars procedure: loop over chars} {
+test unixfont-5.3 {Tk_MeasureChars procedure: loop over chars} unix {
.b.l config -text "0"
.b.l config -text "\377"
.b.l config -text "0\3770\377"
.b.l config -text "000000000000000"
} {}
.b.l config -wrap [expr $ax*10]
-test unixfont-5.4 {Tk_MeasureChars procedure: reached right edge} {
+test unixfont-5.4 {Tk_MeasureChars procedure: reached right edge} unix {
.b.l config -text "0000000000000"
getsize
} "[expr $ax*10] [expr $ay*2]"
-test unixfont-5.5 {Tk_MeasureChars procedure: ran out of chars} {
+test unixfont-5.5 {Tk_MeasureChars procedure: ran out of chars} unix {
.b.l config -text "000000"
getsize
} "[expr $ax*6] $ay"
-test unixfont-5.6 {Tk_MeasureChars procedure: find last word} {
+test unixfont-5.6 {Tk_MeasureChars procedure: find last word} unix {
.b.l config -text "000000 00000"
getsize
} "[expr $ax*6] [expr $ay*2]"
-test unixfont-5.7 {Tk_MeasureChars procedure: already saw space in line} {
+test unixfont-5.7 {Tk_MeasureChars procedure: already saw space in line} unix {
.b.l config -text "000000 00000"
getsize
} "[expr $ax*6] [expr $ay*2]"
-test unixfont-5.8 {Tk_MeasureChars procedure: internal spaces significant} {
+test unixfont-5.8 {Tk_MeasureChars procedure: internal spaces significant} unix {
.b.l config -text "00 000 00000"
getsize
} "[expr $ax*7] [expr $ay*2]"
-test unixfont-5.9 {Tk_MeasureChars procedure: TK_PARTIAL_OK} {
+test unixfont-5.9 {Tk_MeasureChars procedure: TK_PARTIAL_OK} unix {
.b.c dchars $t 0 end
.b.c insert $t 0 "0000"
.b.c index $t @[expr int($ax*2.5)],1
} {2}
-test unixfont-5.10 {Tk_MeasureChars procedure: TK_AT_LEAST_ONE} {
+test unixfont-5.10 {Tk_MeasureChars procedure: TK_AT_LEAST_ONE} unix {
.b.l config -text "000000000000"
getsize
} "[expr $ax*10] [expr $ay*2]"
-test unixfont-5.11 {Tk_MeasureChars: TK_AT_LEAST_ONE + not even one char fit!} {
+test unixfont-5.11 {Tk_MeasureChars: TK_AT_LEAST_ONE + not even one char fit!} unix {
set a [.b.l cget -wrap]
.b.l config -text "000000" -wrap 1
set x [getsize]
.b.l config -wrap $a
set x
} "$ax [expr $ay*6]"
-test unixfont-5.12 {Tk_MeasureChars procedure: include eol spaces} {
+test unixfont-5.12 {Tk_MeasureChars procedure: include eol spaces} unix {
.b.l config -text "000 \n000"
getsize
} "[expr $ax*6] [expr $ay*2]"
-test unixfont-6.1 {Tk_DrawChars procedure: loop test} {
+test unixfont-6.1 {Tk_DrawChars procedure: loop test} unix {
.b.l config -text "a"
update
} {}
-test unixfont-6.2 {Tk_DrawChars procedure: loop test} {
+test unixfont-6.2 {Tk_DrawChars procedure: loop test} unix {
.b.l config -text "abcd"
update
} {}
-test unixfont-6.3 {Tk_DrawChars procedure: special char} {
+test unixfont-6.3 {Tk_DrawChars procedure: special char} unix {
.b.l config -text "\001"
update
} {}
-test unixfont-6.4 {Tk_DrawChars procedure: normal then special} {
+test unixfont-6.4 {Tk_DrawChars procedure: normal then special} unix {
.b.l config -text "ab\001"
update
} {}
-test unixfont-6.5 {Tk_DrawChars procedure: ends with special} {
+test unixfont-6.5 {Tk_DrawChars procedure: ends with special} unix {
.b.l config -text "ab\001"
update
} {}
-test unixfont-6.6 {Tk_DrawChars procedure: more normal chars at end} {
+test unixfont-6.6 {Tk_DrawChars procedure: more normal chars at end} unix {
.b.l config -text "ab\001def"
update
} {}
-test unixfont-7.1 {DrawChars procedure: no effects} {
+test unixfont-7.1 {DrawChars procedure: no effects} unix {
.b.l config -text "abc"
update
} {}
-test unixfont-7.2 {DrawChars procedure: underlining} {
+test unixfont-7.2 {DrawChars procedure: underlining} unix {
set f [.b.l cget -font]
.b.l config -text "abc" -font "courier 10 underline"
update
.b.l config -font $f
} {}
-test unixfont-7.3 {DrawChars procedure: overstrike} {
+test unixfont-7.3 {DrawChars procedure: overstrike} unix {
set f [.b.l cget -font]
.b.l config -text "abc" -font "courier 10 overstrike"
update
.b.l config -font $f
} {}
-test unixfont-8.1 {AllocFont procedure: use old font} {
+test unixfont-8.1 {AllocFont procedure: use old font} unix {
font create xyz
button .c -font xyz
font configure xyz -family times
@@ -244,10 +245,10 @@ test unixfont-8.1 {AllocFont procedure: use old font} {
destroy .c
font delete xyz
} {}
-test unixfont-8.2 {AllocFont procedure: parse information from XLFD} {
+test unixfont-8.2 {AllocFont procedure: parse information from XLFD} unix {
expr {[lindex [font actual {-family times -size 0}] 3] == 0}
} {0}
-test unixfont-8.3 {AllocFont procedure: can't parse info from name} {
+test unixfont-8.3 {AllocFont procedure: can't parse info from name} unix {
catch {unset fontArray}
# check that font actual returns the correct attributes.
# the values of those attributes are system dependent.
@@ -256,7 +257,7 @@ test unixfont-8.3 {AllocFont procedure: can't parse info from name} {
catch {unset fontArray}
set result
} {-family -overstrike -size -slant -underline -weight}
-test unixfont-8.4 {AllocFont procedure: classify characters} {
+test unixfont-8.4 {AllocFont procedure: classify characters} unix {
set x 0
incr x [font measure $courier "\u4000"] ;# 6
incr x [font measure $courier "\002"] ;# 4
@@ -264,38 +265,38 @@ test unixfont-8.4 {AllocFont procedure: classify characters} {
incr x [font measure $courier "\101"] ;# 1
set x
} [expr $cx*13]
-test unixfont-8.5 {AllocFont procedure: setup widths of normal chars} {
+test unixfont-8.5 {AllocFont procedure: setup widths of normal chars} unix {
font metrics $courier -fixed
} {1}
-test unixfont-8.6 {AllocFont procedure: setup widths of special chars} {
+test unixfont-8.6 {AllocFont procedure: setup widths of special chars} unix {
set x 0
incr x [font measure $courier "\001"] ;# 4
incr x [font measure $courier "\002"] ;# 4
incr x [font measure $courier "\012"] ;# 2
set x
} [expr $cx*10]
-test unixfont-8.7 {AllocFont procedure: XA_UNDERLINE_POSITION} {
+test unixfont-8.7 {AllocFont procedure: XA_UNDERLINE_POSITION} unix {
catch {font actual -adobe-courier-bold-i-normal--0-0-0-0-m-0-iso8859-1}
set x {}
} {}
-test unixfont-8.8 {AllocFont procedure: no XA_UNDERLINE_POSITION} {
+test unixfont-8.8 {AllocFont procedure: no XA_UNDERLINE_POSITION} unix {
catch {font actual --symbol-medium-r-normal--0-0-0-0-p-0-sun-fontspecific}
set x {}
} {}
-test unixfont-8.9 {AllocFont procedure: XA_UNDERLINE_THICKNESS} {
+test unixfont-8.9 {AllocFont procedure: XA_UNDERLINE_THICKNESS} unix {
catch {font actual -adobe-courier-bold-i-normal--0-0-0-0-m-0-iso8859-1}
set x {}
} {}
-test unixfont-8.10 {AllocFont procedure: no XA_UNDERLINE_THICKNESS} {
+test unixfont-8.10 {AllocFont procedure: no XA_UNDERLINE_THICKNESS} unix {
catch {font actual --symbol-medium-r-normal--0-0-0-0-p-0-sun-fontspecific}
set x {}
} {}
-test unixfont-8.11 {AllocFont procedure: XA_UNDERLINE_POSITION was 0} {
+test unixfont-8.11 {AllocFont procedure: XA_UNDERLINE_POSITION was 0} unix {
catch {font actual -adobe-courier-bold-i-normal--0-0-0-0-m-0-iso8859-1}
set x {}
} {}
-test unixfont-9.1 {GetControlCharSubst procedure: 2 chars subst} {
+test unixfont-9.1 {GetControlCharSubst procedure: 2 chars subst} unix {
.b.c dchars $t 0 end
.b.c insert $t 0 "0\a0"
set x {}
@@ -304,7 +305,7 @@ test unixfont-9.1 {GetControlCharSubst procedure: 2 chars subst} {
lappend x [.b.c index $t @[expr $ax*2],0]
lappend x [.b.c index $t @[expr $ax*3],0]
} {0 1 1 2}
-test unixfont-9.2 {GetControlCharSubst procedure: 4 chars subst} {
+test unixfont-9.2 {GetControlCharSubst procedure: 4 chars subst} unix {
.b.c dchars $t 0 end
.b.c insert $t 0 "0\0010"
set x {}
diff --git a/tests/unixMenu.test b/tests/unixMenu.test
index fe67be6..ed4a048 100644
--- a/tests/unixMenu.test
+++ b/tests/unixMenu.test
@@ -7,25 +7,17 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: unixMenu.test,v 1.5 2001/08/01 16:21:12 dgp Exp $
+# RCS: @(#) $Id: unixMenu.test,v 1.6 2002/07/12 13:41:00 dgp Exp $
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-
-if {$tcl_platform(platform) != "unix"} {
- puts "skipping: Unix only tests..."
- ::tcltest::cleanupTests
- return
-}
-
-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
-}
+package require tcltest 2.1
+namespace import -force tcltest::test
+namespace import -force tcltest::testConstraint
+namespace import -force tcltest::testsDirectory
+namespace import -force tcltest::configure
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
+eval configure $argv
proc deleteWindows {} {
foreach i [winfo children .] {
@@ -37,11 +29,11 @@ deleteWindows
wm geometry . {}
raise .
-test unixMenu-1.1 {TkpNewMenu - normal menu} {
+test unixMenu-1.1 {TkpNewMenu - normal menu} unix {
catch {destroy .m1}
list [catch {menu .m1} msg] $msg [destroy .m1]
} {0 .m1 {}}
-test unixMenu-1.2 {TkpNewMenu - help menu} {
+test unixMenu-1.2 {TkpNewMenu - help menu} unix {
catch {destroy .m1}
menu .m1 -tearoff 0
. configure -menu .m1
@@ -52,13 +44,13 @@ test unixMenu-1.2 {TkpNewMenu - help menu} {
test unixMenu-2.1 {TkpDestroyMenu - nothing to do} {} {}
test unixMenu-3.1 {TkpDestroymenuEntry - nothing to do} {} {}
-test unixMenu-4.1 {TkpConfigureMenuEntry - non-cascade entry} {
+test unixMenu-4.1 {TkpConfigureMenuEntry - non-cascade entry} unix {
catch {destroy .m1}
menu .m1 -tearoff 0
.m1 add command -label test
list [catch {.m1 entryconfigure test -label foo} msg] $msg [destroy .m1]
} {0 {} {}}
-test unixMenu-4.2 {TkpConfigureMenuEntry - cascade entry} {
+test unixMenu-4.2 {TkpConfigureMenuEntry - cascade entry} unix {
catch {destroy .m1}
menu .m1 -tearoff 0
.m1 add cascade -menu .m2 -label test
@@ -68,14 +60,14 @@ test unixMenu-4.2 {TkpConfigureMenuEntry - cascade entry} {
test unixMenu-5.1 {TkpMenuNewEntry - nothing to do} {} {}
-test unixMenu-6.1 {TkpSetWindowMenuBar - null menu} {
+test unixMenu-6.1 {TkpSetWindowMenuBar - null menu} unix {
catch {destroy .m1}
menu .m1
.m1 add cascade -label foo
. configure -menu .m1
list [catch {. configure -menu ""} msg] $msg [destroy .m1]
} {0 {} {}}
-test unixMenu-6.2 {TkpSetWindowMenuBar - menu} {
+test unixMenu-6.2 {TkpSetWindowMenuBar - menu} unix {
catch {destroy .m1}
menu .m1
.m1 add cascade -label foo
@@ -84,19 +76,19 @@ test unixMenu-6.2 {TkpSetWindowMenuBar - menu} {
test unixMenu-7.1 {TkpSetMainMenubar - nothing to do} {} {}
-test unixMenu-8.1 {GetMenuIndicatorGeometry - indicator off} {
+test unixMenu-8.1 {GetMenuIndicatorGeometry - indicator off} unix {
catch {destroy .m1}
menu .m1
.m1 add checkbutton -label foo -indicatoron 0
list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1]
} {0 {}}
-test unixMenu-8.2 {GetMenuIndicatorGeometry - not checkbutton or radio} {
+test unixMenu-8.2 {GetMenuIndicatorGeometry - not checkbutton or radio} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label foo
list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1]
} {0 {}}
-test unixMenu-8.3 {GetMenuIndicatorGeometry - checkbutton image} {
+test unixMenu-8.3 {GetMenuIndicatorGeometry - checkbutton image} {unix testImageType} {
catch {destroy .m1}
catch {image delete image1}
menu .m1
@@ -105,21 +97,21 @@ test unixMenu-8.3 {GetMenuIndicatorGeometry - checkbutton image} {
.m1 invoke foo
list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] [image delete image1]
} {0 {} {}}
-test unixMenu-8.4 {GetMenuIndicatorGeometry - checkbutton bitmap} {
+test unixMenu-8.4 {GetMenuIndicatorGeometry - checkbutton bitmap} unix {
catch {destroy .m1}
menu .m1
.m1 add checkbutton -bitmap questhead -label foo
.m1 invoke foo
list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1]
} {0 {}}
-test unixMenu-8.5 {GetMenuIndicatorGeometry - checkbutton} {
+test unixMenu-8.5 {GetMenuIndicatorGeometry - checkbutton} unix {
catch {destroy .m1}
menu .m1
.m1 add checkbutton -label foo
.m1 invoke foo
list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1]
} {0 {}}
-test unixMenu-8.6 {GetMenuIndicatorGeometry - radiobutton image} {
+test unixMenu-8.6 {GetMenuIndicatorGeometry - radiobutton image} {unix testImageType} {
catch {destroy .m1}
catch {image delete image1}
menu .m1
@@ -128,21 +120,21 @@ test unixMenu-8.6 {GetMenuIndicatorGeometry - radiobutton image} {
.m1 invoke foo
list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] [image delete image1]
} {0 {} {}}
-test unixMenu-8.7 {GetMenuIndicatorGeometry - radiobutton bitmap} {
+test unixMenu-8.7 {GetMenuIndicatorGeometry - radiobutton bitmap} unix {
catch {destroy .m1}
menu .m1
.m1 add radiobutton -bitmap questhead -label foo
.m1 invoke foo
list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1]
} {0 {}}
-test unixMenu-8.8 {GetMenuIndicatorGeometry - radiobutton} {
+test unixMenu-8.8 {GetMenuIndicatorGeometry - radiobutton} unix {
catch {destroy .m1}
menu .m1
.m1 add radiobutton -label foo
.m1 invoke foo
list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1]
} {0 {}}
-test unixMenu-8.9 {GetMenuIndicatorGeometry - hideMargin} {
+test unixMenu-8.9 {GetMenuIndicatorGeometry - hideMargin} unix {
catch {destroy .m1}
menu .m1
.m1 add radiobutton -label foo -hidemargin 1
@@ -150,26 +142,26 @@ test unixMenu-8.9 {GetMenuIndicatorGeometry - hideMargin} {
list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1]
} {0 {}}
-test unixMenu-9.1 {GetMenuAccelGeometry - cascade entry} {
+test unixMenu-9.1 {GetMenuAccelGeometry - cascade entry} unix {
catch {destroy .m1}
menu .m1
.m1 add cascade -label foo
list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1]
} {0 {}}
-test unixMenu-9.2 {GetMenuAccelGeometry - non-null label} {
+test unixMenu-9.2 {GetMenuAccelGeometry - non-null label} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label foo -accel "Ctrl+S"
list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1]
} {0 {}}
-test unixMenu-9.3 {GetMenuAccelGeometry - null label} {
+test unixMenu-9.3 {GetMenuAccelGeometry - null label} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label foo
list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1]
} {0 {}}
-test unixMenu-10.1 {DrawMenuEntryBackground - active menubar} {
+test unixMenu-10.1 {DrawMenuEntryBackground - active menubar} unix {
catch {destroy .m1}
menu .m1
.m1 add cascade -label foo
@@ -177,7 +169,7 @@ test unixMenu-10.1 {DrawMenuEntryBackground - active menubar} {
.m1 activate 1
list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
} {0 {} {} {}}
-test unixMenu-10.2 {DrawMenuEntryBackground - active} {
+test unixMenu-10.2 {DrawMenuEntryBackground - active} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label foo
@@ -185,7 +177,7 @@ test unixMenu-10.2 {DrawMenuEntryBackground - active} {
$tearoff activate 0
list [catch {update} msg] $msg [destroy .m1]
} {0 {} {}}
-test unixMenu-10.3 {DrawMenuEntryBackground - non-active} {
+test unixMenu-10.3 {DrawMenuEntryBackground - non-active} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label foo
@@ -193,7 +185,7 @@ test unixMenu-10.3 {DrawMenuEntryBackground - non-active} {
list [catch {update} msg] $msg [destroy .m1]
} {0 {} {}}
-test unixMenu-11.1 {DrawMenuEntryAccelerator - menubar} {
+test unixMenu-11.1 {DrawMenuEntryAccelerator - menubar} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label foo -accel "Ctrl+U"
@@ -201,21 +193,21 @@ test unixMenu-11.1 {DrawMenuEntryAccelerator - menubar} {
list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
} {0 {} {} {}}
# drawArrow parameter is never false under Unix
-test unixMenu-11.2 {DrawMenuEntryAccelerator - cascade entry} {
+test unixMenu-11.2 {DrawMenuEntryAccelerator - cascade entry} unix {
catch {destroy .m1}
menu .m1
.m1 add cascade -label foo
set tearoff [tk::TearOffMenu .m1 40 40]
list [catch {update} msg] $msg [destroy .m1]
} {0 {} {}}
-test unixMenu-11.3 {DrawMenuEntryAccelerator - normal entry} {
+test unixMenu-11.3 {DrawMenuEntryAccelerator - normal entry} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label foo -accel "Ctrl+U"
set tearoff [tk::TearOffMenu .m1 40 40]
list [catch {update} msg] $msg [destroy .m1]
} {0 {} {}}
-test unixMenu-11.4 {DrawMenuEntryAccelerator - null entry} {
+test unixMenu-11.4 {DrawMenuEntryAccelerator - null entry} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label foo
@@ -223,28 +215,28 @@ test unixMenu-11.4 {DrawMenuEntryAccelerator - null entry} {
list [catch {update} msg] $msg [destroy .m1]
} {0 {} {}}
-test unixMenu-12.1 {DrawMenuEntryIndicator - non-check or radio} {
+test unixMenu-12.1 {DrawMenuEntryIndicator - non-check or radio} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label foo
set tearoff [tk::TearOffMenu .m1 40 40]
list [catch {update} msg] $msg [destroy .m1]
} {0 {} {}}
-test unixMenu-12.2 {DrawMenuEntryIndicator - checkbutton - indicator off} {
+test unixMenu-12.2 {DrawMenuEntryIndicator - checkbutton - indicator off} unix {
catch {destroy .m1}
menu .m1
.m1 add checkbutton -label foo -indicatoron 0
set tearoff [tk::TearOffMenu .m1 40 40]
list [catch {update} msg] $msg [destroy .m1]
} {0 {} {}}
-test unixMenu-12.3 {DrawMenuEntryIndicator - checkbutton - not selected} {
+test unixMenu-12.3 {DrawMenuEntryIndicator - checkbutton - not selected} unix {
catch {destroy .m1}
menu .m1
.m1 add checkbutton -label foo
set tearoff [tk::TearOffMenu .m1 40 40]
list [catch {update} msg] $msg [destroy .m1]
} {0 {} {}}
-test unixMenu-12.4 {DrawMenuEntryIndicator - checkbutton - selected} {
+test unixMenu-12.4 {DrawMenuEntryIndicator - checkbutton - selected} unix {
catch {destroy .m1}
menu .m1
.m1 add checkbutton -label foo
@@ -252,21 +244,21 @@ test unixMenu-12.4 {DrawMenuEntryIndicator - checkbutton - selected} {
set tearoff [tk::TearOffMenu .m1 40 40]
list [catch {update} msg] $msg [destroy .m1]
} {0 {} {}}
-test unixMenu-12.5 {DrawMenuEntryIndicator - radiobutton - indicator off} {
+test unixMenu-12.5 {DrawMenuEntryIndicator - radiobutton - indicator off} unix {
catch {destroy .m1}
menu .m1
.m1 add radiobutton -label foo -indicatoron 0
set tearoff [tk::TearOffMenu .m1 40 40]
list [catch {update} msg] $msg [destroy .m1]
} {0 {} {}}
-test unixMenu-12.6 {DrawMenuEntryIndicator - radiobutton - not selected} {
+test unixMenu-12.6 {DrawMenuEntryIndicator - radiobutton - not selected} unix {
catch {destroy .m1}
menu .m1
.m1 add radiobutton -label foo
set tearoff [tk::TearOffMenu .m1 40 40]
list [catch {update} msg] $msg [destroy .m1]
} {0 {} {}}
-test unixMenu-12.7 {DrawMenuEntryIndicator - radiobutton - selected} {
+test unixMenu-12.7 {DrawMenuEntryIndicator - radiobutton - selected} unix {
catch {destroy .m1}
menu .m1
.m1 add radiobutton -label foo
@@ -275,14 +267,14 @@ test unixMenu-12.7 {DrawMenuEntryIndicator - radiobutton - selected} {
list [catch {update} msg] $msg [destroy .m1]
} {0 {} {}}
-test unixMenu-13.1 {DrawMenuSeparator - menubar case} {
+test unixMenu-13.1 {DrawMenuSeparator - menubar case} unix {
catch {destroy .m1}
menu .m1
.m1 add separator
. configure -menu .m1
list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
} {0 {} {} {}}
-test unixMenu-13.2 {DrawMenuSepartor - normal menu} {
+test unixMenu-13.2 {DrawMenuSepartor - normal menu} unix {
catch {destroy .m1}
menu .m1
.m1 add separator
@@ -290,7 +282,7 @@ test unixMenu-13.2 {DrawMenuSepartor - normal menu} {
list [catch {update} msg] $msg [destroy .m1]
} {0 {} {}}
-test unixMenu-14.1 {DrawMenuEntryLabel} {
+test unixMenu-14.1 {DrawMenuEntryLabel} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label foo
@@ -298,14 +290,14 @@ test unixMenu-14.1 {DrawMenuEntryLabel} {
list [catch {update} msg] $msg [destroy .m1]
} {0 {} {}}
-test unixMenu-15.1 {DrawMenuUnderline - menubar} {
+test unixMenu-15.1 {DrawMenuUnderline - menubar} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label foo -underline 0
. configure -menu .m1
list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
} {0 {} {} {}}
-test unixMenu-15.2 {DrawMenuUnderline - no menubar} {
+test unixMenu-15.2 {DrawMenuUnderline - no menubar} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label foo -underline 0
@@ -313,21 +305,21 @@ test unixMenu-15.2 {DrawMenuUnderline - no menubar} {
list [catch {update} msg] $msg [destroy .m1]
} {0 {} {}}
-test unixMenu-16.1 {TkpPostMenu} {
+test unixMenu-16.1 {TkpPostMenu} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label foo
list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1]
} {0 {}}
-test unixMenu-17.1 {GetMenuSeparatorGeometry} {
+test unixMenu-17.1 {GetMenuSeparatorGeometry} unix {
catch {destroy .m1}
menu .m1
.m1 add separator
list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1]
} {0 {}}
-test unixMenu-18.1 {GetTearoffEntryGeometry} {
+test unixMenu-18.1 {GetTearoffEntryGeometry} unix {
catch {destroy .m1}
menubutton .mb -text "test" -menu .mb.m
menu .mb.m
@@ -338,42 +330,42 @@ test unixMenu-18.1 {GetTearoffEntryGeometry} {
} {0 {} {} {}}
# Don't know how to reproduce the case where the tkwin has been deleted.
-test unixMenu-19.1 {TkpComputeMenubarGeometry - zero entries} {
+test unixMenu-19.1 {TkpComputeMenubarGeometry - zero entries} unix {
catch {destroy .m1}
menu .m1
. configure -menu .m1
list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
} {0 {} {} {}}
# Don't know how to generate one width windows
-test unixMenu-19.2 {TkpComputeMenubarGeometry - one entry} {
+test unixMenu-19.2 {TkpComputeMenubarGeometry - one entry} unix {
catch {destroy .m1}
menu .m1
.m1 add cascade -label File
. configure -menu .m1
list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
} {0 {} {} {}}
-test unixMenu-19.3 {TkpComputeMenubarGeometry - entry with different font} {
+test unixMenu-19.3 {TkpComputeMenubarGeometry - entry with different font} unix {
catch {destroy .m1}
menu .m1 -font "Courier 24"
.m1 add cascade -label File -font "Helvetica 18"
. configure -menu .m1
list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
} {0 {} {} {}}
-test unixMenu-19.4 {TkpComputeMenubarGeometry - separator} {
+test unixMenu-19.4 {TkpComputeMenubarGeometry - separator} unix {
catch {destroy .m1}
menu .m1
.m1 add separator
. configure -menu .m1
list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
} {0 {} {} {}}
-test unixMenu-19.5 {TkpComputeMenubarGeometry - First entry} {
+test unixMenu-19.5 {TkpComputeMenubarGeometry - First entry} unix {
catch {destroy .m1}
menu .m1 -tearoff 0
.m1 add cascade -label File
. configure -menu .m1
list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
} {0 {} {} {}}
-test unixMenu-19.6 {TkpComputeMenubarGeometry - First entry too wide} {
+test unixMenu-19.6 {TkpComputeMenubarGeometry - First entry too wide} unix {
catch {destroy .m1}
menu .m1 -tearoff 0
.m1 add cascade -label File -font "Times 72"
@@ -381,7 +373,7 @@ test unixMenu-19.6 {TkpComputeMenubarGeometry - First entry too wide} {
wm geometry . 10x10
list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
} {0 {} {} {}}
-test unixMenu-19.7 {TkpComputeMenubarGeometry - two entries fit} {
+test unixMenu-19.7 {TkpComputeMenubarGeometry - two entries fit} unix {
catch {destroy .m1}
menu .m1 -tearoff 0
.m1 add cascade -label File
@@ -390,7 +382,7 @@ test unixMenu-19.7 {TkpComputeMenubarGeometry - two entries fit} {
wm geometry . 200x200
list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
} {0 {} {} {}}
-test unixMenu-19.8 {TkpComputeMenubarGeometry - two entries; 2nd don't fit} {
+test unixMenu-19.8 {TkpComputeMenubarGeometry - two entries; 2nd don't fit} unix {
catch {destroy .m1}
menu .m1 -tearoff 0
.m1 add cascade -label File
@@ -399,7 +391,7 @@ test unixMenu-19.8 {TkpComputeMenubarGeometry - two entries; 2nd don't fit} {
wm geometry . 100x100
list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
} {0 {} {} {}}
-test unixMenu-19.9 {TkpComputeMenubarGeometry - two entries; 1st dont fit} {
+test unixMenu-19.9 {TkpComputeMenubarGeometry - two entries; 1st dont fit} unix {
catch {destroy .m1}
menu .m1 -tearoff 0
.m1 add cascade -label File -font "Times 72"
@@ -408,7 +400,7 @@ test unixMenu-19.9 {TkpComputeMenubarGeometry - two entries; 1st dont fit} {
wm geometry . 100x100
list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
} {0 {} {} {}}
-test unixMenu-19.10 {TkpComputeMenubarGeometry - two entries; neither fit} {
+test unixMenu-19.10 {TkpComputeMenubarGeometry - two entries; neither fit} unix {
catch {destroy .m1}
menu .m1 -tearoff 0 -font "Times 72"
.m1 add cascade -label File
@@ -419,7 +411,7 @@ test unixMenu-19.10 {TkpComputeMenubarGeometry - two entries; neither fit} {
} {0 {} {} {}}
# ABC notation; capital A means first window fits, small a means it
# does not. capital B menu means second window fist, etc.
-test unixMenu-19.11 {TkpComputeMenubarGeometry - abc} {
+test unixMenu-19.11 {TkpComputeMenubarGeometry - abc} unix {
catch {destroy .m1}
menu .m1 -tearoff 0 -font "Times 72"
.m1 add cascade -label "aaaaa"
@@ -429,7 +421,7 @@ test unixMenu-19.11 {TkpComputeMenubarGeometry - abc} {
wm geometry . 10x10
list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
} {0 {} {} {}}
-test unixMenu-19.12 {TkpComputeMenubarGeometry - abC} {
+test unixMenu-19.12 {TkpComputeMenubarGeometry - abC} unix {
catch {destroy .m1}
menu .m1 -tearoff 0
.m1 add cascade -label "aaaaa" -font "Times 72"
@@ -439,7 +431,7 @@ test unixMenu-19.12 {TkpComputeMenubarGeometry - abC} {
wm geometry . 10x10
list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
} {0 {} {} {}}
-test unixMenu-19.13 {TkpComputeMenubarGeometry - aBc} {
+test unixMenu-19.13 {TkpComputeMenubarGeometry - aBc} unix {
catch {destroy .m1}
menu .m1 -tearoff 0
.m1 add cascade -label "aaaaa" -font "Times 72"
@@ -449,7 +441,7 @@ test unixMenu-19.13 {TkpComputeMenubarGeometry - aBc} {
wm geometry . 10x10
list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
} {0 {} {} {}}
-test unixMenu-19.14 {TkpComputeMenubarGeometry - aBC} {
+test unixMenu-19.14 {TkpComputeMenubarGeometry - aBC} unix {
catch {destroy .m1}
menu .m1 -tearoff 0
.m1 add cascade -label "aaaaa" -font "Times 72"
@@ -459,7 +451,7 @@ test unixMenu-19.14 {TkpComputeMenubarGeometry - aBC} {
wm geometry . 60x10
list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
} {0 {} {} {}}
-test unixMenu-19.15 {TkpComputeMenubarGeometry - Abc} {
+test unixMenu-19.15 {TkpComputeMenubarGeometry - Abc} unix {
catch {destroy .m1}
menu .m1 -tearoff 0
.m1 add cascade -label "A"
@@ -469,7 +461,7 @@ test unixMenu-19.15 {TkpComputeMenubarGeometry - Abc} {
wm geometry . 60x10
list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
} {0 {} {} {}}
-test unixMenu-19.16 {TkpComputeMenubarGeometry - AbC} {
+test unixMenu-19.16 {TkpComputeMenubarGeometry - AbC} unix {
catch {destroy .m1}
menu .m1 -tearoff 0
.m1 add cascade -label "A"
@@ -479,7 +471,7 @@ test unixMenu-19.16 {TkpComputeMenubarGeometry - AbC} {
wm geometry . 60x10
list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
} {0 {} {} {}}
-test unixMenu-19.17 {TkpComputeMenubarGeometry - ABc} {
+test unixMenu-19.17 {TkpComputeMenubarGeometry - ABc} unix {
catch {destroy .m1}
menu .m1 -tearoff 0
.m1 add cascade -label "A"
@@ -489,7 +481,7 @@ test unixMenu-19.17 {TkpComputeMenubarGeometry - ABc} {
wm geometry . 60x10
list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
} {0 {} {} {}}
-test unixMenu-19.18 {TkpComputeMenubarGeometry - ABC} {
+test unixMenu-19.18 {TkpComputeMenubarGeometry - ABC} unix {
catch {destroy .m1}
menu .m1 -tearoff 0
.m1 add cascade -label "A"
@@ -499,7 +491,7 @@ test unixMenu-19.18 {TkpComputeMenubarGeometry - ABC} {
wm geometry . 100x10
list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
} {0 {} {} {}}
-test unixMenu-19.19 {TkpComputeMenubarGeometry - help menu in first position} {
+test unixMenu-19.19 {TkpComputeMenubarGeometry - help menu in first position} unix {
catch {destroy .m1}
menu .m1 -tearoff 0
.m1 add cascade -label Help -menu .m1.help
@@ -512,7 +504,7 @@ test unixMenu-19.19 {TkpComputeMenubarGeometry - help menu in first position} {
wm geometry . 100x10
list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
} {0 {} {} {}}
-test unixMenu-19.20 {TkpComputeMenubarGeometry - help menu in middle} {
+test unixMenu-19.20 {TkpComputeMenubarGeometry - help menu in middle} unix {
catch {destroy .m1}
menu .m1 -tearoff 0
.m1 add cascade -label Edit -menu .m1.edit
@@ -525,7 +517,7 @@ test unixMenu-19.20 {TkpComputeMenubarGeometry - help menu in middle} {
wm geometry . 100x10
list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
} {0 {} {} {}}
-test unixMenu-19.21 {TkpComputeMenubarGeometry - help menu in first position} {
+test unixMenu-19.21 {TkpComputeMenubarGeometry - help menu in first position} unix {
catch {destroy .m1}
menu .m1 -tearoff 0
.m1 add cascade -label File -menu .m1.file
@@ -538,7 +530,7 @@ test unixMenu-19.21 {TkpComputeMenubarGeometry - help menu in first position} {
wm geometry . 100x10
list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
} {0 {} {} {}}
-test unixMenu-19.22 {TkpComputeMenubarGeometry - help item fits} {
+test unixMenu-19.22 {TkpComputeMenubarGeometry - help item fits} unix {
catch {destroy .m1}
menu .m1 -tearoff 0
.m1 add cascade -label File -menu .m1.file
@@ -549,7 +541,7 @@ test unixMenu-19.22 {TkpComputeMenubarGeometry - help item fits} {
wm geometry . 100x10
list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
} {0 {} {} {}}
-test unixMenu-19.23 {TkpComputeMenubarGeometry - help item does not fit} {
+test unixMenu-19.23 {TkpComputeMenubarGeometry - help item does not fit} unix {
catch {destroy .m1}
menu .m1 -tearoff 0
.m1 add cascade -label File -menu .m1.file
@@ -560,7 +552,7 @@ test unixMenu-19.23 {TkpComputeMenubarGeometry - help item does not fit} {
wm geometry . 100x10
list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
} {0 {} {} {}}
-test unixMenu-19.24 {TkpComputeMenubarGeometry - help item only one} {
+test unixMenu-19.24 {TkpComputeMenubarGeometry - help item only one} unix {
catch {destroy .m1}
menu .m1 -tearoff 0
.m1 add cascade -label Help -menu .m1.help
@@ -570,14 +562,14 @@ test unixMenu-19.24 {TkpComputeMenubarGeometry - help item only one} {
list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
} {0 {} {} {}}
-test unixMenu-20.1 {DrawTearoffEntry - menubar} {
+test unixMenu-20.1 {DrawTearoffEntry - menubar} unix {
catch {destroy .m1}
menu .m1
.m1 add cascade -label File
. configure -menu .m1
list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
} {0 {} {} {}}
-test unixMenu-20.2 {DrawTearoffEntry - non-menubar} {
+test unixMenu-20.2 {DrawTearoffEntry - non-menubar} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label foo
@@ -587,28 +579,28 @@ test unixMenu-20.2 {DrawTearoffEntry - non-menubar} {
test unixMenu-21.1 {TkpInitializeMenuBindings - nothing to do} {} {}
-test unixMenu-22.1 {SetHelpMenu - no menubars} {
+test unixMenu-22.1 {SetHelpMenu - no menubars} unix {
catch {destroy .m1}
menu .m1 -tearoff 0
.m1 add cascade -label test -menu .m1.test
list [catch {menu .m1.test} msg] $msg [destroy .m1]
} {0 .m1.test {}}
# Don't know how to automate missing tkwins
-test unixMenu-22.2 {SetHelpMenu - menubar but no help menu} {
+test unixMenu-22.2 {SetHelpMenu - menubar but no help menu} unix {
catch {destroy .m1}
menu .m1 -tearoff 0
. configure -menu .m1
.m1 add cascade -label .m1.file
list [catch {menu .m1.file} msg] $msg [. configure -menu ""] [destroy .m1]
} {0 .m1.file {} {}}
-test unixMenu-22.3 {SetHelpMenu - menubar with help menu} {
+test unixMenu-22.3 {SetHelpMenu - menubar with help menu} unix {
catch {destroy .m1}
menu .m1 -tearoff 0
. configure -menu .m1
.m1 add cascade -label .m1.help
list [catch {menu .m1.help} msg] $msg [. configure -menu ""] [destroy .m1]
} {0 .m1.help {} {}}
-test unixMenu-22.4 {SetHelpMenu - multiple menubars with same help menu} {
+test unixMenu-22.4 {SetHelpMenu - multiple menubars with same help menu} unix {
catch {destroy .m1}
catch {destroy .t2}
toplevel .t2
@@ -620,7 +612,7 @@ test unixMenu-22.4 {SetHelpMenu - multiple menubars with same help menu} {
list [catch {menu .m1.help} msg] $msg [. configure -menu ""] [destroy .m1] [destroy .t2]
} {0 .m1.help {} {} {}}
-test unixMenu-23.1 {TkpDrawMenuEntry - gc for active and not strict motif} {
+test unixMenu-23.1 {TkpDrawMenuEntry - gc for active and not strict motif} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label foo
@@ -628,7 +620,7 @@ test unixMenu-23.1 {TkpDrawMenuEntry - gc for active and not strict motif} {
.m1 entryconfigure 1 -state active
list [update] [destroy .m1]
} {{} {}}
-test unixMenu-23.2 {TkpDrawMenuEntry - gc for active menu item with its own gc} {
+test unixMenu-23.2 {TkpDrawMenuEntry - gc for active menu item with its own gc} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label foo -activeforeground red
@@ -636,7 +628,7 @@ test unixMenu-23.2 {TkpDrawMenuEntry - gc for active menu item with its own gc}
.m1 entryconfigure 1 -state active
list [update] [destroy .m1]
} {{} {}}
-test unixMenu-23.3 {TkpDrawMenuEntry - gc for active and strict motif} {
+test unixMenu-23.3 {TkpDrawMenuEntry - gc for active and strict motif} unix {
catch {destroy .m1}
menu .m1
set tk_strictMotif 1
@@ -645,42 +637,42 @@ test unixMenu-23.3 {TkpDrawMenuEntry - gc for active and strict motif} {
.m1 entryconfigure 1 -state active
list [update] [destroy .m1] [set tk_strictMotif 0]
} {{} {} 0}
-test unixMenu-23.4 {TkpDrawMenuEntry - gc for disabled with disabledfg and custom entry} {
+test unixMenu-23.4 {TkpDrawMenuEntry - gc for disabled with disabledfg and custom entry} unix {
catch {destroy .m1}
menu .m1 -disabledforeground blue
.m1 add command -label foo -state disabled -background red
set tearoff [tk::TearOffMenu .m1 40 40]
list [update] [destroy .m1]
} {{} {}}
-test unixMenu-23.5 {TkpDrawMenuEntry - gc for disabled with disabledFg} {
+test unixMenu-23.5 {TkpDrawMenuEntry - gc for disabled with disabledFg} unix {
catch {destroy .m1}
menu .m1 -disabledforeground blue
.m1 add command -label foo -state disabled
set tearoff [tk::TearOffMenu .m1 40 40]
list [update] [destroy .m1]
} {{} {}}
-test unixMenu-23.6 {TkpDrawMenuEntry - gc for disabled - no disabledFg} {
+test unixMenu-23.6 {TkpDrawMenuEntry - gc for disabled - no disabledFg} unix {
catch {destroy .m1}
menu .m1 -disabledforeground ""
.m1 add command -label foo -state disabled
set tearoff [tk::TearOffMenu .m1 40 40]
list [update] [destroy .m1]
} {{} {}}
-test unixMenu-23.7 {TkpDrawMenuEntry - gc for normal - custom entry} {
+test unixMenu-23.7 {TkpDrawMenuEntry - gc for normal - custom entry} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label foo -foreground red
set tearoff [tk::TearOffMenu .m1 40 40]
list [update] [destroy .m1]
} {{} {}}
-test unixMenu-23.8 {TkpDrawMenuEntry - gc for normal} {
+test unixMenu-23.8 {TkpDrawMenuEntry - gc for normal} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label foo
set tearoff [tk::TearOffMenu .m1 40 40]
list [update] [destroy .m1]
} {{} {}}
-test unixMenu-23.9 {TkpDrawMenuEntry - gc for indicator - custom entry} {
+test unixMenu-23.9 {TkpDrawMenuEntry - gc for indicator - custom entry} unix {
catch {destroy .m1}
menu .m1
.m1 add checkbutton -label foo -selectcolor orange
@@ -688,7 +680,7 @@ test unixMenu-23.9 {TkpDrawMenuEntry - gc for indicator - custom entry} {
set tearoff [tk::TearOffMenu .m1 40 40]
list [update] [destroy .m1]
} {{} {}}
-test unixMenu-23.10 {TkpDrawMenuEntry - gc for indicator} {
+test unixMenu-23.10 {TkpDrawMenuEntry - gc for indicator} unix {
catch {destroy .m1}
menu .m1
.m1 add checkbutton -label foo
@@ -696,7 +688,7 @@ test unixMenu-23.10 {TkpDrawMenuEntry - gc for indicator} {
set tearoff [tk::TearOffMenu .m1 40 40]
list [update] [destroy .m1]
} {{} {}}
-test unixMenu-23.11 {TkpDrawMenuEntry - border - custom entry} {
+test unixMenu-23.11 {TkpDrawMenuEntry - border - custom entry} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label foo -activebackground green
@@ -704,7 +696,7 @@ test unixMenu-23.11 {TkpDrawMenuEntry - border - custom entry} {
.m1 entryconfigure 1 -state active
list [update] [destroy .m1]
} {{} {}}
-test unixMenu-23.12 {TkpDrawMenuEntry - border} {
+test unixMenu-23.12 {TkpDrawMenuEntry - border} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label foo
@@ -712,7 +704,7 @@ test unixMenu-23.12 {TkpDrawMenuEntry - border} {
.m1 entryconfigure 1 -state active
list [update] [destroy .m1]
} {{} {}}
-test unixMenu-23.13 {TkpDrawMenuEntry - active border - strict motif} {
+test unixMenu-23.13 {TkpDrawMenuEntry - active border - strict motif} unix {
catch {destroy .m1}
set tk_strictMotif 1
menu .m1
@@ -721,7 +713,7 @@ test unixMenu-23.13 {TkpDrawMenuEntry - active border - strict motif} {
.m1 entryconfigure 1 -state active
list [update] [destroy .m1] [set tk_strictMotif 0]
} {{} {} 0}
-test unixMenu-23.14 {TkpDrawMenuEntry - active border - custom entry} {
+test unixMenu-23.14 {TkpDrawMenuEntry - active border - custom entry} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label foo -activeforeground yellow
@@ -729,7 +721,7 @@ test unixMenu-23.14 {TkpDrawMenuEntry - active border - custom entry} {
.m1 entryconfigure 1 -state active
list [update] [destroy .m1]
} {{} {}}
-test unixMenu-23.15 {TkpDrawMenuEntry - active border} {
+test unixMenu-23.15 {TkpDrawMenuEntry - active border} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label foo
@@ -737,35 +729,35 @@ test unixMenu-23.15 {TkpDrawMenuEntry - active border} {
.m1 entryconfigure 1 -state active
list [update] [destroy .m1]
} {{} {}}
-test unixMenu-23.16 {TkpDrawMenuEntry - font - custom entry} {
+test unixMenu-23.16 {TkpDrawMenuEntry - font - custom entry} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label foo -font "Helvectica 72"
set tearoff [tk::TearOffMenu .m1 40 40]
list [update] [destroy .m1]
} {{} {}}
-test unixMenu-23.17 {TkpDrawMenuEntry - font} {
+test unixMenu-23.17 {TkpDrawMenuEntry - font} unix {
catch {destroy .m1}
menu .m1 -font "Courier 72"
.m1 add command -label foo
set tearoff [tk::TearOffMenu .m1 40 40]
list [update] [destroy .m1]
} {{} {}}
-test unixMenu-23.18 {TkpDrawMenuEntry - separator} {
+test unixMenu-23.18 {TkpDrawMenuEntry - separator} unix {
catch {destroy .m1}
menu .m1
.m1 add separator
set tearoff [tk::TearOffMenu .m1 40 40]
list [update] [destroy .m1]
} {{} {}}
-test unixMenu-23.19 {TkpDrawMenuEntry - standard} {
+test unixMenu-23.19 {TkpDrawMenuEntry - standard} unix {
catch {destroy .mb}
menu .m1
.m1 add command -label foo
set tearoff [tk::TearOffMenu .m1 40 40]
list [update] [destroy .m1]
} {{} {}}
-test unixMenu-23.20 {TkpDrawMenuEntry - disabled cascade item} {
+test unixMenu-23.20 {TkpDrawMenuEntry - disabled cascade item} unix {
catch {destroy .m1}
menu .m1
.m1 add cascade -label File -menu .m1.file
@@ -775,7 +767,7 @@ test unixMenu-23.20 {TkpDrawMenuEntry - disabled cascade item} {
set tearoff [tk::TearOffMenu .m1 40 40]
list [update] [destroy .m1]
} {{} {}}
-test unixMenu-23.21 {TkpDrawMenuEntry - indicator} {
+test unixMenu-23.21 {TkpDrawMenuEntry - indicator} unix {
catch {destroy .m1}
menu .m1
.m1 add checkbutton -label Foo
@@ -783,7 +775,7 @@ test unixMenu-23.21 {TkpDrawMenuEntry - indicator} {
set tearoff [tk::TearOffMenu .m1 40 40]
list [update] [destroy .m1]
} {{} {}}
-test unixMenu-23.22 {TkpDrawMenuEntry - hide margin} {
+test unixMenu-23.22 {TkpDrawMenuEntry - hide margin} unix {
catch {destroy .m1}
menu .m1
.m1 add checkbutton -label Foo -hidemargin 1
@@ -792,7 +784,7 @@ test unixMenu-23.22 {TkpDrawMenuEntry - hide margin} {
list [update] [destroy .m1]
} {{} {}}
-test unixMenu-24.1 {GetMenuLabelGeometry - image} {
+test unixMenu-24.1 {GetMenuLabelGeometry - image} {testImageType unix} {
catch {destroy .m1}
catch {image delete image1}
menu .m1
@@ -800,44 +792,44 @@ test unixMenu-24.1 {GetMenuLabelGeometry - image} {
.m1 add command -image image1
list [update idletasks] [destroy .m1] [image delete image1]
} {{} {} {}}
-test unixMenu-24.2 {GetMenuLabelGeometry - bitmap} {
+test unixMenu-24.2 {GetMenuLabelGeometry - bitmap} unix {
catch {destroy .m1}
menu .m1
.m1 add command -bitmap questhead
list [update idletasks] [destroy .m1]
} {{} {}}
-test unixMenu-24.3 {GetMenuLabelGeometry - no text} {
+test unixMenu-24.3 {GetMenuLabelGeometry - no text} unix {
catch {destroy .m1}
menu .m1
.m1 add command
list [update idletasks] [destroy .m1]
} {{} {}}
-test unixMenu-24.4 {GetMenuLabelGeometry - text} {
+test unixMenu-24.4 {GetMenuLabelGeometry - text} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label "This is a test."
list [update idletasks] [destroy .m1]
} {{} {}}
-test unixMenu-25.1 {TkpComputeStandardMenuGeometry - no entries} {
+test unixMenu-25.1 {TkpComputeStandardMenuGeometry - no entries} unix {
catch {destroy .m1}
menu .m1
list [update idletasks] [destroy .m1]
} {{} {}}
-test unixMenu-25.2 {TkpComputeStandardMenuGeometry - one entry} {
+test unixMenu-25.2 {TkpComputeStandardMenuGeometry - one entry} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label "one"
list [update idletasks] [destroy .m1]
} {{} {}}
-test unixMenu-25.3 {TkpComputeStandardMenuGeometry - more than one entry} {
+test unixMenu-25.3 {TkpComputeStandardMenuGeometry - more than one entry} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label "one"
.m1 add command -label "two"
list [update idletasks] [destroy .m1]
} {{} {}}
-test unixMenu-25.4 {TkpComputeStandardMenuGeometry - separator} {
+test unixMenu-25.4 {TkpComputeStandardMenuGeometry - separator} unix {
catch {destroy .m1}
menu .m1
.m1 add separator
@@ -852,60 +844,60 @@ test unixMenu-25.5 {TkpComputeStandardMenuGeometry - tearoff entry} {unixOnly} {
catch {tk::MbPost .mb}
list [update] [tk::MenuUnpost .mb.m] [destroy .mb]
} {{} {} {}}
-test unixMenu-25.6 {TkpComputeStandardMenuGeometry - standard label geometry} {
+test unixMenu-25.6 {TkpComputeStandardMenuGeometry - standard label geometry} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label "test"
list [update idletasks] [destroy .m1]
} {{} {}}
-test unixMenu-25.7 {TkpComputeStandardMenuGeometry - different font for entry} {
+test unixMenu-25.7 {TkpComputeStandardMenuGeometry - different font for entry} unix {
catch {destroy .m1}
menu .m1 -font "Helvetica 12"
.m1 add command -label "test" -font "Courier 12"
list [update idletasks] [destroy .m1]
} {{} {}}
-test unixMenu-25.8 {TkpComputeStandardMenuGeometry - second entry larger} {
+test unixMenu-25.8 {TkpComputeStandardMenuGeometry - second entry larger} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label "test"
.m1 add command -label "test test"
list [update idletasks] [destroy .m1]
} {{} {}}
-test unixMenu-25.9 {TkpComputeStandardMenuGeometry - first entry larger} {
+test unixMenu-25.9 {TkpComputeStandardMenuGeometry - first entry larger} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label "test test"
.m1 add command -label "test"
list [update idletasks] [destroy .m1]
} {{} {}}
-test unixMenu-25.10 {TkpComputeStandardMenuGeometry - accelerator} {
+test unixMenu-25.10 {TkpComputeStandardMenuGeometry - accelerator} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label "test" -accel "Ctrl+S"
list [update idletasks] [destroy .m1]
} {{} {}}
-test unixMenu-25.11 {TkpComputeStandardMenuGeometry - second accel larger} {
+test unixMenu-25.11 {TkpComputeStandardMenuGeometry - second accel larger} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label "test" -accel "1"
.m1 add command -label "test" -accel "1 1"
list [update idletasks] [destroy .m1]
} {{} {}}
-test unixMenu-25.12 {TkpComputeStandardMenuGeometry - second accel smaller} {
+test unixMenu-25.12 {TkpComputeStandardMenuGeometry - second accel smaller} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label "test" -accel "1 1"
.m1 add command -label "test" -accel "1"
list [update idletasks] [destroy .m1]
} {{} {}}
-test unixMenu-25.13 {TkpComputeStandardMenuGeometry - indicator} {
+test unixMenu-25.13 {TkpComputeStandardMenuGeometry - indicator} unix {
catch {destroy .m1}
menu .m1
.m1 add checkbutton -label test
.m1 invoke 1
list [update idletasks] [destroy .m1]
} {{} {}}
-test unixMenu-25.14 {TkpComputeStandardMenuGeometry - second indicator less or equal } {
+test unixMenu-25.14 {TkpComputeStandardMenuGeometry - second indicator less or equal } {unix testImageType} {
catch {destroy .m1}
catch {image delete image1}
image create test image1
@@ -916,7 +908,7 @@ test unixMenu-25.14 {TkpComputeStandardMenuGeometry - second indicator less or e
.m1 invoke 2
list [update idletasks] [destroy .m1] [image delete image1]
} {{} {} {}}
-test unixMenu-25.15 {TkpComputeStandardMenuGeometry - second indicator larger } {unixOnly} {
+test unixMenu-25.15 {TkpComputeStandardMenuGeometry - second indicator larger } {unixOnly testImageType} {
catch {destroy .m1}
catch {image delete image1}
image create test image1
@@ -927,12 +919,12 @@ test unixMenu-25.15 {TkpComputeStandardMenuGeometry - second indicator larger }
.m1 invoke 2
list [update idletasks] [destroy .m1] [image delete image1]
} {{} {} {}}
-test unixMenu-25.16 {TkpComputeStandardMenuGeometry - zero sized menus} {
+test unixMenu-25.16 {TkpComputeStandardMenuGeometry - zero sized menus} unix {
catch {destroy .m1}
menu .m1 -tearoff 0
list [update idletasks] [destroy .m1]
} {{} {}}
-test unixMenu-25.17 {TkpComputeStandardMenuGeometry - first column bigger} {
+test unixMenu-25.17 {TkpComputeStandardMenuGeometry - first column bigger} unix {
catch {destroy .m1}
menu .m1
.m1 add command -label one
@@ -940,7 +932,7 @@ test unixMenu-25.17 {TkpComputeStandardMenuGeometry - first column bigger} {
.m1 add command -label three -columnbreak 1
list [update idletasks] [destroy .m1]
} {{} {}}
-test unixMenu-25.18 {TkpComputeStandardMenuGeometry - second column bigger} {
+test unixMenu-25.18 {TkpComputeStandardMenuGeometry - second column bigger} unix {
catch {destroy .m1}
menu .m1 -tearoff 0
.m1 add command -label one
@@ -948,7 +940,7 @@ test unixMenu-25.18 {TkpComputeStandardMenuGeometry - second column bigger} {
.m1 add command -label three
list [update idletasks] [destroy .m1]
} {{} {}}
-test unixMenu-25.19 {TkpComputeStandardMenuGeometry - three columns} {
+test unixMenu-25.19 {TkpComputeStandardMenuGeometry - three columns} unix {
catch {destroy .m1}
menu .m1 -tearoff 0
.m1 add command -label one
@@ -959,7 +951,7 @@ test unixMenu-25.19 {TkpComputeStandardMenuGeometry - three columns} {
.m1 add command -label six
list [update idletasks] [destroy .m1]
} {{} {}}
-test unixMenu-25.20 {TkpComputeStandardMenuGeometry - hide margin} {
+test unixMenu-25.20 {TkpComputeStandardMenuGeometry - hide margin} unix {
catch {destroy .m1}
menu .m1 -tearoff 0
.m1 add checkbutton -label one -hidemargin 1
diff --git a/tests/unixSelect.test b/tests/unixSelect.test
index c5ea280..84c4cc4 100644
--- a/tests/unixSelect.test
+++ b/tests/unixSelect.test
@@ -9,17 +9,16 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: unixSelect.test,v 1.2 1999/07/09 02:10:07 stanton Exp $
-
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-
-if {$tcl_platform(platform) != "unix"} {
- puts "skipping: Unix only tests..."
- ::tcltest::cleanupTests
- return
-}
+# RCS: @(#) $Id: unixSelect.test,v 1.3 2002/07/12 13:41:00 dgp Exp $
+
+package require tcltest 2.1
+namespace import -force tcltest::test
+namespace import -force tcltest::testsDirectory
+namespace import -force tcltest::configure
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
+eval configure $argv
eval destroy [winfo child .]
diff --git a/tests/unixWm.test b/tests/unixWm.test
index 64094fd..ddd641b 100644
--- a/tests/unixWm.test
+++ b/tests/unixWm.test
@@ -7,11 +7,17 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: unixWm.test,v 1.19 2002/06/22 10:13:26 hobbs Exp $
-
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
+# RCS: @(#) $Id: unixWm.test,v 1.20 2002/07/12 13:41:00 dgp Exp $
+
+package require tcltest 2.1
+namespace import -force tcltest::test
+namespace import -force tcltest::testsDirectory
+namespace import -force tcltest::configure
+namespace import -force tcltest::interpreter
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
+eval configure $argv
if {$tcl_platform(platform) != "unix"} {
puts "skipping: Unix only tests..."
@@ -2351,7 +2357,7 @@ test unixWm-59.1 {exit processing} {
exit
}
close $fd
- if {[catch {exec $::tcltest::tktest script -geometry 10x10+0+0} msg]} {
+ if {[catch {exec [interpreter] script -geometry 10x10+0+0} msg]} {
set error 1
} else {
set error 0
@@ -2370,7 +2376,7 @@ test unixWm-59.2 {exit processing} {
exit
}
close $fd
- if {[catch {exec $::tcltest::tktest script -geometry 10x10+0+0} msg]} {
+ if {[catch {exec [interpreter] script -geometry 10x10+0+0} msg]} {
set error 1
} else {
set error 0
@@ -2395,7 +2401,7 @@ test unixWm-59.3 {exit processing} {
exit
}
close $fd
- if {[catch {exec $::tcltest::tktest script -geometry 10x10+0+0} msg]} {
+ if {[catch {exec [interpreter] script -geometry 10x10+0+0} msg]} {
set error 1
} else {
set error 0
diff --git a/tests/util.test b/tests/util.test
index d3d5c91..bf89528 100644
--- a/tests/util.test
+++ b/tests/util.test
@@ -6,11 +6,11 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: util.test,v 1.3 1999/04/16 01:51:42 stanton Exp $
+# RCS: @(#) $Id: util.test,v 1.4 2002/07/12 13:41:00 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::test
+eval tcltest::configure $argv
foreach i [winfo children .] {
destroy $i
diff --git a/tests/visual.test b/tests/visual.test
index 8614c2d..6863abf 100644
--- a/tests/visual.test
+++ b/tests/visual.test
@@ -7,11 +7,11 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: visual.test,v 1.3 1999/04/16 01:51:43 stanton Exp $
+# RCS: @(#) $Id: visual.test,v 1.4 2002/07/12 13:41:01 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::test
+eval tcltest::configure $argv
foreach i [winfo children .] {
destroy $i
diff --git a/tests/visual_bb.test b/tests/visual_bb.test
index a113e3e..480026c 100644
--- a/tests/visual_bb.test
+++ b/tests/visual_bb.test
@@ -6,11 +6,18 @@
# at the window to make sure it appears as expected. Individual tests
# are kept in separate ".tcl" files in this directory.
#
-# RCS: @(#) $Id: visual_bb.test,v 1.4 2002/07/11 13:01:31 dkf Exp $
-
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
+# RCS: @(#) $Id: visual_bb.test,v 1.5 2002/07/12 13:41:01 dgp Exp $
+
+package require tcltest 2.1
+namespace import -force tcltest::test
+namespace import -force tcltest::testConstraint
+namespace import -force tcltest::testsDirectory
+namespace import -force tcltest::cleanupTests
+namespace import -force tcltest::configure
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
+eval configure $argv
set auto_path ". $auto_path"
wm title . "Visual Tests for Tk"
@@ -23,7 +30,7 @@ proc runTest {file} {
global testNum
test "2.$testNum" "testing $file" {userInteraction} {
- uplevel \#0 source [file join $::tcltest::testsDir $file]
+ uplevel \#0 source [file join [testsDirectory] $file]
concat ""
} {}
incr testNum
@@ -56,7 +63,7 @@ test 1.1 "running visual tests" {userInteraction} {
menubutton .menu.file -text "File" -menu .menu.file.m
menu .menu.file.m
- .menu.file.m add command -label "Quit" -command ::tcltest::cleanupTests
+ .menu.file.m add command -label "Quit" -command cleanupTests
menubutton .menu.group1 -text "Group 1" -menu .menu.group1.m
menu .menu.group1.m
@@ -79,7 +86,7 @@ test 1.1 "running visual tests" {userInteraction} {
.menu.ps.m add command -label "Bitmaps" \
-command {runTest canvPsBmap.tcl}
.menu.ps.m add command -label "Images" \
- -command {source canvPsImg.tcl}
+ -command {runTest canvPsImg.tcl}
.menu.ps.m add command -label "Arcs" \
-command {runTest canvPsArc.tcl}
@@ -102,6 +109,6 @@ test 1.1 "running visual tests" {userInteraction} {
concat ""
} {}
-if {!$::tcltest::testConfig(userInteraction)} {
- ::tcltest::cleanupTests
+if {![testConstraint userInteraction]} {
+ cleanupTests
}
diff --git a/tests/winButton.test b/tests/winButton.test
index 0a0c5d0..0d890ca 100644
--- a/tests/winButton.test
+++ b/tests/winButton.test
@@ -8,11 +8,11 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: winButton.test,v 1.6 2001/12/29 00:30:30 hobbs Exp $
+# RCS: @(#) $Id: winButton.test,v 1.7 2002/07/12 13:41:01 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::test
+eval tcltest::configure $argv
if {[lsearch [image types] test] < 0} {
puts "This application hasn't been compiled with the \"test\""
diff --git a/tests/winClipboard.test b/tests/winClipboard.test
index 73aaaef..078a2be 100644
--- a/tests/winClipboard.test
+++ b/tests/winClipboard.test
@@ -10,17 +10,18 @@
# Copyright (c) 1998-2000 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: winClipboard.test,v 1.9 2001/09/21 20:38:18 hobbs Exp $
+# RCS: @(#) $Id: winClipboard.test,v 1.10 2002/07/12 13:41:01 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::test
+namespace import -force tcltest::testConstraint
+namespace import -force tcltest::bytestring
+eval tcltest::configure $argv
# Note that these tests may fail if another application is grabbing the
# clipboard (e.g. an X server)
-set ::tcltest::testConfig(testclipboard) \
- [llength [info commands testclipboard]]
+testConstraint testclipboard [llength [info commands testclipboard]]
test winClipboard-1.1 {TkSelGetSelection} {pcOnly} {
clipboard clear
diff --git a/tests/winDialog.test b/tests/winDialog.test
index 62c1c8a..bebfe08 100644
--- a/tests/winDialog.test
+++ b/tests/winDialog.test
@@ -6,14 +6,13 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 1998-1999 ActiveState Corporation.
#
-# RCS: @(#) $Id: winDialog.test,v 1.7 2001/09/21 20:38:18 hobbs Exp $
+# RCS: @(#) $Id: winDialog.test,v 1.8 2002/07/12 13:41:01 dgp Exp $
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-
-set ::tcltest::testConfig(testwinevent) \
- [llength [info commands testwinevent]]
+package require tcltest 2.1
+namespace import -force tcltest::test
+namespace import -force tcltest::testConstraint
+eval tcltest::configure $argv
+testConstraint testwinevent [llength [info commands testwinevent]]
catch {testwinevent debug 1}
diff --git a/tests/winFont.test b/tests/winFont.test
index ca19cd0..0341d86 100644
--- a/tests/winFont.test
+++ b/tests/winFont.test
@@ -10,12 +10,11 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: winFont.test,v 1.6 2001/09/21 20:38:18 hobbs Exp $
-
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
+# RCS: @(#) $Id: winFont.test,v 1.7 2002/07/12 13:41:01 dgp Exp $
+package require tcltest 2.1
+namespace import -force tcltest::test
+eval tcltest::configure $argv
catch {destroy .b}
catch {font delete xyz}
diff --git a/tests/winMenu.test b/tests/winMenu.test
index fe4d90a..afa5ca0 100644
--- a/tests/winMenu.test
+++ b/tests/winMenu.test
@@ -7,12 +7,11 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: winMenu.test,v 1.4 2001/08/01 16:21:12 dgp Exp $
-
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
+# RCS: @(#) $Id: winMenu.test,v 1.5 2002/07/12 13:41:01 dgp Exp $
+package require tcltest 2.1
+namespace import -force tcltest::test
+eval tcltest::configure $argv
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"
diff --git a/tests/winSend.test b/tests/winSend.test
index 34819b5..04491df 100644
--- a/tests/winSend.test
+++ b/tests/winSend.test
@@ -7,23 +7,15 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: winSend.test,v 1.2 1999/04/16 01:51:44 stanton Exp $
+# RCS: @(#) $Id: winSend.test,v 1.3 2002/07/12 13:41:01 dgp Exp $
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
+package require Tk 8.4
+package require tcltest 2.1
+namespace import -force tcltest::test
+namespace import -force tcltest::testConstraint
+namespace import -force tcltest::interpreter
+eval tcltest::configure $argv
-if {$tcl_platform(platform) != "windows"} {
- puts "skipping: Windows only tests..."
- ::tcltest::cleanupTests
- return
-}
-
-if {[info commands send] != "send"} {
- puts "skipping: Unimplemented send command"
- ::tcltest::cleanupTests
- return
-}
foreach i [winfo children .] {
destroy $i
@@ -31,14 +23,6 @@ foreach i [winfo children .] {
wm geometry . {}
raise .
-set currentInterps [winfo interps]
-
-if {[catch {exec tktest &}] == 1} {
- puts "Could not run winSend.test because another instance of tktest could not be loaded."
- ::tcltest::cleanupTests
- return;
-}
-
# Compute a script that will load Tk into a child interpreter.
foreach pkg [info loaded] {
@@ -61,86 +45,91 @@ proc newApp {name {safe {}}} {
catch {eval $loadTk $name}
}
-# Wait until the child application has launched.
+set currentInterps [winfo interps]
+if {[testConstraint win] && [llength [info commands send]]} {
-while {[llength [winfo interps]] == [llength $currentInterps]} {
-}
+ if {[catch {exec [interpreter] &}] == 0} {
-# Now find an interp to send to
-set newInterps [winfo interps]
-foreach interp $newInterps {
- if {[lsearch -exact $currentInterps $interp] < 0} {
- break
- }
-}
+ # Wait until the child application has launched.
+ while {[llength [winfo interps]] == [llength $currentInterps]} {}
+
+ # Now find an interp to send to
+ set newInterps [winfo interps]
+ foreach interp $newInterps {
+ if {[lsearch -exact $currentInterps $interp] < 0} {
+ break
+ }
+ }
-# Now we have found our interpreter we are going to send to. Make sure that
-# it works first.
-if {[catch {send $interp {console hide; update}}] == 1} {
- puts "Could not send to child interpreter $interp"
- ::tcltest::cleanupTests
- return
+ # Now we have found our interpreter we are going to send to.
+ # Make sure that it works first.
+ testConstraint winSend [expr {[catch {
+ send $interp {console hide; update}
+ }] == 0}]
+ }
}
# setting up dde server is done when the first interp is created and
# cannot be tested very easily.
-test winSend-1.1 {Tk_SetAppName - changing name of interp} {
+test winSend-1.1 {Tk_SetAppName - changing name of interp} winSend {
newApp testApp
list [testApp eval tk appname testApp2] [interp delete testApp]
} {testApp2 {}}
test winSend-1.2 {Tk_SetAppName - changing name - not front of linked list} {
+ winSend
+} {
newApp testApp
newApp testApp2
list [testApp eval tk appname testApp3] [interp delete testApp] [interp delete testApp2]
} {testApp3 {} {}}
-test winSend-1.3 {Tk_SetAppName - unique name - no conflicts} {
+test winSend-1.3 {Tk_SetAppName - unique name - no conflicts} winSend {
newApp testApp
list [testApp eval tk appname testApp] [interp delete testApp]
} {testApp {}}
-test winSend-1.4 {Tk_SetAppName - unique name - one conflict} {
+test winSend-1.4 {Tk_SetAppName - unique name - one conflict} winSend {
newApp testApp
newApp foobar
list [foobar eval tk appname testApp] [interp delete foobar] [interp delete testApp]
} {{testApp #2} {} {}}
-test winSend-1.5 {Tk_SetAppName - unique name - one conflict} {
+test winSend-1.5 {Tk_SetAppName - unique name - one conflict} winSend {
newApp testApp
newApp foobar
newApp blaz
foobar eval tk appname testApp
list [blaz eval tk appname testApp] [interp delete foobar] [interp delete testApp] [interp delete blaz]
} {{testApp #3} {} {} {}}
-test winSend-1.6 {Tk_SetAppName - safe interps} {
+test winSend-1.6 {Tk_SetAppName - safe interps} winSend {
newApp testApp -safe
list [catch {testApp eval send testApp {set foo a}} msg] $msg [interp delete testApp]
} {1 {invalid command name "send"} {}}
-test winSend-2.1 {Tk_SendObjCmd - # of args} {
+test winSend-2.1 {Tk_SendObjCmd - # of args} winSend {
list [catch {send tktest} msg] $msg
} {1 {wrong # args: should be "send ?options? interpName arg ?arg ...?"}}
-test winSend-2.1 {Tk_SendObjCmd: arguments} {
+test winSend-2.1 {Tk_SendObjCmd: arguments} winSend {
list [catch {send -bogus tktest} msg] $msg
} {1 {bad option "-bogus": must be -async, -displayof, or --}}
-test winSend-2.1 {Tk_SendObjCmd: arguments} {
+test winSend-2.1 {Tk_SendObjCmd: arguments} winSend {
list [catch {send -async bogus foo} msg] $msg
} {1 {no registered server named "bogus"}}
-test winSend-2.1 {Tk_SendObjCmd: arguments} {
+test winSend-2.1 {Tk_SendObjCmd: arguments} winSend {
list [catch {send -displayof . bogus foo} msg] $msg
} {1 {no registered server named "bogus"}}
-test winSend-2.1 {Tk_SendObjCmd: arguments} {
+test winSend-2.1 {Tk_SendObjCmd: arguments} winSend {
list [catch {send -- -bogus foo} msg] $msg
} {1 {no registered server named "-bogus"}}
-test winSend-2.2 {Tk_SendObjCmd - sending to ourselves} {
+test winSend-2.2 {Tk_SendObjCmd - sending to ourselves} winSend {
list [send [tk appname] {set foo a}]
} {a}
-test winSend-2.3 {Tk_SendObjCmd - sending to ourselves in a different interpreter} {
+test winSend-2.3 {Tk_SendObjCmd - sending to ourselves in a different interpreter} winSend {
newApp testApp
list [catch {send testApp {set foo b}} msg] $msg [interp delete testApp]
} {0 b {}}
-test winSend-2.4 {Tk_SendObjCmd - sending to ourselves in a different interp with errors} {
+test winSend-2.4 {Tk_SendObjCmd - sending to ourselves in a different interp with errors} winSend {
newApp testApp
list [catch {send testApp {expr 2 / 0}} msg] $msg $errorCode $errorInfo [interp delete testApp]
} "1 {divide by zero} {ARITH DIVZERO {divide by zero}} {divide by zero\n while executing\n\"expr 2 / 0\"\n invoked from within\n\"send testApp {expr 2 / 0}\"} {}"
-test winSend-2.5 {Tk_SendObjCmd - sending to another app async} {
+test winSend-2.5 {Tk_SendObjCmd - sending to another app async} winSend {
set newInterps [winfo interps]
foreach interp $newInterps {
if {[lsearch $currentInterps $interp] < 0} {
@@ -149,7 +138,7 @@ test winSend-2.5 {Tk_SendObjCmd - sending to another app async} {
}
list [catch {send -async $interp {set foo a}} msg] $msg
} {0 {}}
-test winSend-2.6 {Tk_SendObjCmd - sending to another app sync - no error} {
+test winSend-2.6 {Tk_SendObjCmd - sending to another app sync - no error} winSend {
set newInterps [winfo interps]
foreach interp $newInterps {
if {[lsearch $currentInterps $interp] < 0} {
@@ -158,7 +147,7 @@ test winSend-2.6 {Tk_SendObjCmd - sending to another app sync - no error} {
}
list [catch {send $interp {set foo a}} msg] $msg
} {0 a}
-test winSend-2.7 {Tk_SendObjCmd - sending to another app - error} {
+test winSend-2.7 {Tk_SendObjCmd - sending to another app - error} winSend {
set newInterps [winfo interps]
foreach interp $newInterps {
if {[lsearch $currentInterps $interp] < 0} {
@@ -168,22 +157,22 @@ test winSend-2.7 {Tk_SendObjCmd - sending to another app - error} {
list [catch {send $interp {expr 2 / 0}} msg] $msg $errorCode $errorInfo
} "1 {divide by zero} {ARITH DIVZERO {divide by zero}} {divide by zero\n while executing\n\"expr 2 / 0\"\n invoked from within\n\"send \$interp {expr 2 / 0}\"}"
-test winSend-3.1 {TkGetInterpNames} {
+test winSend-3.1 {TkGetInterpNames} winSend {
set origLength [llength $currentInterps]
set newLength [llength [winfo interps]]
expr {($newLength - 2) == $origLength}
} {1}
-test winSend-4.1 {DeleteProc - changing name of app} {
+test winSend-4.1 {DeleteProc - changing name of app} winSend {
newApp a
list [a eval tk appname foo] [interp delete a]
} {foo {}}
-test winSend-4.2 {DeleteProc - normal} {
+test winSend-4.2 {DeleteProc - normal} winSend {
newApp a
list [interp delete a]
} {{}}
-test winSend-5.1 {ExecuteRemoteObject - no error} {
+test winSend-5.1 {ExecuteRemoteObject - no error} winSend {
set newInterps [winfo interps]
foreach interp $newInterps {
if {[lsearch $currentInterps $interp] < 0} {
@@ -192,7 +181,7 @@ test winSend-5.1 {ExecuteRemoteObject - no error} {
}
list [send $interp {send [tk appname] {expr 2 / 1}}]
} {2}
-test winSend-5.2 {ExecuteRemoteObject - error} {
+test winSend-5.2 {ExecuteRemoteObject - error} winSend {
set newInterps [winfo interps]
foreach interp $newInterps {
if {[lsearch $currentInterps $interp] < 0} {
@@ -202,7 +191,7 @@ test winSend-5.2 {ExecuteRemoteObject - error} {
list [catch {send $interp {send [tk appname] {expr 2 / 0}}} msg] $msg
} {1 {divide by zero}}
-test winSend-6.1 {SendDDEServer - XTYP_CONNECT} {
+test winSend-6.1 {SendDDEServer - XTYP_CONNECT} winSend {
set foo "Hello, World"
set newInterps [winfo interps]
foreach interp $newInterps {
@@ -213,7 +202,7 @@ test winSend-6.1 {SendDDEServer - XTYP_CONNECT} {
set command "dde request Tk [tk appname] foo"
list [catch "send \{$interp\} \{$command\}" msg] $msg
} {0 {Hello, World}}
-test winSend-6.2 {SendDDEServer - XTYP_CONNECT_CONFIRM} {
+test winSend-6.2 {SendDDEServer - XTYP_CONNECT_CONFIRM} winSend {
set foo "Hello, World"
set newInterps [winfo interps]
foreach interp $newInterps {
@@ -224,7 +213,7 @@ test winSend-6.2 {SendDDEServer - XTYP_CONNECT_CONFIRM} {
set command "dde request Tk [tk appname] foo"
list [catch "send \{$interp\} \{$command\}" msg] $msg
} {0 {Hello, World}}
-test winSend-6.3 {SendDDEServer - XTYP_DISCONNECT} {
+test winSend-6.3 {SendDDEServer - XTYP_DISCONNECT} winSend {
set foo "Hello, World"
set newInterps [winfo interps]
foreach interp $newInterps {
@@ -235,7 +224,7 @@ test winSend-6.3 {SendDDEServer - XTYP_DISCONNECT} {
set command "dde request Tk [tk appname] foo"
list [catch "send \{$interp\} \{$command\}" msg] $msg
} {0 {Hello, World}}
-test winSend-6.4 {SendDDEServer - XTYP_REQUEST variable} {
+test winSend-6.4 {SendDDEServer - XTYP_REQUEST variable} winSend {
set foo "Hello, World"
set newInterps [winfo interps]
foreach interp $newInterps {
@@ -246,7 +235,7 @@ test winSend-6.4 {SendDDEServer - XTYP_REQUEST variable} {
set command "dde request Tk [tk appname] foo"
list [catch "send \{$interp\} \{$command\}" msg] $msg
} {0 {Hello, World}}
-test winSend-6.5 {SendDDEServer - XTYP_REQUEST array} {
+test winSend-6.5 {SendDDEServer - XTYP_REQUEST array} winSend {
catch {unset foo}
set foo(test) "Hello, World"
set newInterps [winfo interps]
@@ -258,7 +247,7 @@ test winSend-6.5 {SendDDEServer - XTYP_REQUEST array} {
set command "dde request Tk [tk appname] foo(test)"
list [catch "send \{$interp\} \{$command\}" msg] $msg [catch {unset foo}]
} {0 {Hello, World} 0}
-test winSend-6.6 {SendDDEServer - XTYP_REQUEST return results} {
+test winSend-6.6 {SendDDEServer - XTYP_REQUEST return results} winSend {
set foo 3
set newInterps [winfo interps]
foreach interp $newInterps {
@@ -269,7 +258,7 @@ test winSend-6.6 {SendDDEServer - XTYP_REQUEST return results} {
set command "send [tk appname] {expr $foo + 1}"
list [catch "send \{$interp\} \{$command\}" msg] $msg
} {0 4}
-test winSend-6.7 {SendDDEServer - XTYP_EXECUTE} {
+test winSend-6.7 {SendDDEServer - XTYP_EXECUTE} winSend {
set newInterps [winfo interps]
foreach interp $newInterps {
if {[lsearch $currentInterps $interp] < 0} {
@@ -279,7 +268,7 @@ test winSend-6.7 {SendDDEServer - XTYP_EXECUTE} {
set command "send [tk appname] {expr 4 / 2}"
list [catch "send \{$interp\} \{$command\}" msg] $msg
} {0 2}
-test winSend-6.8 {SendDDEServer - XTYP_WILDCONNECT} {
+test winSend-6.8 {SendDDEServer - XTYP_WILDCONNECT} winSend {
set newInterps [winfo interps]
foreach interp $newInterps {
if {[lsearch $currentInterps $interp] < 0} {
@@ -290,12 +279,12 @@ test winSend-6.8 {SendDDEServer - XTYP_WILDCONNECT} {
list [catch "send \{$interp\} \{$command\}"]
} {0}
-test winSend-7.1 {DDEExitProc} {
+test winSend-7.1 {DDEExitProc} winSend {
newApp testApp
list [interp delete testApp]
} {{}}
-test winSend-8.1 {SendDdeConnect} {
+test winSend-8.1 {SendDdeConnect} winSend {
set newInterps [winfo interps]
foreach interp $newInterps {
if {[lsearch $currentInterps $interp] < 0} {
@@ -305,38 +294,38 @@ test winSend-8.1 {SendDdeConnect} {
list [send $interp {set tk foo}]
} {foo}
-test winSend-9.1 {SetDDEError} {
+test winSend-9.1 {SetDDEError} winSend {
list [catch {dde execute Tk foo {set foo hello}} msg] $msg
} {1 {dde command failed}}
-test winSend-10.1 {Tk_DDEObjCmd - wrong num args} {
+test winSend-10.1 {Tk_DDEObjCmd - wrong num args} winSend {
list [catch {dde} msg] $msg
} {1 {wrong # args: should be "dde ?-async? serviceName topicName value"}}
-test winSend-10.2 {Tk_DDEObjCmd - unknown subcommand} {
+test winSend-10.2 {Tk_DDEObjCmd - unknown subcommand} winSend {
list [catch {dde foo} msg] $msg
} {1 {bad command "foo": must be execute, request, or services}}
-test winSend-10.3 {Tk_DDEObjCmd - execute - wrong num args} {
+test winSend-10.3 {Tk_DDEObjCmd - execute - wrong num args} winSend {
list [catch {dde execute} msg] $msg
} {1 {wrong # args: should be "dde execute ?-async? serviceName topicName value"}}
-test winSend-10.4 {Tk_DDEObjCmd - execute - wrong num args} {
+test winSend-10.4 {Tk_DDEObjCmd - execute - wrong num args} winSend {
list [catch {dde execute 3 4 5 6 7} msg] $msg
} {1 {wrong # args: should be "dde execute ?-async? serviceName topicName value"}}
-test winSend-10.5 {Tk_DDEObjCmd - execute async - wrong num args} {
+test winSend-10.5 {Tk_DDEObjCmd - execute async - wrong num args} winSend {
list [catch {dde execute -async} msg] $msg
} {1 {wrong # args: should be "dde execute ?-async? serviceName topicName value"}}
-test winSend-10.6 {Tk_DDEObjCmd - request - wrong num args} {
+test winSend-10.6 {Tk_DDEObjCmd - request - wrong num args} winSend {
list [catch {dde request} msg] $msg
} {1 {wrong # args: should be "dde request serviceName topicName value"}}
-test winSend-10.7 {Tk_DDEObjCmd - services wrong num args} {
+test winSend-10.7 {Tk_DDEObjCmd - services wrong num args} winSend {
list [catch {dde services} msg] $msg
} {1 {wrong # args: should be "dde services serviceName topicName"}}
-test winSend-10.8 {Tk_DDEObjCmd - null service name} {
+test winSend-10.8 {Tk_DDEObjCmd - null service name} winSend {
list [catch {dde services {} {tktest #2}}]
} {0}
-test winSend-10.9 {Tk_DDEObjCmd - null topic name} {
+test winSend-10.9 {Tk_DDEObjCmd - null topic name} winSend {
list [catch {dde services {Tk} {}}]
} {0}
-test winSend-10.10 {Tk_DDEObjCmd - execute - nothing to execute} {
+test winSend-10.10 {Tk_DDEObjCmd - execute - nothing to execute} winSend {
set newInterps [winfo interps]
foreach interp $newInterps {
if {[lsearch $currentInterps $interp] < 0} {
@@ -345,10 +334,10 @@ test winSend-10.10 {Tk_DDEObjCmd - execute - nothing to execute} {
}
list [catch {dde execute Tk $interp {}} msg] $msg
} {1 {cannot execute null data}}
-test winSend-10.11 {Tk_DDEObjCmd - execute - no such conversation} {
+test winSend-10.11 {Tk_DDEObjCmd - execute - no such conversation} winSend {
list [catch {dde execute Tk foo {set foo hello}} msg] $msg
} {1 {dde command failed}}
-test winSend-10.12 {Tk_DDEObjCmd - execute - async} {
+test winSend-10.12 {Tk_DDEObjCmd - execute - async} winSend {
set newInterps [winfo interps]
foreach interp $newInterps {
if {[lsearch $currentInterps $interp] < 0} {
@@ -357,7 +346,7 @@ test winSend-10.12 {Tk_DDEObjCmd - execute - async} {
}
list [catch {dde execute -async Tk $interp {set foo hello}} msg] $msg
} {0 {}}
-test winSend-10.13 {Tk_DDEObjCmd - execute} {
+test winSend-10.13 {Tk_DDEObjCmd - execute} winSend {
set newInterps [winfo interps]
foreach interp $newInterps {
if {[lsearch $currentInterps $interp] < 0} {
@@ -366,7 +355,7 @@ test winSend-10.13 {Tk_DDEObjCmd - execute} {
}
list [catch {dde execute Tk $interp {set foo goodbye}} msg] $msg
} {0 {}}
-test winSend-10.14 {Tk_DDEObjCmd - request - nothing to request} {
+test winSend-10.14 {Tk_DDEObjCmd - request - nothing to request} winSend {
set newInterps [winfo interps]
foreach interp $newInterps {
if {[lsearch $currentInterps $interp] < 0} {
@@ -375,7 +364,7 @@ test winSend-10.14 {Tk_DDEObjCmd - request - nothing to request} {
}
list [catch {dde request Tk $interp {}} msg] $msg
} {1 {cannot request value of null data}}
-test winSend-10.15 {Tk_DDEObjCmd - request - invalid interp} {
+test winSend-10.15 {Tk_DDEObjCmd - request - invalid interp} winSend {
set newInterps [winfo interps]
foreach interp $newInterps {
if {[lsearch $currentInterps $interp] < 0} {
@@ -384,7 +373,7 @@ test winSend-10.15 {Tk_DDEObjCmd - request - invalid interp} {
}
list [catch {dde request Tk foo foo} msg] $msg
} {1 {dde command failed}}
-test winSend-10.16 {Tk_DDEObjCmd - invalid variable} {
+test winSend-10.16 {Tk_DDEObjCmd - invalid variable} winSend {
set newInterps [winfo interps]
foreach interp $newInterps {
if {[lsearch $currentInterps $interp] < 0} {
@@ -394,7 +383,7 @@ test winSend-10.16 {Tk_DDEObjCmd - invalid variable} {
send $interp {unset foo}
list [catch {dde request Tk $interp foo} msg] $msg
} {1 {remote server cannot handle this command}}
-test winSend-10.17 {Tk_DDEObjCmd - valid variable} {
+test winSend-10.17 {Tk_DDEObjCmd - valid variable} winSend {
set newInterps [winfo interps]
foreach interp $newInterps {
if {[lsearch $currentInterps $interp] < 0} {
@@ -404,7 +393,7 @@ test winSend-10.17 {Tk_DDEObjCmd - valid variable} {
send $interp {set foo winSend-10.17}
list [catch {dde request Tk $interp foo} msg] $msg
} {0 winSend-10.17}
-test winSend-10.18 {Tk_DDEObjCmd - services} {
+test winSend-10.18 {Tk_DDEObjCmd - services} winSend {
set currentService [list Tk [tk appname]]
list [catch {dde services Tk {}} msg] [expr [lsearch $msg $currentService] >= 0]
} {0 1}
diff --git a/tests/winWm.test b/tests/winWm.test
index bc4a220..5e81325 100644
--- a/tests/winWm.test
+++ b/tests/winWm.test
@@ -9,12 +9,11 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: winWm.test,v 1.6 2002/06/24 20:34:40 mdejong Exp $
-
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
+# RCS: @(#) $Id: winWm.test,v 1.7 2002/07/12 13:41:01 dgp Exp $
+package require tcltest 2.1
+namespace import -force tcltest::test
+eval tcltest::configure $argv
foreach i [winfo children .] {
catch {destroy $i}
}
diff --git a/tests/window.test b/tests/window.test
index 2de63a0..3b5ede6 100644
--- a/tests/window.test
+++ b/tests/window.test
@@ -5,11 +5,12 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: window.test,v 1.4 1999/04/16 01:51:44 stanton Exp $
+# RCS: @(#) $Id: window.test,v 1.5 2002/07/12 13:41:01 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::test
+namespace import -force tcltest::testConstraint
+eval tcltest::configure $argv
foreach i [winfo children .] {
destroy $i
@@ -80,8 +81,7 @@ test window-2.3 {Tk_DestroyWindow procedure, destroy handler deletes parent} {
} {}
# Some tests require the testmenubar command
-set ::tcltest::testConfig(testmenubar) \
- [expr {[info commands testmenubar] != {}}]
+testConstraint testmenubar [llength [info commands testmenubar]]
test window-3.1 {Tk_MakeWindowExist procedure, stacking order and menubars} \
{unixOnly testmenubar} {
diff --git a/tests/winfo.test b/tests/winfo.test
index a1344c9..1916cfa 100644
--- a/tests/winfo.test
+++ b/tests/winfo.test
@@ -6,11 +6,12 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: winfo.test,v 1.6 2002/06/14 07:17:53 mdejong Exp $
+# RCS: @(#) $Id: winfo.test,v 1.7 2002/07/12 13:41:01 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::test
+namespace import -force tcltest::testConstraint
+eval tcltest::configure $argv
foreach i [winfo children .] {
catch {destroy $i}
@@ -19,8 +20,7 @@ wm geometry . {}
raise .
# Some tests require the testwrapper command
-set ::tcltest::testConfig(testwrapper) \
- [expr {[info commands testwrapper] != {}}]
+testConstraint testwrapper [llength [info commands testwrapper]]
# eatColors --
# Creates a toplevel window and allocates enough colors in it to
@@ -92,8 +92,8 @@ test winfo-2.7 {"winfo atom" command} {
} SECONDARY
# Some tests require the "pseudocolor" visual class.
-set ::tcltest::testConfig(pseudocolor) \
- [expr {([winfo depth .] == 8) && ([winfo visual .] == "pseudocolor")}]
+testConstraint pseudocolor [expr { ([winfo depth .] == 8)
+ && ([winfo visual .] == "pseudocolor")}]
test winfo-3.1 {"winfo colormapfull" command} {pseudocolor} {
list [catch {winfo colormapfull} msg] $msg
diff --git a/tests/wm.test b/tests/wm.test
index bc1bd1a..6c91e9d 100644
--- a/tests/wm.test
+++ b/tests/wm.test
@@ -7,15 +7,14 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: wm.test,v 1.13 2002/06/24 20:34:40 mdejong Exp $
+# RCS: @(#) $Id: wm.test,v 1.14 2002/07/12 13:41:01 dgp Exp $
# This file tests window manager interactions that work across
# platforms. Window manager tests that only work on a specific
# platform should be placed in unixWm.test or winWm.test.
-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::test
proc deleteWindows {} {
foreach i [winfo children .] {
@@ -26,7 +25,10 @@ proc deleteWindows {} {
deleteWindows
-wm deicon .
+wm deiconify .
+if {![winfo ismapped .]} {
+ tkwait visibility .
+}
test wm-stackorder-1.1 {usage} {
list [catch {wm stackorder} err] $err
@@ -808,7 +810,7 @@ test wm-deiconify-2.4 {invoking destroy after a deiconify
deleteWindows
-
+tcltest::cleanupTests
return
diff --git a/tests/xmfbox.test b/tests/xmfbox.test
index 8035e44..8d7e221 100644
--- a/tests/xmfbox.test
+++ b/tests/xmfbox.test
@@ -7,13 +7,13 @@
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
# All rights reserved.
#
-# RCS: @(#) $Id: xmfbox.test,v 1.5 2001/08/01 16:21:12 dgp Exp $
+# RCS: @(#) $Id: xmfbox.test,v 1.6 2002/07/12 13:41:01 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::test
set testPWD [pwd]
eval destroy [winfo children .]
@@ -124,7 +124,7 @@ test xmfbox-2.5 {tk::MotifFDialog_BrowseFList, ~ in file names} {unixOnly} {
$::tk::dialog::file::foo(sEnt) get
} $testPWD/~nosuchuser1
-test xmfbox-2.5 {tk::MotifFDialog_ActivateFList, ~ in file names} {unixOnly} {
+test xmfbox-2.6 {tk::MotifFDialog_ActivateFList, ~ in file names} {unixOnly} {
cleanup
close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}]
set x [tk::MotifFDialog_Create foo open {}]
diff --git a/unix/Makefile.in b/unix/Makefile.in
index e67ef09..d3fddeb 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.74 2002/07/08 22:08:49 davygrvy Exp $
+# RCS: @(#) $Id: Makefile.in,v 1.75 2002/07/12 13:41:01 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 \
+ ./tktest $(TOP_DIR)/tests/all.tcl -geometry +0+0 -match \* \
$(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 \
+ ./tktest $(TOP_DIR)/tests/all.tcl -geometry +0+0 -match \* \
$(TESTFLAGS) $(TCLTESTARGS); \
done
generated by cgit v0.12 at 2024-11-10 06:53:48 (GMT)