summaryrefslogtreecommitdiffstats
path: root/tests/clrpick.test
diff options
context:
space:
mode:
authorstanton <stanton>1999-04-16 01:51:06 (GMT)
committerstanton <stanton>1999-04-16 01:51:06 (GMT)
commit03656f44f81469f459031fa3a4a7b09c8bc77712 (patch)
tree31378e81bd58f8c726fc552d6b30cbf3ca07497b /tests/clrpick.test
parent404fc236f34304df53b7e44bc7971d786b87d453 (diff)
downloadtk-03656f44f81469f459031fa3a4a7b09c8bc77712.zip
tk-03656f44f81469f459031fa3a4a7b09c8bc77712.tar.gz
tk-03656f44f81469f459031fa3a4a7b09c8bc77712.tar.bz2
* Merged 8.1 branch into the main trunk
Diffstat (limited to 'tests/clrpick.test')
-rw-r--r--tests/clrpick.test107
1 files changed, 60 insertions, 47 deletions
diff --git a/tests/clrpick.test b/tests/clrpick.test
index a56b6b3..db101b8 100644
--- a/tests/clrpick.test
+++ b/tests/clrpick.test
@@ -2,22 +2,27 @@
# It is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: clrpick.test,v 1.2 1998/09/14 18:23:45 stanton Exp $
+# RCS: @(#) $Id: clrpick.test,v 1.3 1999/04/16 01:51:35 stanton Exp $
#
-if {[string compare test [info procs test]] == 1} {
- source defs
+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 {unknown option "-foo", must be -initialcolor, -parent or -title}}
+} {1 {bad option "-foo": must be -initialcolor, -parent, or -title}}
-catch {tk_chooseColor -foo} msg
+catch {tk_chooseColor -foo 1} msg
regsub -all , $msg "" options
regsub \"-foo\" $options "" options
@@ -31,7 +36,7 @@ foreach option $options {
test clrpick-1.3 {tk_chooseColor command} {
list [catch {tk_chooseColor -foo bar} msg] $msg
-} {1 {unknown option "-foo", must be -initialcolor, -parent or -title}}
+} {1 {bad option "-foo": must be -initialcolor, -parent, or -title}}
test clrpick-1.4 {tk_chooseColor command} {
list [catch {tk_chooseColor -initialcolor} msg] $msg
@@ -55,14 +60,6 @@ if {[info commands tkColorDialog] == ""} {
set isNative 0
}
-if {$isNative && ![info exists INTERACTIVE]} {
- puts " Some tests were skipped because they could not be performed"
- puts " automatically on this platform. If you wish to execute them"
- puts " interactively, set the TCL variable INTERACTIVE and re-run"
- puts " the test."
- return
-}
-
proc ToPressButton {parent btn} {
global isNative
if {!$isNative} {
@@ -141,8 +138,9 @@ set verylongstring $verylongstring$verylongstring
# let's soak up a bunch of colors...so that
# machines with small color palettes still fail.
+# some tests will be skipped if there are no more colors
set numcolors 32
-set nomorecolors 0
+set ::tcltest::testConfig(colorsLeftover) 1
set i 0
canvas .c
pack .c -expand 1 -fill both
@@ -160,7 +158,7 @@ while {$i<$numcolors} {
set g [expr $g/256]
set b [expr $b/256]
if {"$color" != "#[format %02x%02x%02x $r $g $b]"} {
- set nomorecolors 1
+ set ::tcltest::testConfig(colorsLeftover) 0
}
}
.c delete $i
@@ -169,47 +167,62 @@ while {$i<$numcolors} {
destroy .c
-if {!$nomorecolors} {
- set color #404040
- test clrpick-2.1 {tk_chooseColor command} {
- ToPressButton $parent ok
- tk_chooseColor -title "Press Ok $verylongstring" -initialcolor $color -parent $parent
- } "$color"
+set color #404040
+test clrpick-2.1 {tk_chooseColor command} \
+ {nonUnixUserInteraction colorsLeftover} {
+ ToPressButton $parent ok
+ tk_chooseColor -title "Press Ok $verylongstring" -initialcolor $color \
+ -parent $parent
+} "$color"
- set color #808040
- test clrpick-2.2 {tk_chooseColor command} {
- if {$tcl_platform(platform) == "macintosh"} {
- set colors "32768 32768 16384"
- } else {
- set colors "128 128 64"
- }
- ToChooseColorByKey $parent 128 128 64
- tk_chooseColor -parent $parent -title "choose $colors"
- } "$color"
+set color #808040
+test clrpick-2.2 {tk_chooseColor command} \
+ {nonUnixUserInteraction colorsLeftover} {
+ if {$tcl_platform(platform) == "macintosh"} {
+ set colors "32768 32768 16384"
+ } else {
+ set colors "128 128 64"
+ }
+ ToChooseColorByKey $parent 128 128 64
+ tk_chooseColor -parent $parent -title "choose $colors"
+} "$color"
- test clrpick-2.3 {tk_chooseColor command} {
- ToPressButton $parent ok
- tk_chooseColor -parent $parent -title "Press OK"
- } "$color"
-} else {
- puts "Skipped tests clrpick2.1, clrpick2.2 and clrpick2.3 because"
- puts "you ran out of colors in your color palette, and this would"
- puts "have caused the tests to generate errors."
-}
+test clrpick-2.3 {tk_chooseColor command} \
+ {nonUnixUserInteraction colorsLeftover} {
+ ToPressButton $parent ok
+ tk_chooseColor -parent $parent -title "Press OK"
+} "$color"
-test clrpick-2.4 {tk_chooseColor command} {
+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} {
+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} {
+test clrpick-3.2 {tk_chooseColor: background events} {nonUnixUserInteraction} {
after 1 {set x 53}
ToPressButton $parent cancel
tk_chooseColor -parent $parent -title "Press Cancel"
} ""
+
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+