diff options
Diffstat (limited to 'tests/clrpick.test')
| -rw-r--r-- | tests/clrpick.test | 74 |
1 files changed, 35 insertions, 39 deletions
diff --git a/tests/clrpick.test b/tests/clrpick.test index 70f1a52..9396dbb 100644 --- a/tests/clrpick.test +++ b/tests/clrpick.test @@ -5,13 +5,47 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: clrpick.test,v 1.10 2004/05/23 17:34:48 dkf Exp $ +# RCS: @(#) $Id: clrpick.test,v 1.11 2004/06/17 22:38:57 dkf Exp $ # package require tcltest 2.1 eval tcltest::configure $argv tcltest::loadTestedCommands +if {[testConstraint defaultPseudocolor8]} { + # 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 + testConstraint colorsLeftover 1 + set i 0 + canvas .c + pack .c -expand 1 -fill both + while {$i<$numcolors} { + set color \#[format "%02x%02x%02x" $i [expr $i+1] [expr $i+3]] + .c create rectangle [expr 10+$i] [expr 10+$i] [expr 50+$i] [expr 50+$i] -fill $color -outline $color + incr i + } + set i 0 + while {$i<$numcolors} { + set color [.c itemcget $i -fill] + if {$color != ""} { + foreach {r g b} [winfo rgb . $color] {} + set r [expr $r/256] + set g [expr $g/256] + set b [expr $b/256] + if {"$color" != "#[format %02x%02x%02x $r $g $b]"} { + testConstraint colorsLeftover 0 + } + } + .c delete $i + incr i + } + destroy .c +} else { + testConstraint colorsLeftover 0 +} + test clrpick-1.1 {tk_chooseColor command} { list [catch {tk_chooseColor -foo} msg] $msg } {1 {bad option "-foo": must be -initialcolor, -parent, or -title}} @@ -31,19 +65,15 @@ foreach option $options { test clrpick-1.3 {tk_chooseColor command} { list [catch {tk_chooseColor -foo bar} msg] $msg } {1 {bad option "-foo": must be -initialcolor, -parent, or -title}} - test clrpick-1.4 {tk_chooseColor command} { list [catch {tk_chooseColor -initialcolor} msg] $msg } {1 {value for "-initialcolor" missing}} - test clrpick-1.5 {tk_chooseColor command} { list [catch {tk_chooseColor -parent foo.bar} msg] $msg } {1 {bad window path name "foo.bar"}} - test clrpick-1.6 {tk_chooseColor command} { list [catch {tk_chooseColor -initialcolor badbadbaadcolor} msg] $msg } {1 {unknown color name "badbadbaadcolor"}} - test clrpick-1.7 {tk_chooseColor command} { list [catch {tk_chooseColor -initialcolor ##badbadbaadcolor} msg] $msg } {1 {invalid color name "##badbadbaadcolor"}} @@ -126,37 +156,6 @@ set verylongstring $verylongstring$verylongstring #set verylongstring $verylongstring$verylongstring #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 -testConstraint colorsLeftover 1 -set i 0 -canvas .c -pack .c -expand 1 -fill both -while {$i<$numcolors} { - set color \#[format "%02x%02x%02x" $i [expr $i+1] [expr $i+3]] - .c create rectangle [expr 10+$i] [expr 10+$i] [expr 50+$i] [expr 50+$i] -fill $color -outline $color - incr i -} -set i 0 -while {$i<$numcolors} { - set color [.c itemcget $i -fill] - if {$color != ""} { - foreach {r g b} [winfo rgb . $color] {} - set r [expr $r/256] - set g [expr $g/256] - set b [expr $b/256] - if {"$color" != "#[format %02x%02x%02x $r $g $b]"} { - testConstraint colorsLeftover 0 - } - } - .c delete $i - incr i -} - -destroy .c - set color #404040 test clrpick-2.1 {tk_chooseColor command} \ {nonUnixUserInteraction colorsLeftover} { @@ -164,7 +163,6 @@ test clrpick-2.1 {tk_chooseColor command} \ tk_chooseColor -title "Press Ok $verylongstring" -initialcolor $color \ -parent $parent } "$color" - set color #808040 test clrpick-2.2 {tk_chooseColor command} \ {nonUnixUserInteraction colorsLeftover} { @@ -172,13 +170,11 @@ test clrpick-2.2 {tk_chooseColor command} \ ToChooseColorByKey $parent 128 128 64 tk_chooseColor -parent $parent -title "choose $colors" } "$color" - 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} {nonUnixUserInteraction} { ToPressButton $parent cancel tk_chooseColor -parent $parent -title "Press Cancel" |