Relocate procs colorsFree, eatColors.

tcltk · Jan 6, 2025 · 64863d4 · 64863d4
1 parent 2d2f869
commit 64863d4
Show file tree

Hide file tree

Showing 5 changed files with 75 additions and 141 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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