diff --git a/tests/color.test b/tests/color.test index af0695e22..b2ed9d251 100644 --- a/tests/color.test +++ b/tests/color.test @@ -9,6 +9,9 @@ package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +# Import utility procs for specific functional areas +namespace import -force ::tk::test::colors::* + # cname -- # Returns a proper name for a color, given its intensities. # @@ -74,22 +77,6 @@ proc c255 {vals} { [expr {[lindex $vals 2]/256}] } -# colorsFree -- -# -# Returns 1 if there appear to be free colormap entries in a window, -# 0 otherwise. -# -# Arguments: -# w - Name of window in which to check. -# red, green, blue - Intensities to use in a trial color allocation -# to see if there are colormap entries free. - -proc colorsFree {w {red 31} {green 245} {blue 192}} { - set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]] - expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \ - && ([lindex $vals 2]/256 == $blue) -} - # -- WARNING (SB, 6.4.2017) -- # # The if block below looks _very_ outdated. It didn't get any @@ -305,6 +292,10 @@ test color-4.1 {FreeColorObjProc} -constraints { destroy .t -# cleanup +# +# CLEANUP +# + +namespace forget ::tk::test::colors::* cleanupTests return diff --git a/tests/frame.test b/tests/frame.test index 9cb5070b8..cd32c3778 100644 --- a/tests/frame.test +++ b/tests/frame.test @@ -12,46 +12,10 @@ namespace import ::tcltest::* tcltest::configure {*}$argv tcltest::loadTestedCommands -tcltest::testConstraint x11 [expr {[tk windowingsystem] eq "x11"}] - -# eatColors -- -# Creates a toplevel window and allocates enough colors in it to use up all -# the slots in an 8-bit colormap. -# -# Arguments: -# w - Name of toplevel window to create. - -proc eatColors {w} { - catch {destroy $w} - toplevel $w - wm geom $w +0+0 - canvas $w.c -width 400 -height 200 -bd 0 - pack $w.c - for {set y 0} {$y < 8} {incr y} { - for {set x 0} {$x < 40} {incr x} { - set color [format #%02x%02x%02x [expr {$x*6}] [expr {$y*30}] 0] - $w.c create rectangle [expr {10*$x}] [expr {20*$y}] \ - [expr {10*$x + 10}] [expr {20*$y + 20}] -outline {} \ - -fill $color - } - } - update -} - -# colorsFree -- -# -# Returns 1 if there appear to be free colormap entries in a window, 0 -# otherwise. -# -# Arguments: -# w - Name of window in which to check. -# red, green, blue - Intensities to use in a trial color allocation -# to see if there are colormap entries free. +# Import utility procs for specific functional areas +namespace import -force ::tk::test::colors::* -proc colorsFree {w {red 31} {green 245} {blue 192}} { - lassign [winfo rgb $w [format "#%02x%02x%02x" $red $green $blue]] r g b - expr {($r/256 == $red) && ($g/256 == $green) && ($b/256 == $blue)} -} +tcltest::testConstraint x11 [expr {[tk windowingsystem] eq "x11"}] # uniq -- # @@ -1767,13 +1731,16 @@ test frame-15.14 {TIP 262: toplevel background images} -setup { deleteWindows catch {image delete gorp} } -result {{gorp get} {gorp display 0 0 30 15} {gorp display 0 0 30 10} {gorp display 0 0 20 15} {gorp display 0 0 20 10}} - -# cleanup + +# +# CLEANUP +# + deleteWindows apply {cmds {foreach cmd $cmds {rename $cmd {}}}} { eatColors colorsFree uniq optnames } - +namespace forget ::tk::test::colors::* cleanupTests return diff --git a/tests/testutils.tcl b/tests/testutils.tcl index fe31a2961..df164a2e2 100644 --- a/tests/testutils.tcl +++ b/tests/testutils.tcl @@ -286,6 +286,50 @@ namespace eval ::tk::test::button { namespace export * } +namespace eval ::tk::test::colors { + # colorsFree -- + # + # Returns 1 if there appear to be free colormap entries in a window, 0 + # otherwise. + # + # Arguments: + # w - Name of window in which to check. + # red, green, blue - Intensities to use in a trial color allocation + # to see if there are colormap entries free. + # + proc colorsFree {w {red 31} {green 245} {blue 192}} { + lassign [winfo rgb $w [format "#%02x%02x%02x" $red $green $blue]] r g b + expr {($r/256 == $red) && ($g/256 == $green) && ($b/256 == $blue)} + } + + # eatColors -- + # + # Creates a toplevel window and allocates enough colors in it to use up all + # the slots in an 8-bit colormap. + # + # Arguments: + # w - Name of toplevel window to create. + # + proc eatColors {w} { + catch {destroy $w} + toplevel $w + wm geom $w +0+0 + canvas $w.c -width 400 -height 200 -bd 0 + pack $w.c + for {set y 0} {$y < 8} {incr y} { + for {set x 0} {$x < 40} {incr x} { + set color [format #%02x%02x%02x [expr {$x*6}] [expr {$y*30}] 0] + $w.c create rectangle [expr {10*$x}] [expr {20*$y}] \ + [expr {10*$x + 10}] [expr {20*$y + 20}] -outline {} \ + -fill $color + } + } + update + } + + namespace export * +} + namespace eval ::tk::test::dialog { # diff --git a/tests/unixEmbed.test b/tests/unixEmbed.test index c28d6bd20..b6b0ac26b 100644 --- a/tests/unixEmbed.test +++ b/tests/unixEmbed.test @@ -11,6 +11,9 @@ eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test +# Import utility procs for specific functional areas +namespace import -force ::tk::test::colors::* + testConstraint failsOnUbuntu [expr {![info exists ::env(CI)] || ![string match Linux $::tcl_platform(os)]}] testConstraint failsOnXQuarz [expr {$tcl_platform(os) ne "Darwin" || [tk windowingsystem] ne "x11" }] @@ -48,46 +51,6 @@ proc ::_test_tmp::testInterp {name} { setupbg dobg {wm withdraw .} -# eatColors -- -# Creates a toplevel window and allocates enough colors in it to -# use up all the slots in the colormap. -# -# Arguments: -# w - Name of toplevel window to create. - -proc eatColors {w} { - catch {destroy $w} - toplevel $w - wm geom $w +0+0 - canvas $w.c -width 400 -height 200 -bd 0 - pack $w.c - for {set y 0} {$y < 8} {incr y} { - for {set x 0} {$x < 40} {incr x} { - set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0] - $w.c create rectangle [expr 10*$x] [expr 20*$y] \ - [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \ - -fill $color - } - } - update -} - -# colorsFree -- -# -# Returns 1 if there appear to be free colormap entries in a window, -# 0 otherwise. -# -# Arguments: -# w - Name of window in which to check. -# red, green, blue - Intensities to use in a trial color allocation -# to see if there are colormap entries free. - -proc colorsFree {w {red 31} {green 245} {blue 192}} { - set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]] - expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \ - && ([lindex $vals 2]/256 == $blue) -} - test unixEmbed-1.1 {Tk_UseWindow procedure, bad window identifier} -constraints { unix } -setup { @@ -1322,9 +1285,12 @@ test unixEmbed-11.2 {mouse coordinates in embedded toplevels} -constraints { deleteWindows } -result {.main.b {pushed .main.b} .embed.b {pushed .embed.b}} +# +# CLEANUP +# -# cleanup deleteWindows cleanupbg +namespace forget ::tk::test::colors::* cleanupTests return diff --git a/tests/visual.test b/tests/visual.test index c4e26d25c..10e70cdba 100644 --- a/tests/visual.test +++ b/tests/visual.test @@ -12,47 +12,10 @@ namespace import ::tcltest::* tcltest::configure {*}$argv tcltest::loadTestedCommands -update - -# eatColors -- -# Creates a toplevel window and allocates enough colors in it to -# use up all the slots in the colormap. -# -# Arguments: -# w - Name of toplevel window to create. - -proc eatColors {w} { - catch {destroy $w} - toplevel $w - wm geom $w +0+0 - canvas $w.c -width 400 -height 200 -bd 0 - pack $w.c - for {set y 0} {$y < 8} {incr y} { - for {set x 0} {$x < 40} {incr x} { - set color [format #%02x%02x%02x [expr {$x*6}] [expr {$y*30}] 0] - $w.c create rectangle [expr {10*$x}] [expr {20*$y}] \ - [expr {10*$x + 10}] [expr {20*$y + 20}] -outline {} \ - -fill $color - } - } - update -} +# Import utility procs for specific functional areas +namespace import -force ::tk::test::colors::* -# colorsFree -- -# -# Returns 1 if there appear to be free colormap entries in a window, -# 0 otherwise. -# -# Arguments: -# w - Name of window in which to check. -# red, green, blue - Intensities to use in a trial color allocation -# to see if there are colormap entries free. - -proc colorsFree {w {red 31} {green 245} {blue 192}} { - set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]] - expr {([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) - && ([lindex $vals 2]/256 == $blue)} -} +update # If more than one visual type is available for the screen, pick one # that is *not* the default. @@ -556,12 +519,15 @@ test visual-8.2 {Tk_FreeColormap procedure} -constraints haveOtherVisual -setup deleteWindows } -result {} +# +# CLEANUP +# deleteWindows rename eatColors {} rename colorsFree {} -# cleanup +namespace forget ::tk::test::colors::* cleanupTests return