diff options
Diffstat (limited to 'tests/clrpick.test')
| -rw-r--r-- | tests/clrpick.test | 95 |
1 files changed, 42 insertions, 53 deletions
diff --git a/tests/clrpick.test b/tests/clrpick.test index ec570d2..8b3769e 100644 --- a/tests/clrpick.test +++ b/tests/clrpick.test @@ -6,12 +6,43 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +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}} @@ -21,38 +52,30 @@ regsub -all , $msg "" options regsub \"-foo\" $options "" options foreach option $options { - if {[string index $option 0] == "-"} { - test clrpick-1.2 {tk_chooseColor command} { - list [catch {tk_chooseColor $option} msg] $msg - } [list 1 "value for \"$option\" missing"] + if {[string index $option 0] eq "-"} { + test clrpick-1.2$option {tk_chooseColor command} -body { + tk_chooseColor $option + } -returnCodes error -result "value for \"$option\" missing" } } 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"}} -if {[info commands tk::dialog::color::] == ""} { - set isNative 1 -} else { - set isNative 0 -} +set isNative [expr {[info commands tk::dialog::color::] eq ""}] proc ToPressButton {parent btn} { global isNative @@ -130,37 +153,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} { @@ -168,7 +160,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} { @@ -176,13 +167,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" @@ -200,7 +189,7 @@ test clrpick-3.2 {tk_chooseColor: background events} {nonUnixUserInteraction} { tk_chooseColor -parent $parent -title "Press Cancel" } "" -test clrpick-4.1 {tk_chooseColor: screen is inherited from parent} unixOnly { +test clrpick-4.1 {tk_chooseColor: screen is inherited from parent} {unix notAqua} { after 50 {set ::scr [winfo screen .__tk__color]} ToPressButton $parent cancel tk_chooseColor -parent $parent @@ -208,5 +197,5 @@ test clrpick-4.1 {tk_chooseColor: screen is inherited from parent} unixOnly { } [winfo screen $parent] # cleanup -::tcltest::cleanupTests +cleanupTests return |