summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorhershey <hershey>1999-03-26 00:07:49 (GMT)
committerhershey <hershey>1999-03-26 00:07:49 (GMT)
commit8ef1ceb8863bebe0af2419b9fa736601470af737 (patch)
tree52a68d75c6dbbed8bec457475298eeb85eea1eea
parent3b20040d0062aedf023c92942101d4d86bb40146 (diff)
downloadtk-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.
-rw-r--r--tests/bitmap.test3
-rw-r--r--tests/border.test5
-rw-r--r--tests/button.test11
-rw-r--r--tests/canvImg.test11
-rw-r--r--tests/canvRect.test4
-rw-r--r--tests/clrpick.test22
-rw-r--r--tests/color.test15
-rw-r--r--tests/config.test11
-rw-r--r--tests/cursor.test5
-rw-r--r--tests/defs.tcl31
-rw-r--r--tests/entry.test15
-rw-r--r--tests/filebox.test40
-rw-r--r--tests/font.test11
-rw-r--r--tests/id.test3
-rw-r--r--tests/image.test11
-rw-r--r--tests/macEmbed.test3
-rw-r--r--tests/macFont.test11
-rw-r--r--tests/macMenu.test12
-rw-r--r--tests/macWinMenu.test71
-rw-r--r--tests/macscrollbar.test11
-rw-r--r--tests/menu.test26
-rw-r--r--tests/menuDraw.test17
-rw-r--r--tests/menubut.test13
-rw-r--r--tests/msgbox.test39
-rw-r--r--tests/option.test14
-rw-r--r--tests/scrollbar.test6
-rw-r--r--tests/send.test13
-rw-r--r--tests/textMark.test3
-rw-r--r--tests/textTag.test3
-rw-r--r--tests/unixButton.test12
-rw-r--r--tests/unixEmbed.test12
-rw-r--r--tests/unixFont.test11
-rw-r--r--tests/unixMenu.test12
-rw-r--r--tests/unixSend.test14
-rw-r--r--tests/unixWm.test14
-rw-r--r--tests/winButton.test11
-rw-r--r--tests/winDialog.test11
-rw-r--r--tests/winMenu.test41
-rw-r--r--tests/winSend.test15
-rw-r--r--tests/window.test23
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