diff options
author | hershey <hershey> | 1999-03-26 00:07:49 (GMT) |
---|---|---|
committer | hershey <hershey> | 1999-03-26 00:07:49 (GMT) |
commit | 8ef1ceb8863bebe0af2419b9fa736601470af737 (patch) | |
tree | 52a68d75c6dbbed8bec457475298eeb85eea1eea | |
parent | 3b20040d0062aedf023c92942101d4d86bb40146 (diff) | |
download | tk-8ef1ceb8863bebe0af2419b9fa736601470af737.zip tk-8ef1ceb8863bebe0af2419b9fa736601470af737.tar.gz tk-8ef1ceb8863bebe0af2419b9fa736601470af737.tar.bz2 |
Now all test files that skip tests by returning early (which ideally they
shouldn't do) call ::tcltest::cleanupTests before returning. The defs.tcl
file has one hew constraint: userInteraction, used by tests that require
user interaction. The next putback will include an updated version of the
"visual" test file to use this mechanism.
40 files changed, 338 insertions, 278 deletions
diff --git a/tests/bitmap.test b/tests/bitmap.test index ac91e5c..7df45d3 100644 --- a/tests/bitmap.test +++ b/tests/bitmap.test @@ -6,7 +6,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: bitmap.test,v 1.1.2.5 1999/03/24 02:54:23 hershey Exp $ +# RCS: @(#) $Id: bitmap.test,v 1.1.2.6 1999/03/26 00:07:49 hershey Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { source [file join [pwd] [file dirname [info script]] defs.tcl] @@ -14,6 +14,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { if {[info commands testbitmap] != "testbitmap"} { puts "testbitmap command not available; skipping tests" + ::tcltest::cleanupTests return } diff --git a/tests/border.test b/tests/border.test index a713d76..76f7c87 100644 --- a/tests/border.test +++ b/tests/border.test @@ -5,7 +5,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: border.test,v 1.1.2.5 1999/03/24 02:54:24 hershey Exp $ +# RCS: @(#) $Id: border.test,v 1.1.2.6 1999/03/26 00:07:49 hershey Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { source [file join [pwd] [file dirname [info script]] defs.tcl] @@ -13,6 +13,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { if {[info commands testborder] != "testborder"} { puts "testborder command not available; skipping tests" + ::tcltest::cleanupTests return } @@ -26,11 +27,13 @@ raise . # test file. if [catch {toplevel .t -visual {pseudocolor 8} -colormap new}] { + ::tcltest::cleanupTests return } wm geom .t +0+0 if {[winfo depth .t] != 8} { destroy .t + ::tcltest::cleanupTests return } diff --git a/tests/button.test b/tests/button.test index 9d52562..992f45a 100644 --- a/tests/button.test +++ b/tests/button.test @@ -7,19 +7,20 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: button.test,v 1.1.4.5 1999/03/24 02:54:26 hershey Exp $ +# RCS: @(#) $Id: button.test,v 1.1.4.6 1999/03/26 00:07:50 hershey Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} if {[lsearch [image types] test] < 0} { puts "This application hasn't been compiled with the \"test\"" puts "image, so I can't run this test. Are you sure you're using" puts "tktest instead of wish?" + ::tcltest::cleanupTests return } -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - foreach i [winfo children .] { destroy $i } diff --git a/tests/canvImg.test b/tests/canvImg.test index ca6882e..008ffd1 100644 --- a/tests/canvImg.test +++ b/tests/canvImg.test @@ -7,19 +7,20 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: canvImg.test,v 1.1.4.4 1999/03/24 02:54:27 hershey Exp $ +# RCS: @(#) $Id: canvImg.test,v 1.1.4.5 1999/03/26 00:07:51 hershey Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} if {[lsearch [image types] test] < 0} { puts "This application hasn't been compiled with the \"test\" image" puts "type, so I can't run this test. Are you sure you're using" puts "tktest instead of wish?" + ::tcltest::cleanupTests return } -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - foreach i [winfo children .] { destroy $i } diff --git a/tests/canvRect.test b/tests/canvRect.test index 5a6a76f..57744cb 100644 --- a/tests/canvRect.test +++ b/tests/canvRect.test @@ -6,7 +6,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: canvRect.test,v 1.1.4.4 1999/03/24 02:54:31 hershey Exp $ +# RCS: @(#) $Id: canvRect.test,v 1.1.4.5 1999/03/26 00:07:52 hershey Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { source [file join [pwd] [file dirname [info script]] defs.tcl] @@ -293,7 +293,7 @@ test canvRect-10.1 {TranslateRectOval procedure} { # This test is non-portable because different color information # will get generated on different displays (e.g. mono displays # vs. color). -test canvRect-11.1 {RectOvalToPostscript procedure} {nonPortable win32sCrash macCrash} { +test canvRect-11.1 {RectOvalToPostscript procedure} {nonPortable macCrash} { # Crashes on Mac because the XGetImage() call isn't implemented, causing a # dereference of NULL. diff --git a/tests/clrpick.test b/tests/clrpick.test index 911e91d..7aef25a 100644 --- a/tests/clrpick.test +++ b/tests/clrpick.test @@ -5,13 +5,19 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: clrpick.test,v 1.1.4.5 1999/03/24 02:54:34 hershey Exp $ +# RCS: @(#) $Id: clrpick.test,v 1.1.4.6 1999/03/26 00:07:52 hershey Exp $ # if {[lsearch [namespace children] ::tcltest] == -1} { source [file join [pwd] [file dirname [info script]] defs.tcl] } +# Some tests require user interaction on non-unix platform + +set ::tcltest::testConfig(nonUnixUserInteraction) \ + [expr {$::tcltest::testConfig(userInteraction) || \ + $::tcltest::testConfig(unixOnly)}] + test clrpick-1.1 {tk_chooseColor command} { list [catch {tk_chooseColor -foo} msg] $msg } {1 {bad option "-foo": must be -initialcolor, -parent, or -title}} @@ -50,10 +56,8 @@ test clrpick-1.7 {tk_chooseColor command} { if {[info commands tkColorDialog] == ""} { set isNative 1 - set ::tcltest::testConfig(tkDialog) 0 } else { set isNative 0 - set ::tcltest::testConfig(tkDialog) 1 } proc ToPressButton {parent btn} { @@ -165,7 +169,7 @@ destroy .c set color #404040 test clrpick-2.1 {tk_chooseColor command} \ - {interactive colorsLeftover tkDialog} { + {nonUnixUserInteraction colorsLeftover} { ToPressButton $parent ok tk_chooseColor -title "Press Ok $verylongstring" -initialcolor $color \ -parent $parent @@ -173,7 +177,7 @@ test clrpick-2.1 {tk_chooseColor command} \ set color #808040 test clrpick-2.2 {tk_chooseColor command} \ - {interactive colorsLeftover tkDialog} { + {nonUnixUserInteraction colorsLeftover} { if {$tcl_platform(platform) == "macintosh"} { set colors "32768 32768 16384" } else { @@ -184,23 +188,23 @@ test clrpick-2.2 {tk_chooseColor command} \ } "$color" test clrpick-2.3 {tk_chooseColor command} \ - {interactive colorsLeftover tkDialog} { + {nonUnixUserInteraction colorsLeftover} { ToPressButton $parent ok tk_chooseColor -parent $parent -title "Press OK" } "$color" -test clrpick-2.4 {tk_chooseColor command} {interactive tkDialog} { +test clrpick-2.4 {tk_chooseColor command} {nonUnixUserInteraction} { ToPressButton $parent cancel tk_chooseColor -parent $parent -title "Press Cancel" } "" set color #000000 -test clrpick-3.1 {tk_chooseColor: background events} {interactive tkDialog} { +test clrpick-3.1 {tk_chooseColor: background events} {nonUnixUserInteraction} { after 1 {set x 53} ToPressButton $parent ok tk_chooseColor -parent $parent -title "Press OK" -initialcolor $color } "#000000" -test clrpick-3.2 {tk_chooseColor: background events} {interactive tkDialog} { +test clrpick-3.2 {tk_chooseColor: background events} {nonUnixUserInteraction} { after 1 {set x 53} ToPressButton $parent cancel tk_chooseColor -parent $parent -title "Press Cancel" diff --git a/tests/color.test b/tests/color.test index f45aef9..e097210 100644 --- a/tests/color.test +++ b/tests/color.test @@ -5,17 +5,18 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: color.test,v 1.1.4.5 1999/03/24 02:54:36 hershey Exp $ +# RCS: @(#) $Id: color.test,v 1.1.4.6 1999/03/26 00:07:53 hershey Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} if {[info commands testcolor] != "testcolor"} { puts "testcolor command not available; skipping tests" + ::tcltest::cleanupTests return } -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - eval destroy [winfo children .] wm geometry . {} raise . @@ -107,11 +108,13 @@ proc colorsFree {w {red 31} {green 245} {blue 192}} { # test file. if [catch {toplevel .t -visual {pseudocolor 8} -colormap new}] { + ::tcltest::cleanupTests return } wm geom .t +0+0 if {[winfo depth .t] != 8} { destroy .t + ::tcltest::cleanupTests return } mkColors .t.c 40 6 0 0 0 0 6 0 0 0 40 @@ -119,12 +122,14 @@ pack .t.c update if ![colorsFree .t.c 101 233 17] { destroy .t + ::tcltest::cleanupTests return } mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0 pack .t.c2 if [colorsFree .t.c] { destroy .t + ::tcltest::cleanupTests return } destroy .t.c .t.c2 diff --git a/tests/config.test b/tests/config.test index 40a0422..6fd2eab 100644 --- a/tests/config.test +++ b/tests/config.test @@ -6,19 +6,20 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: config.test,v 1.1.2.5 1999/03/24 02:54:36 hershey Exp $ +# RCS: @(#) $Id: config.test,v 1.1.2.6 1999/03/26 00:07:53 hershey Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} if {[info command testobjconfig] != "testobjconfig"} { puts "This application hasn't been compiled with the \"testobjconfig\"" puts "command, so I can't run this test. Are you sure you're using" puts "tktest instead of wish?" + ::tcltest::cleanupTests return } -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - proc killTables {} { # Note: it's important to delete chain2 before chain1, because # chain2 depends on chain1. If chain1 is deleted first, the diff --git a/tests/cursor.test b/tests/cursor.test index bbae72b..6c8ef3c 100644 --- a/tests/cursor.test +++ b/tests/cursor.test @@ -6,7 +6,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: cursor.test,v 1.1.2.5 1999/03/24 02:54:37 hershey Exp $ +# RCS: @(#) $Id: cursor.test,v 1.1.2.6 1999/03/26 00:07:54 hershey Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { source [file join [pwd] [file dirname [info script]] defs.tcl] @@ -14,6 +14,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { if {[info commands testcursor] != "testcursor"} { puts "testcursor command not available; skipping tests" + ::tcltest::cleanupTests return } @@ -48,7 +49,7 @@ test cursor-1.3 {Tk_AllocCursorFromObj - reuse existing cursor} { button .b2 -cursor $x pack .b1 .b2 -side top lappend result [testcursor watch] -} {{1 1}} {{2 1}} +} {{{1 1}} {{2 1}}} test cursor-2.1 {Tk_GetCursor procedure} { destroy .b1 diff --git a/tests/defs.tcl b/tests/defs.tcl index 77f87b5..5986d03 100644 --- a/tests/defs.tcl +++ b/tests/defs.tcl @@ -11,7 +11,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: defs.tcl,v 1.1.2.7 1999/03/25 17:13:55 hershey Exp $ +# RCS: @(#) $Id: defs.tcl,v 1.1.2.8 1999/03/26 00:07:54 hershey Exp $ # Initialize wish shell if {[info exists tk_version]} { @@ -190,12 +190,18 @@ proc ::tcltest::initConfig {} { } } - # By default, non-portable tests are skipped. - set ::tcltest::testConfig(nonPortable) 0 + # Skip empty tests + set ::tcltest::testConfig(emptyTest) 0 # By default, tests that expost known bugs are skipped. set ::tcltest::testConfig(knownBug) 0 + # By default, non-portable tests are skipped. + set ::tcltest::testConfig(nonPortable) 0 + + # Some tests require user interaction. + set ::tcltest::testConfig(userInteraction) 0 + # Some tests must be skipped if the interpreter is not in interactive mode set ::tcltest::testConfig(interactive) $tcl_interactive @@ -315,7 +321,9 @@ proc ::tcltest::initConfig {} { # ::tcltest::processCmdLineArgs -- # # Use command line args to set the verbose, skippingTests, and -# matchingTests variables. +# matchingTests variables. This procedure must be run after +# constraints are initialized, because some constraints can be +# overridden. # # Arguments: # none @@ -374,16 +382,13 @@ proc ::tcltest::processCmdLineArgs {} { set ::tcltest::skippingTests $flag(-skip) } - # Use the -constraints flag, if given, to turn on the following - # constraints: knownBug and nonPortable + # Use the -constraints flag, if given, to turn on constraints that are + # turned off by default: userInteractive knownBug nonPortable. This + # code fragment must be run after constraints are initialized. if {[info exists flag(-constraints)]} { - set constrList $flag(-constraints) - } else { - set constrList {} - } - foreach elt [list knownBug nonPortable] { - set ::tcltest::testConfig($elt) \ - [expr {[lsearch -exact $constrList $elt] != -1}] + foreach elt $flag(-constraints) { + set ::tcltest::testConfig($elt) 1 + } } } diff --git a/tests/entry.test b/tests/entry.test index 0ed6c4c..e19e67a 100644 --- a/tests/entry.test +++ b/tests/entry.test @@ -6,19 +6,20 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: entry.test,v 1.1.4.6 1999/03/24 02:54:38 hershey Exp $ +# RCS: @(#) $Id: entry.test,v 1.1.4.7 1999/03/26 00:07:55 hershey Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} if {[lsearch [image types] test] < 0} { puts "This application hasn't been compiled with the \"test\"" puts "image, so I can't run this test. Are you sure you're using" puts "tktest instead of wish?" + ::tcltest::cleanupTests return } -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - foreach i [winfo children .] { destroy $i } @@ -735,7 +736,7 @@ test entry-6.10 {EntryComputeGeometry procedure} {unixOnly fonts} { .e configure -show "" lappend x [winfo reqwidth .e] } {23 53 43} -test entry-6.11 {EntryComputeGeometry procedure} {pc} { +test entry-6.11 {EntryComputeGeometry procedure} {pcOnly} { catch {destroy .e} entry .e -bd 1 -relief raised -width 0 -show . -font {helvetica 12} .e insert 0 12345 @@ -1291,7 +1292,7 @@ test entry-15.2 {EntryVisibleRange procedure} {unixOnly fonts} { .e insert 0 ............................. .e xview } {0 0.275862} -test entry-15.3 {EntryVisibleRange procedure} {pc} { +test entry-15.3 {EntryVisibleRange procedure} {pcOnly} { .e configure -show . .e delete 0 end .e insert 0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXX diff --git a/tests/filebox.test b/tests/filebox.test index 2b591b1..49784b2 100644 --- a/tests/filebox.test +++ b/tests/filebox.test @@ -6,11 +6,21 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: filebox.test,v 1.1.4.7 1999/03/24 02:54:39 hershey Exp $ +# RCS: @(#) $Id: filebox.test,v 1.1.4.8 1999/03/26 00:07:56 hershey Exp $ # +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + set tk_strictMotif_old $tk_strictMotif +# Some tests require user interaction on non-unix platform + +set ::tcltest::testConfig(nonUnixUserInteraction) \ + [expr {$::tcltest::testConfig(userInteraction) || \ + $::tcltest::testConfig(unixOnly)}] + #---------------------------------------------------------------------- # # Procedures needed by this test file @@ -89,10 +99,6 @@ proc SendButtonPress {parent btn type} { # #---------------------------------------------------------------------- -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - if {$tcl_platform(platform) == "unix"} { set modes "0 1" } else { @@ -160,10 +166,6 @@ foreach mode $modes { set isNative 0 } - if {$isNative && ![info exists tcl_interactive]} { - continue - } - set parent . set verylongstring longstring: @@ -178,7 +180,7 @@ foreach mode $modes { # set verylongstring $verylongstring$verylongstring set color #404040 - test filebox-2.1 "$command command" { + test filebox-2.1 "$command command" {nonUnixUserInteraction} { ToPressButton $parent cancel $command -title "Press Cancel ($verylongstring)" -parent $parent } "" @@ -193,33 +195,33 @@ foreach mode $modes { set pathName [file join $fileDir $fileName] } - test filebox-2.2 "$command command" { + test filebox-2.2 "$command command" {nonUnixUserInteraction} { ToPressButton $parent ok set choice [$command -title "Press Ok" \ -parent $parent -initialfile $fileName -initialdir $fileDir] } $pathName - test filebox-2.3 "$command command" { + test filebox-2.3 "$command command" {nonUnixUserInteraction} { ToEnterFileByKey $parent $fileName $fileDir set choice [$command -title "Enter \"$fileName\" and press Ok" \ -parent $parent -initialdir $fileDir] } $pathName - test filebox-2.4 "$command command" { + test filebox-2.4 "$command command" {nonUnixUserInteraction} { ToPressButton $parent ok set choice [$command -title "Enter \"$fileName\" and press Ok" \ -parent $parent -initialdir . \ -initialfile $fileName] } $pathName - test filebox-2.5 "$command command" { + test filebox-2.5 "$command command" {nonUnixUserInteraction} { ToPressButton $parent ok set choice [$command -title "Enter \"$fileName\" and press Ok" \ -parent $parent -initialdir /badpath \ -initialfile $fileName] } $pathName - test filebox-2.6 "$command command" { + test filebox-2.6 "$command command" {nonUnixUserInteraction} { toplevel .t1; toplevel .t2 ToPressButton .t1 ok set choice {} @@ -264,7 +266,7 @@ foreach mode $modes { } foreach x [lsort -integer [array names filters]] { - test filebox-3.$x "$command command" { + test filebox-3.$x "$command command" {nonUnixUserInteraction} { ToPressButton $parent ok set choice [$command -title "Press Ok" -filetypes $filters($x)\ -parent $parent -initialfile $fileName -initialdir $fileDir] @@ -288,12 +290,6 @@ foreach mode $modes { set tk_strictMotif $tk_strictMotif_old -if {$isNative && ![info exists tcl_interactive]} { - puts " Some tests were skipped because they could not be performed" - puts " automatically on this platform. If you wish to execute them" - puts " run them in an interactive shell." -} - # cleanup ::tcltest::cleanupTests return diff --git a/tests/font.test b/tests/font.test index 290361e..0b40239 100644 --- a/tests/font.test +++ b/tests/font.test @@ -6,17 +6,18 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: font.test,v 1.1.4.5 1999/03/24 02:54:41 hershey Exp $ +# RCS: @(#) $Id: font.test,v 1.1.4.6 1999/03/26 00:07:56 hershey Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} if {[info commands testfont] != "testfont"} { puts "testfont command not available; skipping tests" + ::tcltest::cleanupTests return } -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - catch {destroy .b} toplevel .b wm geom .b +0+0 diff --git a/tests/id.test b/tests/id.test index 058febc..6d5854f 100644 --- a/tests/id.test +++ b/tests/id.test @@ -6,7 +6,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: id.test,v 1.1.4.4 1999/03/24 02:54:44 hershey Exp $ +# RCS: @(#) $Id: id.test,v 1.1.4.5 1999/03/26 00:07:57 hershey Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { source [file join [pwd] [file dirname [info script]] defs.tcl] @@ -15,6 +15,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { if {[string compare testwrapper [info commands testwrapper]] != 0} { puts "This application hasn't been compiled with the testwrapper command," puts "therefore I am skipping all of these tests." + ::tcltest::cleanupTests return } diff --git a/tests/image.test b/tests/image.test index e54ed40..c4b7a1f 100644 --- a/tests/image.test +++ b/tests/image.test @@ -7,19 +7,20 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: image.test,v 1.1.4.4 1999/03/24 02:54:45 hershey Exp $ +# RCS: @(#) $Id: image.test,v 1.1.4.5 1999/03/26 00:07:57 hershey Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} if {[lsearch [image types] test] < 0} { puts "This application hasn't been compiled with the \"test\" image" puts "type, so I can't run this test. Are you sure you're using" puts "tktest instead of wish?" + ::tcltest::cleanupTests return } -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - foreach i [winfo children .] { destroy $i } diff --git a/tests/macEmbed.test b/tests/macEmbed.test index 6f9a908..11288f8 100644 --- a/tests/macEmbed.test +++ b/tests/macEmbed.test @@ -6,7 +6,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: macEmbed.test,v 1.1.4.4 1999/03/24 02:54:48 hershey Exp $ +# RCS: @(#) $Id: macEmbed.test,v 1.1.4.5 1999/03/26 00:07:58 hershey Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { source [file join [pwd] [file dirname [info script]] defs.tcl] @@ -29,6 +29,7 @@ test macEmbed-1.2 {TkpUseWindow procedure, bad window identifier} {macOnly} { 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." + ::tcltest::cleanupTests return } diff --git a/tests/macFont.test b/tests/macFont.test index ade2af1..7ef43df 100644 --- a/tests/macFont.test +++ b/tests/macFont.test @@ -10,17 +10,18 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: macFont.test,v 1.1.4.5 1999/03/24 02:54:49 hershey Exp $ +# RCS: @(#) $Id: macFont.test,v 1.1.4.6 1999/03/26 00:07:59 hershey Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} if {$tcl_platform(platform)!="macintosh"} { puts "skipping: Mac only tests..." + ::tcltest::cleanupTests return } -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - catch {destroy .b} toplevel .b update idletasks diff --git a/tests/macMenu.test b/tests/macMenu.test index 1be6095..dd6cf23 100644 --- a/tests/macMenu.test +++ b/tests/macMenu.test @@ -7,10 +7,15 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: macMenu.test,v 1.1.4.4 1999/03/24 02:54:49 hershey Exp $ +# RCS: @(#) $Id: macMenu.test,v 1.1.4.5 1999/03/26 00:07:59 hershey Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} if {$tcl_platform(platform) != "macintosh"} { puts "skipping: Mac only tests..." + ::tcltest::cleanupTests return } @@ -18,13 +23,10 @@ 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 } -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - proc deleteWindows {} { foreach i [winfo children .] { catch [destroy $i] diff --git a/tests/macWinMenu.test b/tests/macWinMenu.test index 6c55470..da19638 100644 --- a/tests/macWinMenu.test +++ b/tests/macWinMenu.test @@ -6,23 +6,24 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: macWinMenu.test,v 1.1.4.4 1999/03/24 02:54:50 hershey Exp $ +# RCS: @(#) $Id: macWinMenu.test,v 1.1.4.5 1999/03/26 00:08:00 hershey Exp $ -if {$tcl_platform(platform) == "unix"} { - puts "skipping: Unix only tests..." - return +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } if {[lsearch [image types] test] < 0} { puts "This application hasn't been compiled with the \"test\" image" puts "type, so I can't run this test. Are you sure you're using" puts "tktest instead of wish?" + ::tcltest::cleanupTests return } -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} +# Some tests require user interaction on non-unix platform +set ::tcltest::testConfig(nonUnixUserInteraction) \ + [expr {$::tcltest::testConfig(userInteraction) || \ + $::tcltest::testConfig(unixOnly)}] proc deleteWindows {} { foreach i [winfo children .] { @@ -34,32 +35,26 @@ deleteWindows wm geometry . {} raise . -if {$tcl_platform(platform) == "windows" && ![info exists tcl_interactive]} { - puts " Some tests were skipped because they could not be performed" - puts " automatically on this platform. If you wish to execute them" - puts " run them in an tcl_interactive shell." -} - -test macWinMenu-1.1 {PreprocessMenu} { +test macWinMenu-1.1 {PreprocessMenu} {macOrPc nonUnixUserInteraction} { catch {destroy .m1} menu .m1 -postcommand "destroy .m1" .m1 add command -label "macWinMenu-1.1: Hit Escape" list [catch {.m1 post 40 40} msg] $msg } {0 {}} -if {$tcl_platform(platform) != "windows" || [info exists tcl_interactive]} { - test macWinMenu-1.2 {PreprocessMenu} { - catch {destroy .m1} - catch {destroy .m2} - set foo1 foo - set foo2 foo - menu .m1 -postcommand "set foo1 .m1" - .m1 add cascade -menu .m2 -label "macWinMenu-1.2: Hit Escape" - menu .m2 -postcommand "set foo2 .m2" - update idletasks - list [catch {.m1 post 40 40} msg] $msg [set foo1] [set foo2] [destroy .m1 .m2] [catch {unset foo1}] [catch {unset foo2}] - } {0 .m2 .m1 .m2 {} 0 0} -} -test macWinMenu-1.3 {PreprocessMenu} { +test macWinMenu-1.2 {PreprocessMenu} {macOrPc nonUnixUserInteraction} { + catch {destroy .m1} + catch {destroy .m2} + set foo1 foo + set foo2 foo + menu .m1 -postcommand "set foo1 .m1" + .m1 add cascade -menu .m2 -label "macWinMenu-1.2: Hit Escape" + menu .m2 -postcommand "set foo2 .m2" + update idletasks + list [catch {.m1 post 40 40} msg] $msg [set foo1] [set foo2] \ + [destroy .m1 .m2] [catch {unset foo1}] [catch {unset foo2}] +} {0 .m2 .m1 .m2 {} 0 0} + +test macWinMenu-1.3 {PreprocessMenu} {macOrPc nonUnixUserInteraction} { catch {destroy .l1} catch {destroy .m1} catch {destroy .m2} @@ -75,7 +70,7 @@ test macWinMenu-1.3 {PreprocessMenu} { update idletasks list [catch {.m1 post 40 40} msg] $msg [destroy .l1 .m2 .m3] } {0 {} {}} -test macWinMenu-1.4 {PreprocessMenu} { +test macWinMenu-1.4 {PreprocessMenu} {macOrPc} { catch {destroy .l1} catch {destroy .m1} catch {destroy .m2} @@ -94,7 +89,7 @@ test macWinMenu-1.4 {PreprocessMenu} { update idletasks list [catch {.m1 post 40 40} msg] $msg [destroy .l1 .m2 .m3 .m4] } {0 {} {}} -test macWinMenu-1.5 {PreprocessMenu} { +test macWinMenu-1.5 {PreprocessMenu} {macOrPc} { catch {destroy .m1} catch {destroy .m2} menu .m1 @@ -103,15 +98,13 @@ test macWinMenu-1.5 {PreprocessMenu} { list [catch {.m1 post 40 40} msg] $msg [destroy .m1 .m2] } {1 {invalid command name "glorp"} {}} -if {$tcl_platform(platform) != "windows" || [info exists tcl_interactive]} { - test macWinMenu-2.1 {TkPreprocessMenu} { - catch {destroy .m1} - set foo test - menu .m1 -postcommand "set foo 2.1" - .m1 add command -label "macWinMenu-2.1: Hit Escape" - list [catch {.m1 post 40 40} msg] $msg [set foo] [destroy .m1] [unset foo] - } {0 2.1 2.1 {} {}} -} +test macWinMenu-2.1 {TkPreprocessMenu} {macOrPc nonUnixUserInteraction} { + catch {destroy .m1} + set foo test + menu .m1 -postcommand "set foo 2.1" + .m1 add command -label "macWinMenu-2.1: Hit Escape" + list [catch {.m1 post 40 40} msg] $msg [set foo] [destroy .m1] [unset foo] +} {0 2.1 2.1 {} {}} # cleanup deleteWindows diff --git a/tests/macscrollbar.test b/tests/macscrollbar.test index e9c4aca..14c8533 100644 --- a/tests/macscrollbar.test +++ b/tests/macscrollbar.test @@ -7,18 +7,19 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: macscrollbar.test,v 1.1.4.4 1999/03/24 02:54:51 hershey Exp $ +# RCS: @(#) $Id: macscrollbar.test,v 1.1.4.5 1999/03/26 00:08:00 hershey Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} # Only run this test on the Macintosh if {$tcl_platform(platform) != "macintosh"} { puts "skipping: Mac only tests..." + ::tcltest::cleanupTests return } -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - foreach i [winfo children .] { destroy $i } diff --git a/tests/menu.test b/tests/menu.test index 8944a3d..0405f33 100644 --- a/tests/menu.test +++ b/tests/menu.test @@ -5,18 +5,24 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: menu.test,v 1.1.4.6 1999/03/24 02:54:52 hershey Exp $ +# RCS: @(#) $Id: menu.test,v 1.1.4.7 1999/03/26 00:08:01 hershey Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} if {[lsearch [image types] test] < 0} { puts "This application hasn't been compiled with the \"test\" image" puts "type, so I can't run this test. Are you sure you're using" puts "tktest instead of wish?" + ::tcltest::cleanupTests return } -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} +# Some tests require user interaction on non-unix platform +set ::tcltest::testConfig(nonUnixUserInteraction) \ + [expr {$::tcltest::testConfig(userInteraction) || \ + $::tcltest::testConfig(unixOnly)}] proc deleteWindows {} { foreach i [winfo children .] { @@ -527,7 +533,7 @@ test menu-3.1 {MenuWidgetCmd procedure} { menu .m1 list [catch {.m1} msg] $msg [destroy .m1] } {1 {wrong # args: should be ".m1 option ?arg arg ...?"} {}} -test menu-3.2 {MenuWidgetCmd, Tcl_Preserve and Tcl_Release} {pcOnly interactive} { +test menu-3.2 {MenuWidgetCmd, Tcl_Preserve and Tcl_Release} {nonUnixUserInteraction } { catch {destroy .m1} menu .m1 -postcommand "destroy .m1" .m1 add command -label "menu-3.2: Hit Escape" @@ -798,7 +804,7 @@ test menu-3.49 {MenuWidgetCmd procedure, "post" option} { menu .m1 list [catch {.m1 post 40 bar} msg] $msg [destroy .m1] } {1 {expected integer but got "bar"} {}} -test menu-3.50 {MenuWidgetCmd procedure, "post" option} {pcOnly interactive} { +test menu-3.50 {MenuWidgetCmd procedure, "post" option} {nonUnixUserInteraction } { catch {destroy .m1} menu .m1 .m1 add command -label "menu-3.53: hit Escape" -command "puts hello" @@ -814,7 +820,7 @@ test menu-3.52 {MenuWidgetCmd procedure, "postcascade" option} { menu .m1 list [catch {.m1 postcascade foo} msg] $msg [destroy .m1] } {1 {bad menu entry index "foo"} {}} -test menu-3.53 {MenuWidgetCmd procedure, "postcascade" option} {pcOnly interactive} { +test menu-3.53 {MenuWidgetCmd procedure, "postcascade" option} {nonUnixUserInteraction } { catch {destroy .m1} catch {destroy .m2} menu .m1 @@ -883,7 +889,7 @@ test menu-3.63 {MenuWidgetCmd procedure, "unpost" option} { menu .m1 list [catch {.m1 unpost foo} msg] $msg [destroy .m1] } {1 {wrong # args: should be ".m1 unpost"} {}} -test menu-3.64 {MenuWidgetCmd procedure, "unpost" option} {pcOnly interactive} { +test menu-3.64 {MenuWidgetCmd procedure, "unpost" option} {nonUnixUserInteraction } { catch {destroy .m1} menu .m1 .m1 add command -label "menu-3.68 - hit Escape" @@ -1991,13 +1997,13 @@ test menu-18.4 {TkActivateMenuEntry} { list [catch {.m1 activate 1} msg] $msg [destroy .m1] } {0 {} {}} -test menu-19.1 {TkPostCommand} {pcOnly interactive} { +test menu-19.1 {TkPostCommand} {nonUnixUserInteraction } { catch {destroy .m1} menu .m1 -postcommand "set menu_test menu-19.1" .m1 add command -label "menu-19.1 - hit Escape" list [catch {.m1 post 40 40} msg] $msg [.m1 unpost] [set menu_test] [destroy .m1] } {0 menu-19.1 {} menu-19.1 {}} -test menu-19.2 {TkPostCommand} {pcOnly interactive} { +test menu-19.2 {TkPostCommand} {nonUnixUserInteraction } { catch {destroy .m1} menu .m1 .m1 add command -label "menu-19.2 - hit Escape" diff --git a/tests/menuDraw.test b/tests/menuDraw.test index e6d6157..87c99fe 100644 --- a/tests/menuDraw.test +++ b/tests/menuDraw.test @@ -5,19 +5,20 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: menuDraw.test,v 1.1.4.5 1999/03/24 02:54:52 hershey Exp $ +# RCS: @(#) $Id: menuDraw.test,v 1.1.4.6 1999/03/26 00:08:02 hershey Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} if {[lsearch [image types] test] < 0} { puts "This application hasn't been compiled with the \"test\" image" puts "type, so I can't run this test. Are you sure you're using" puts "tktest instead of wish?" + ::tcltest::cleanupTests return } -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - proc deleteWindows {} { foreach i [winfo children .] { catch [destroy $i] @@ -180,7 +181,7 @@ test menuDraw-7.2 {TkEventuallyRecomputeMenu - update pending} { } {{} {}} -test menuDraw-8.1 {TkRecomputeMenu} {pcOnly interactive} { +test menuDraw-8.1 {TkRecomputeMenu} {pcOnly userInteraction} { catch {destroy .m1} menu .m1 .m1 configure -postcommand [.m1 add command -label foo] @@ -495,7 +496,7 @@ test menuDraw-16.5 {TkPostSubMenu} {unixOnly} { set tearoff [tkTearOffMenu .m1 40 40] list [catch {$tearoff postcascade test} msg] $msg [destroy .m1] [destroy .m2] } {1 {invalid command name "glorp"} {} {}} -test menuDraw-16.6 {TkPostSubMenu} {pcOnly interactive} { +test menuDraw-16.6 {TkPostSubMenu} {pcOnly userInteraction} { catch {destroy .m1} catch {destroy .m2} menu .m1 @@ -521,7 +522,7 @@ test menuDraw-17.1 {AdjustMenuCoords - menubar} {unixOnly} { } list [$w postcascade 0] [. configure -menu ""] [destroy .m1] [destroy .m2] } {{} {} {} {}} -test menuDraw-17.2 {AdjustMenuCoords - menu} {pcOnly interactive} { +test menuDraw-17.2 {AdjustMenuCoords - menu} {pcOnly userInteraction} { catch {destroy .m1} catch {destroy .m2} menu .m1 diff --git a/tests/menubut.test b/tests/menubut.test index a77b628..9f27158 100644 --- a/tests/menubut.test +++ b/tests/menubut.test @@ -6,23 +6,24 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: menubut.test,v 1.1.4.5 1999/03/24 02:54:53 hershey Exp $ +# RCS: @(#) $Id: menubut.test,v 1.1.4.6 1999/03/26 00:08:02 hershey Exp $ # XXX This test file is woefully incomplete right now. If any part # XXX of a procedure has tests then the whole procedure has tests, # XXX but many procedures have no tests. +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + if {[lsearch [image types] test] < 0} { puts "This application hasn't been compiled with the \"test\" image" puts "type, so I can't run this test. Are you sure you're using" puts "tktest instead of wish?" + ::tcltest::cleanupTests return } -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - foreach i [winfo children .] { destroy $i } @@ -323,7 +324,7 @@ test menubutton-7.14 {ComputeMenuButtonGeometry procedure} {unixOnly nonPortable pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] } {64 23} -test menubutton-7.15 {ComputeMenuButtonGeometry procedure} {pc nonPortable} { +test menubutton-7.15 {ComputeMenuButtonGeometry procedure} {pcOnly nonPortable} { # The following test is non-portable because the indicator's pixel # size varies to maintain constant absolute size. diff --git a/tests/msgbox.test b/tests/msgbox.test index 961c3ef..b7d63fe 100644 --- a/tests/msgbox.test +++ b/tests/msgbox.test @@ -5,13 +5,18 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: msgbox.test,v 1.1.4.6 1999/03/24 02:54:53 hershey Exp $ +# RCS: @(#) $Id: msgbox.test,v 1.1.4.7 1999/03/26 00:08:03 hershey Exp $ # if {[lsearch [namespace children] ::tcltest] == -1} { source [file join [pwd] [file dirname [info script]] defs.tcl] } +# Some tests require user interaction on non-unix platform +set ::tcltest::testConfig(nonUnixUserInteraction) \ + [expr {$::tcltest::testConfig(userInteraction) || \ + $::tcltest::testConfig(unixOnly)}] + test msgbox-1.1 {tk_messageBox command} { list [catch {tk_messageBox -foo} msg] $msg } {1 {bad option "-foo": must be -default, -icon, -message, -parent, -title, or -type}} @@ -39,17 +44,25 @@ test msgbox-1.5 {tk_messageBox command} { list [catch {tk_messageBox -type foo} msg] $msg } {1 {bad -type value "foo": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel}} +proc createPlatformMsg {val} { + global tcl_platform + if {$tcl_platform(platform) == "unix"} { + return "invalid default button \"$val\"" + } + return "bad -default value \"$val\": must be abort, retry, ignore, ok, cancel, no, or yes" +} + test msgbox-1.6 {tk_messageBox command} { list [catch {tk_messageBox -default 1.1} msg] $msg -} {1 {invalid default button "1.1"}} +} [list 1 [createPlatformMsg "1.1"]] test msgbox-1.7 {tk_messageBox command} { list [catch {tk_messageBox -default foo} msg] $msg -} {1 {invalid default button "foo"}} +} [list 1 [createPlatformMsg "foo"]] test msgbox-1.8 {tk_messageBox command} { list [catch {tk_messageBox -type yesno -default 3} msg] $msg -} {1 {invalid default button "3"}} +} [list 1 [createPlatformMsg "3"]] test msgbox-1.9 {tk_messageBox command} { list [catch {tk_messageBox -icon foo} msg] $msg @@ -65,13 +78,6 @@ if {[info commands tkMessageBox] == ""} { set isNative 0 } -if {$isNative && ![info exists tcl_interactive]} { - puts " Some tests were skipped because they could not be performed" - puts " automatically on this platform. If you wish to execute them" - puts " run them in an tcl_interactive shell." - return -} - proc ChooseMsg {parent btn} { global isNative if {!$isNative} { @@ -126,31 +132,36 @@ set specs { # Try out all combinations of (type) x (default button) and # (type) x (icon). # +set count 1 foreach spec $specs { set type [lindex $spec 0] set buttons [lindex $spec 3] set button [lindex $buttons 0] - test msgbox-2.1 {tk_messageBox command} { + test msgbox-2.$count {tk_messageBox command} {nonUnixUserInteraction} { ChooseMsg $parent $button tk_messageBox -title Hi -message "Please press $button" \ -type $type } $button + incr count foreach icon {warning error info question} { - test msgbox-2.2 {tk_messageBox command -icon option} { + test msgbox-2.$count {tk_messageBox command -icon option} \ + {nonUnixUserInteraction} { ChooseMsg $parent $button tk_messageBox -title Hi -message "Please press $button" \ -type $type -icon $icon } $button + incr count } foreach button $buttons { - test msgbox-2.3 {tk_messageBox command} { + test msgbox-2.$count {tk_messageBox command} {nonUnixUserInteraction} { ChooseMsg $parent $button tk_messageBox -title Hi -message "Please press $button" \ -type $type -default $button } "$button" + incr count } } diff --git a/tests/option.test b/tests/option.test index f6e8935..96f26b6 100644 --- a/tests/option.test +++ b/tests/option.test @@ -6,7 +6,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: option.test,v 1.1.4.4 1999/03/24 02:54:55 hershey Exp $ +# RCS: @(#) $Id: option.test,v 1.1.4.5 1999/03/26 00:08:04 hershey Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { source [file join [pwd] [file dirname [info script]] defs.tcl] @@ -185,15 +185,9 @@ test option-14.12 {error conditions} { list [catch {option get .gorp.gorp a A} msg] $msg } {1 {bad window path name ".gorp.gorp"}} -if {$tcl_platform(os) == "Win32s"} { - set option1 [file join $::tcltest::testsDir OPTION~2.FIL] - set option2 [file join $::tcltest::testsDir OPTION~1.FIL] - set option3 [file join $::tcltest::testsDir OPTION~3.FIL] -} else { - set option1 [file join $::tcltest::testsDir option.file1] - set option2 [file join $::tcltest::testsDir option.file2] - set option3 [file join $::tcltest::testsDir option.file3] -} +set option1 [file join $::tcltest::testsDir option.file1] +set option2 [file join $::tcltest::testsDir option.file2] +set option3 [file join $::tcltest::testsDir option.file3] test option-15.1 {database files} { list [catch {option read non-existent} msg] $msg diff --git a/tests/scrollbar.test b/tests/scrollbar.test index 0843bff..2aee773 100644 --- a/tests/scrollbar.test +++ b/tests/scrollbar.test @@ -7,7 +7,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: scrollbar.test,v 1.1.4.4 1999/03/24 02:54:59 hershey Exp $ +# RCS: @(#) $Id: scrollbar.test,v 1.1.4.5 1999/03/26 00:08:04 hershey Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { source [file join [pwd] [file dirname [info script]] defs.tcl] @@ -169,13 +169,13 @@ test scrollbar-3.10 {ScrollbarWidgetCmd procedure, "cget" option} { list [catch {.s cget -orient} msg] $msg } {0 vertical} scrollbar .s2 -test scrollbar-3.11 {ScrollbarWidgetCmd procedure, "cget" option} {pc} { +test scrollbar-3.11 {ScrollbarWidgetCmd procedure, "cget" option} {pcOnly} { list [catch {.s2 cget -bd} msg] $msg } {0 0} test scrollbar-3.12 {ScrollbarWidgetCmd procedure, "cget" option} {macOrUnix} { list [catch {.s2 cget -bd} msg] $msg } {0 2} -test scrollbar-3.13 {ScrollbarWidgetCmd procedure, "cget" option} {pc} { +test scrollbar-3.13 {ScrollbarWidgetCmd procedure, "cget" option} {pcOnly} { list [catch {.s2 cget -highlightthickness} msg] $msg } {0 0} test scrollbar-3.14 {ScrollbarWidgetCmd procedure, "cget" option} {macOrUnix} { diff --git a/tests/send.test b/tests/send.test index 7976bc2..11f50c9 100644 --- a/tests/send.test +++ b/tests/send.test @@ -7,24 +7,28 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: send.test,v 1.1.4.6 1999/03/24 02:55:00 hershey Exp $ +# RCS: @(#) $Id: send.test,v 1.1.4.7 1999/03/26 00:08:05 hershey Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} if {$tcl_platform(platform) == "macintosh"} { puts "send is not available on the Mac - skipping tests" + ::tcltest::cleanupTests return } if {$tcl_platform(platform) == "window"} { puts "send is not available under Windows - skipping tests" + ::tcltest::cleanupTests return } if {[auto_execok xhost] == ""} { puts "xhost application isn't available - skipping tests" + ::tcltest::cleanupTests return } -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} if {[info commands testsend] == "testsend"} { set gotTestCmds 1 } else { @@ -47,6 +51,7 @@ if {[catch {send $app set a 0} msg] == 1} { puts -nonewline "Your X server is insecure, so \"send\" can't be used;" puts " skipping \"send\" tests." cleanupbg + ::tcltest::cleanupTests return } } diff --git a/tests/textMark.test b/tests/textMark.test index 5d7f3cd..6145d33 100644 --- a/tests/textMark.test +++ b/tests/textMark.test @@ -6,7 +6,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: textMark.test,v 1.1.4.5 1999/03/24 02:55:04 hershey Exp $ +# RCS: @(#) $Id: textMark.test,v 1.1.4.6 1999/03/26 00:08:06 hershey Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { source [file join [pwd] [file dirname [info script]] defs.tcl] @@ -16,6 +16,7 @@ catch {destroy .t} if [catch {text .t -font {Courier 12} -width 20 -height 10}] { puts "The font needed by these tests isn't available, so I'm" puts "going to skip the tests." + ::tcltest::cleanupTests return } pack append . .t {top expand fill} diff --git a/tests/textTag.test b/tests/textTag.test index 0b80d6d..7bc5d10 100644 --- a/tests/textTag.test +++ b/tests/textTag.test @@ -6,7 +6,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: textTag.test,v 1.1.4.5 1999/03/24 02:55:04 hershey Exp $ +# RCS: @(#) $Id: textTag.test,v 1.1.4.6 1999/03/26 00:08:06 hershey Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { source [file join [pwd] [file dirname [info script]] defs.tcl] @@ -16,6 +16,7 @@ catch {destroy .t} if [catch {text .t -font {Courier 12} -width 20 -height 10}] { puts "The font needed by these tests isn't available, so I'm" puts "going to skip the tests." + ::tcltest::cleanupTests return } pack append . .t {top expand fill} diff --git a/tests/unixButton.test b/tests/unixButton.test index d09e8c7..30a270d 100644 --- a/tests/unixButton.test +++ b/tests/unixButton.test @@ -8,10 +8,15 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: unixButton.test,v 1.1.4.4 1999/03/24 02:55:06 hershey Exp $ +# RCS: @(#) $Id: unixButton.test,v 1.1.4.5 1999/03/26 00:08:07 hershey 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 } @@ -19,13 +24,10 @@ 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 } -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - foreach i [winfo children .] { destroy $i } diff --git a/tests/unixEmbed.test b/tests/unixEmbed.test index 116f912..64e7d08 100644 --- a/tests/unixEmbed.test +++ b/tests/unixEmbed.test @@ -6,17 +6,18 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: unixEmbed.test,v 1.1.4.5 1999/03/24 02:55:07 hershey Exp $ +# RCS: @(#) $Id: unixEmbed.test,v 1.1.4.6 1999/03/26 00:08:07 hershey 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 [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - eval destroy [winfo children .] wm geometry . {} raise . @@ -101,6 +102,7 @@ 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 } diff --git a/tests/unixFont.test b/tests/unixFont.test index 6dcddbd..5de7d6d 100644 --- a/tests/unixFont.test +++ b/tests/unixFont.test @@ -12,17 +12,18 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: unixFont.test,v 1.1.4.5 1999/03/24 02:55:07 hershey Exp $ +# RCS: @(#) $Id: unixFont.test,v 1.1.4.6 1999/03/26 00:08:08 hershey 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 [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - catch {destroy .b} toplevel .b wm geom .b +0+0 diff --git a/tests/unixMenu.test b/tests/unixMenu.test index 359c99d..9189ab6 100644 --- a/tests/unixMenu.test +++ b/tests/unixMenu.test @@ -7,10 +7,15 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: unixMenu.test,v 1.1.4.5 1999/03/24 02:55:08 hershey Exp $ +# RCS: @(#) $Id: unixMenu.test,v 1.1.4.6 1999/03/26 00:08:09 hershey 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 } @@ -18,13 +23,10 @@ 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 } -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - proc deleteWindows {} { foreach i [winfo children .] { catch [destroy $i] diff --git a/tests/unixSend.test b/tests/unixSend.test index b17cf5a..f5f7ef0 100644 --- a/tests/unixSend.test +++ b/tests/unixSend.test @@ -7,25 +7,28 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: unixSend.test,v 1.1.2.5 1999/03/24 02:55:09 hershey Exp $ +# RCS: @(#) $Id: unixSend.test,v 1.1.2.6 1999/03/26 00:08:09 hershey Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} if {$tcl_platform(platform) == "macintosh"} { puts "send is not available on the Mac - skipping tests" + ::tcltest::cleanupTests return } if {$tcl_platform(platform) == "windows"} { puts "skipping: Unix only tests..." + ::tcltest::cleanupTests return } if {[auto_execok xhost] == ""} { puts "xhost application isn't available - skipping tests" + ::tcltest::cleanupTests return } -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - if {[info commands testsend] == "testsend"} { set gotTestCmds 1 } else { @@ -48,6 +51,7 @@ if {[catch {send $app set a 0} msg] == 1} { puts -nonewline "Your X server is insecure, so \"send\" can't be used;" puts " skipping \"send\" tests." cleanupbg + ::tcltest::cleanupTests return } } diff --git a/tests/unixWm.test b/tests/unixWm.test index b14eb60..f905b9d 100644 --- a/tests/unixWm.test +++ b/tests/unixWm.test @@ -7,17 +7,18 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: unixWm.test,v 1.1.4.7 1999/03/24 02:55:09 hershey Exp $ +# RCS: @(#) $Id: unixWm.test,v 1.1.4.8 1999/03/26 00:08:10 hershey 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 [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - proc sleep ms { global x after $ms {set x 1} @@ -195,7 +196,7 @@ test unixWm-6.3 {size changes} { update wm geom .t } 170x140+10+10 -test unixWm-6.4 {size changes} {nonPortable} { +test unixWm-6.4 {size changes} {nonPortable userInteraction} { wm minsize .t 1 1 update puts stdout "Please resize window \"t\" with the mouse (but don't move it!)," @@ -355,6 +356,7 @@ test unixWm-8.9 {icon windows} {nonPortable} { if {[string compare testwrapper [info commands testwrapper]] != 0} { puts "This application hasn't been compiled with the testwrapper command," puts "therefore I am skipping all of these tests." + ::tcltest::cleanupTests return } diff --git a/tests/winButton.test b/tests/winButton.test index c709a26..2795482 100644 --- a/tests/winButton.test +++ b/tests/winButton.test @@ -8,19 +8,20 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: winButton.test,v 1.1.4.4 1999/03/24 02:55:11 hershey Exp $ +# RCS: @(#) $Id: winButton.test,v 1.1.4.5 1999/03/26 00:08:11 hershey Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} if {[lsearch [image types] test] < 0} { puts "This application hasn't been compiled with the \"test\"" puts "image, so I can't run this test. Are you sure you're using" puts "tktest instead of wish?" + ::tcltest::cleanupTests return } -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - foreach i [winfo children .] { destroy $i } diff --git a/tests/winDialog.test b/tests/winDialog.test index ede067f..c7417f4 100644 --- a/tests/winDialog.test +++ b/tests/winDialog.test @@ -6,17 +6,18 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: winDialog.test,v 1.1.2.6 1999/03/24 02:55:12 hershey Exp $ +# RCS: @(#) $Id: winDialog.test,v 1.1.2.7 1999/03/26 00:08:11 hershey Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} if {[info command testwinevent] == ""} { puts "skipping: tests require the testwinevent command" + ::tcltest::cleanupTests return } -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - testwinevent debug 1 eval destroy [winfo children .] diff --git a/tests/winMenu.test b/tests/winMenu.test index 1598274..3fddd68 100644 --- a/tests/winMenu.test +++ b/tests/winMenu.test @@ -7,19 +7,20 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: winMenu.test,v 1.1.4.5 1999/03/24 02:55:13 hershey Exp $ +# RCS: @(#) $Id: winMenu.test,v 1.1.4.6 1999/03/26 00:08:12 hershey Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} if {[lsearch [image types] test] < 0} { puts "This application hasn't been compiled with the \"test\" image" puts "type, so I can't run this test. Are you sure you're using" puts "tktest instead of wish?" + ::tcltest::cleanupTests return } -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - proc deleteWindows {} { foreach i [winfo children .] { catch [destroy $i] @@ -309,13 +310,13 @@ test winMenu-8.2 {TkpPostMenu} {pcOnly} { menu .m1 -postcommand "destroy .m1" list [.m1 post 40 40] [winfo exists .m1] } {{} 0} -test winMenu-8.3 {TkpPostMenu - popup menu} {pcOnly interactive} { +test winMenu-8.3 {TkpPostMenu - popup menu} {pcOnly userInteraction} { catch {destroy .m1} menu .m1 .m1 add command -label "winMenu-8.3: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] } {{} {}} -test winMenu-8.4 {TkpPostMenu - menu button} {pcOnly interactive} { +test winMenu-8.4 {TkpPostMenu - menu button} {pcOnly userInteraction} { catch {destroy .mb} menubutton .mb -text test -menu .mb.menu menu .mb.menu @@ -323,7 +324,7 @@ test winMenu-8.4 {TkpPostMenu - menu button} {pcOnly interactive} { pack .mb list [tkMbPost .mb] [destroy .m1] } {{} {}} -test winMenu-8.5 {TkpPostMenu - update not pending} {pcOnly interactive} { +test winMenu-8.5 {TkpPostMenu - update not pending} {pcOnly userInteraction} { catch {destroy .m1} menu .m1 .m1 add command -label "winMenu-8.5 - Hit ESCAPE." @@ -337,7 +338,7 @@ test winMenu-9.1 {TkpMenuNewEntry} {pcOnly} { list [catch {.m1 add command} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-10.1 {TkwinMenuProc} {pcOnly interactive} { +test winMenu-10.1 {TkwinMenuProc} {pcOnly userInteraction} { catch {destroy .m1} menu .m1 .m1 add command -label "winMenu-10.1: Hit ESCAPE." @@ -345,21 +346,21 @@ test winMenu-10.1 {TkwinMenuProc} {pcOnly interactive} { } {{} {}} # Can't generate a WM_INITMENU without a Tk menu yet. -test winMenu-11.1 {TkWinHandleMenuEvent - WM_INITMENU} {pcOnly interactive} { +test winMenu-11.1 {TkWinHandleMenuEvent - WM_INITMENU} {pcOnly userInteraction} { catch {destroy .m1} catch {unset foo} menu .m1 -postcommand "set foo test" .m1 add command -label "winMenu-11.1: Hit ESCAPE." list [.m1 post 40 40] [set foo] [unset foo] [destroy .m1] } {test test {} {}} -test winMenu-11.2 {TkWinHandleMenuEvent - WM_COMMAND} {pcOnly interactive} { +test winMenu-11.2 {TkWinHandleMenuEvent - WM_COMMAND} {pcOnly userInteraction} { catch {destroy .m1} catch {unset foo} menu .m1 .m1 add checkbutton -variable foo -label "winMenu-11.2: Please select this menu item." list [.m1 post 40 40] [update] [set foo] [unset foo] [destroy .m1] } {{} {} 1 {} {}} -test winMenu-11.3 {TkWinHandleMenuEvent - WM_COMMAND} {pcOnly interactive} { +test winMenu-11.3 {TkWinHandleMenuEvent - WM_COMMAND} {pcOnly userInteraction} { catch {destroy .m1} catch {unset foo} proc bgerror {args} { @@ -375,33 +376,33 @@ test winMenu-11.3 {TkWinHandleMenuEvent - WM_COMMAND} {pcOnly interactive} { (menu invoke)}} {} {}} # Can't test WM_MENUCHAR -test winMenu-11.4 {TkWinHandleMenuEvent - WM_MEASUREITEM} {pcOnly interactive} { +test winMenu-11.4 {TkWinHandleMenuEvent - WM_MEASUREITEM} {pcOnly userInteraction} { catch {destroy .m1} menu .m1 .m1 add command -label "winMenu-11.3: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] } {{} {}} -test winMenu-11.5 {TkWinHandleMenuEvent - WM_MEASUREITEM} {pcOnly interactive} { +test winMenu-11.5 {TkWinHandleMenuEvent - WM_MEASUREITEM} {pcOnly userInteraction} { catch {destroy .m1} menu .m1 .m1 add checkbutton -label "winMenu-11.4: Hit ESCAPE" -hidemargin 1 list [.m1 post 40 40] [destroy .m1] } {{} {}} -test winMenu-11.6 {TkWinHandleMenuEvent - WM_DRAWITEM} {pcOnly interactive} { +test winMenu-11.6 {TkWinHandleMenuEvent - WM_DRAWITEM} {pcOnly userInteraction} { catch {destroy .m1} menu .m1 .m1 add command -label "winMenu-11.5: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] } {{} {}} test winMenu-11.7 {TkWinHandleMenuEvent - WM_DRAWITEM - item disabled} \ - {pcOnly interactive} { + {pcOnly userInteraction} { catch {destroy .m1} menu .m1 .m1 add command -label "winMenu-11.6: Hit ESCAPE." -state disabled list [.m1 post 40 40] [destroy .m1] } {{} {}} test winMenu-11.8 {TkWinHandleMenuEvent - WM_INITMENU - not pending} \ - {pcOnly interactive} { + {pcOnly userInteraction} { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add command -label "winMenu-11.7: Hit ESCAPE" @@ -467,7 +468,7 @@ test winMenu-15.3 {GetMenuAccelGeometry} {pcOnly} { list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] } {0 {}} -test winMenu-16.1 {GetTearoffEntryGeometry} {pcOnly interactive} { +test winMenu-16.1 {GetTearoffEntryGeometry} {pcOnly userInteraction} { catch {destroy .m1} menu .m1 .m1 add command -label "winMenu-19.1: Hit ESCAPE." @@ -578,7 +579,7 @@ test winMenu-20.4 {DrawMenuEntryAccelerator - cascade, drawArrow true} {pcOnly} list [update] [destroy .m1] } {{} {}} test winMenu-20.5 {DrawMenuEntryAccelerator - cascade, drawArrow false} \ - {pcOnly interactive} { + {pcOnly userInteraction} { catch {destroy .m1} menu .m1 .m1 add cascade -label "winMenu-23.5: Hit ESCAPE." @@ -635,7 +636,7 @@ test winMenu-26.1 {TkpComputeMenubarGeometry} {pcOnly} { list [. configure -menu .m1] [. configure -menu ""] [destroy .m1] } {{} {} {}} -test winMenu-27.1 {DrawTearoffEntry} {pcOnly interactive} { +test winMenu-27.1 {DrawTearoffEntry} {pcOnly userInteraction} { catch {destroy .m1} menu .m1 .m1 add command -label "winMenu-24.4: Hit ESCAPE." diff --git a/tests/winSend.test b/tests/winSend.test index f047b8f..ce1a9a6 100644 --- a/tests/winSend.test +++ b/tests/winSend.test @@ -7,17 +7,18 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: winSend.test,v 1.1.2.5 1999/03/24 02:55:14 hershey Exp $ +# RCS: @(#) $Id: winSend.test,v 1.1.2.6 1999/03/26 00:08:12 hershey Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} if {$tcl_platform(platform) != "windows"} { puts "skipping: Windows only tests..." + ::tcltest::cleanupTests return } -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - foreach i [winfo children .] { destroy $i } @@ -28,6 +29,7 @@ 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; } @@ -70,7 +72,8 @@ foreach interp $newInterps { # it works first. if {[catch {send $interp {console hide; update}}] == 1} { puts "Could not send to child interpreter $interp" - return + ::tcltest::cleanupTests + return } # setting up dde server is done when the first interp is created and diff --git a/tests/window.test b/tests/window.test index a90a533..3e67adf 100644 --- a/tests/window.test +++ b/tests/window.test @@ -5,7 +5,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: window.test,v 1.1.4.4 1999/03/24 02:55:15 hershey Exp $ +# RCS: @(#) $Id: window.test,v 1.1.4.5 1999/03/26 00:08:13 hershey Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { source [file join [pwd] [file dirname [info script]] defs.tcl] @@ -79,13 +79,12 @@ test window-2.3 {Tk_DestroyWindow procedure, destroy handler deletes parent} { destroy .f } {} -if {[string compare testmenubar [info commands testmenubar]] != 0} { - puts "This application hasn't been compiled with the testmenubar command," - puts "therefore I am skipping all of these tests." - return -} +# Some tests require the testmenubar command +set ::tcltest::testConfig(testmenubar) \ + [expr {[info commands testmenubar] != {}}] -test window-3.1 {Tk_MakeWindowExist procedure, stacking order and menubars} unixOnly { +test window-3.1 {Tk_MakeWindowExist procedure, stacking order and menubars} \ + {unixOnly testmenubar} { catch {destroy .t} toplevel .t -width 300 -height 200 wm geometry .t +0+0 @@ -95,7 +94,8 @@ test window-3.1 {Tk_MakeWindowExist procedure, stacking order and menubars} unix update # If stacking order isn't handle properly, generates an X error. } {} -test window-3.2 {Tk_MakeWindowExist procedure, stacking order and menubars} unixOnly { +test window-3.2 {Tk_MakeWindowExist procedure, stacking order and menubars} \ + {unixOnly testmenubar} { catch {destroy .t} toplevel .t -width 300 -height 200 wm geometry .t +0+0 @@ -109,11 +109,11 @@ test window-3.2 {Tk_MakeWindowExist procedure, stacking order and menubars} unix # If stacking order isn't handled properly, generates an X error. } {} -test window-4.1 {Tk_NameToWindow procedure} { +test window-4.1 {Tk_NameToWindow procedure} {testmenubar} { catch {destroy .t} list [catch {winfo geometry .t} msg] $msg } {1 {bad window path name ".t"}} -test window-4.2 {Tk_NameToWindow procedure} { +test window-4.2 {Tk_NameToWindow procedure} {testmenubar} { catch {destroy .t} frame .t -width 100 -height 50 place .t -x 10 -y 10 @@ -121,7 +121,8 @@ test window-4.2 {Tk_NameToWindow procedure} { list [catch {winfo geometry .t} msg] $msg } {0 100x50+10+10} -test window-5.1 {Tk_MakeWindowExist procedure, stacking order and menubars} unixOnly { +test window-5.1 {Tk_MakeWindowExist procedure, stacking order and menubars} \ + {unixOnly testmenubar} { catch {destroy .t} toplevel .t -width 300 -height 200 wm geometry .t +0+0 |