diff options
Diffstat (limited to 'tests/clrpick.test')
| -rw-r--r-- | tests/clrpick.test | 107 |
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 + + + + + + + + + + + + + |