0byt3m1n1
Path:
C:
/
Program Files
/
R
/
R-4.4.1
/
Tcl
/
lib
/
BWidget
/
[
Home
]
File: color.tcl
namespace eval SelectColor { Widget::define SelectColor color Dialog Widget::declare SelectColor { {-title String "Select a color" 0} {-parent String "" 0} {-command String "" 0} {-help Boolean 0 1} {-color TkResource "" 0 {label -background}} {-type Enum "dialog" 1 {dialog popup}} {-placement String "center" 1} {-background TkResource "" 0 {label -background}} } variable _baseColors { \#0000ff \#00ff00 \#00ffff \#ff0000 \#ff00ff \#ffff00 \#000099 \#009900 \#009999 \#990000 \#990099 \#999900 \#000000 \#333333 \#666666 \#999999 \#cccccc \#ffffff } variable _userColors { \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff } if {[string equal $::tcl_platform(platform) "unix"]} { set useTkDialogue 0 } else { set useTkDialogue 1 } variable _selectype variable _selection variable _wcolor variable _image variable _hsv variable _command variable _unsavedSelection variable _oldColor variable _entryColor variable _bgColor variable _fgColor variable _rounds } proc SelectColor::create { path args } { Widget::init SelectColor $path $args set type [Widget::cget $path -type] switch -- [Widget::cget $path -type] { "dialog" { return [eval [list SelectColor::dialog $path] $args] } "popup" { set list [list at center left right above below] set placement [Widget::cget $path -placement] set where [lindex $placement 0] if {[lsearch $list $where] < 0} { return -code error \ [BWidget::badOptionString placement $placement $list] } ## If they specified a parent and didn't pass a second argument ## in the placement, set the placement relative to the parent. set parent [Widget::cget $path -parent] if {[string length $parent]} { if {[llength $placement] == 1} { lappend placement $parent } } return [eval [list SelectColor::menu $path $placement] $args] } } } proc SelectColor::menu {path placement args} { variable _baseColors variable _userColors variable _wcolor variable _selectype variable _selection variable _command variable _bgColor variable _rounds Widget::init SelectColor $path $args set top [toplevel $path] set parent [winfo toplevel [winfo parent $top]] wm withdraw $top wm transient $top $parent wm overrideredirect $top 1 catch { wm attributes $top -topmost 1 } set _command [Widget::cget $path -command] set _bgColor [Widget::cget $path -background] set _rounds {} set frame [frame $top.frame \ -highlightthickness 0 \ -relief raised -borderwidth 2] set col 0 set row 0 set count 0 set colors [concat $_baseColors $_userColors] foreach color $colors { set f [frame $frame.c$count \ -highlightthickness 2 \ -highlightcolor white \ -relief solid -borderwidth 1 \ -width 16 -height 16 -background $color] bind $f <1> "set SelectColor::_selection $count; break" bind $f <Enter> {focus %W} grid $f -column $col -row $row incr count if {[incr col] == 6 } { set col 0 incr row } } set f [label $frame.c$count \ -highlightthickness 2 \ -highlightcolor white \ -relief flat -borderwidth 0 \ -width 16 -height 16 -image [Bitmap::get palette]] grid $f -column $col -row $row bind $f <1> "set SelectColor::_selection $count; break" bind $f <Enter> {focus %W} pack $frame bind $top <1> {set SelectColor::_selection -1} bind $top <Escape> {set SelectColor::_selection -2} bind $top <FocusOut> [subst {if {"%W" == "$top"} \ {set SelectColor::_selection -2}}] # set background color for menu $f configure -bg $_bgColor $frame configure -bg $_bgColor foreach w [winfo children $frame] { $w configure -highlightcolor $_bgColor -highlightbackground $_bgColor } eval [list BWidget::place $top 0 0] $placement wm deiconify $top raise $top if {$::tcl_platform(platform) == "unix"} { tkwait visibility $top update } BWidget::SetFocusGrab $top $frame.c0 vwait SelectColor::_selection BWidget::RestoreFocusGrab $top $frame.c0 destroy Widget::destroy $top if {$_selection == $count} { array set opts { -parent -parent -title -title -color -initialcolor } if {[Widget::theme]} { set native 1 set nativecmd [list tk_chooseColor -parent $parent] foreach {key val} $args { if {![info exists opts($key)]} { set native 0 break } lappend nativecmd $opts($key) $val } if {$native} { # Call native dialog return [eval $nativecmd] } } # Call BWidget dialog return [eval [list dialog $path] $args] } else { # The user has either selected one of the palette colors, or has # cancelled. The full BWidget/native dialog was not called. # Unless the user has cancelled, pass the selected # color to _userCommand. set tmpCol [lindex $colors $_selection] if {[string equal $tmpCol ""]} { # User has cancelled - no need to call _userCommand. } else { _userCommand $tmpCol } return $tmpCol } } proc SelectColor::_userCommand {color} { variable _command if {[string equal $_command {}]} { return } uplevel #0 $_command [list $color] return } proc SelectColor::dialog {path args} { variable _baseColors variable _userColors variable _widget variable _selection variable _image variable _hsv variable _command variable _unsavedSelection variable _oldColor variable _entryColor variable _bgColor variable _fgColor variable _rounds Widget::init SelectColor $path:SelectColor $args set top [Dialog::create $path \ -title [Widget::cget $path:SelectColor -title] \ -parent [Widget::cget $path:SelectColor -parent] \ -separator 0 -default 0 -cancel 1 -anchor e] wm resizable $top 0 0 set dlgf [$top getframe] set fg [frame $dlgf.fg] set desc [list \ base _baseColors "Base colors" \ user _userColors "User colors"] set help [Widget::cget $path:SelectColor -help] set _command [Widget::cget $path:SelectColor -command] set _bgColor [Widget::cget $path:SelectColor -background] set _rounds {} set mouseHelpText "" if {$help} { append mouseHelpText [subst -nocommands -novariables\ [lindex [BWidget::getname mouseHelpText] 0]] } set count 0 foreach {type varcol defTitle} $desc { set col 0 set lin 0 set title [lindex [BWidget::getname "${type}Colors"] 0] if {![string length $title]} { set title $defTitle } set titf [TitleFrame $fg.$type -text $title] set subf [$titf getframe] foreach color [set $varcol] { set fround [frame $fg.round$count \ -highlightthickness 1 \ -relief sunken -borderwidth 2] set fcolor [frame $fg.color$count -width 16 -height 12 \ -highlightthickness 0 \ -relief flat -borderwidth 0 \ -background $color] pack $fcolor -in $fround grid $fround -in $subf -row $lin -column $col -padx 1 -pady 1 bind $fround <ButtonPress-1> [list SelectColor::_select_rgb $count] bind $fcolor <ButtonPress-1> [list SelectColor::_select_rgb $count] DynamicHelp::add $fround -text $mouseHelpText DynamicHelp::add $fcolor -text $mouseHelpText bind $fround <Double-1> \ "SelectColor::_select_rgb [list $count]; [list $top] invoke 0" bind $fcolor <Double-1> \ "SelectColor::_select_rgb [list $count]; [list $top] invoke 0" # Record list of $fround values in _rounds lappend _rounds $fround incr count if {[incr col] == 6} { incr lin set col 0 } } pack $titf -anchor w -pady 2 } # Record these colors for later use set _fgColor [$fg.round0 cget -highlightcolor] # Add a TitleFrame $titf to wrap $fg.round and $fg.value set name [lindex [BWidget::getname yourSelection] 0] set titf [TitleFrame $fg.choice -text $name] set subf [$titf getframe] pack $titf -anchor w -pady 2 -expand yes -fill both # Add an entry widget $fg.value for the #RRGGBB value if {$::tk_version > 8.4} { set fixedFont TkFixedFont } else { set fixedFont Courier } set subf2 $fg.vround frame $subf2 -highlightthickness 0 -relief sunken -borderwidth 2 entry $fg.value -width 8 -relief sunken -bd 0 -highlightthickness 0 \ -bg white -textvariable ::SelectColor::_entryColor -font $fixedFont pack $subf2 -in $subf -anchor w -side left pack $fg.value -in $subf2 -anchor w -side left if {$help} { DynamicHelp::add $fg.value -text [subst -nocommands -novariables\ [lindex [BWidget::getname keyboardHelpText] 0]] } # Remove focus from the entry widget by clicking anywhere... bind $top <1> [list ::SelectColor::_CheckFocus %W] # ... or by pressing Return/Escape. bind $fg.value <Return> [list ::SelectColor::_CheckFocus .] bind $fg.value <Escape> [list ::SelectColor::_CheckFocus .] bind $fg.value <Return> {+break} bind $fg.value <Escape> {+break} # Break so that the bindings to these events on the toplevel are not # executed. # MODS - record the Tk window path for the entry widget. set _widget(en) $fg.value set fround [frame $fg.round \ -highlightthickness 0 \ -relief sunken -borderwidth 2] set fcolor [frame $fg.color \ -width 50 \ -highlightthickness 0 \ -relief flat -borderwidth 0] pack $fcolor -in $fround -fill y -expand yes pack $fround -in $subf -side right -anchor e -pady 2 -fill y -expand yes # Add a TitleFrame $dlgf.fd to wrap the canvas selectors. The # labels are referenced by the DynamicHelp tooltip. set name [lindex [BWidget::getname colorSelectors] 0] set fd0 [TitleFrame $dlgf.fd -text $name] set fd [$fd0 getframe] set f1 [frame $fd.f1 -relief sunken -borderwidth 2] set f2 [frame $fd.f2 -relief sunken -borderwidth 2] set c1 [canvas $f1.c -width 200 -height 200 -bd 0 -highlightthickness 0] set c2 [canvas $f2.c -width 15 -height 200 -bd 0 -highlightthickness 0] for {set val 0} {$val < 40} {incr val} { $c2 create rectangle 0 [expr {5*$val}] 15 [expr {5*$val+5}] -tags val[expr {39-$val}] } $c2 create polygon 0 0 10 5 0 10 -fill black -outline white -tags target pack $c1 $c2 pack $f1 $f2 -side left -padx 10 -anchor n pack $fg $fd0 -side left -anchor n -fill y pack configure $fd0 -pady 2 -padx {4 0} bind $c1 <ButtonPress-1> [list SelectColor::_select_hue_sat %x %y] bind $c1 <B1-Motion> [list SelectColor::_select_hue_sat %x %y] bind $c2 <ButtonPress-1> [list SelectColor::_select_value %x %y] bind $c2 <B1-Motion> [list SelectColor::_select_value %x %y] if {![info exists _image] || [catch {image type $_image}]} { set _image [image create photo -width 200 -height 200] for {set x 0} {$x < 200} {incr x 4} { for {set y 0} {$y < 200} {incr y 4} { $_image put \ [eval [list format "\#%04x%04x%04x"] \ [hsvToRgb [expr {$x/196.0}] [expr {(196-$y)/196.0}] 0.85]] \ -to $x $y [expr {$x+4}] [expr {$y+4}] } } } $c1 create image 0 0 -anchor nw -image $_image $c1 create bitmap 0 0 \ -bitmap @[file join $::BWIDGET::LIBRARY "images" "target.xbm"] \ -anchor nw -tags target set _selection -1 set _widget(fcolor) $fg set _widget(chs) $c1 set _widget(cv) $c2 set rgb [winfo rgb $path [Widget::cget $path:SelectColor -color]] set _hsv [eval rgbToHsv $rgb] _set_rgb [eval [list format "\#%04x%04x%04x"] $rgb] _set_hue_sat [lindex $_hsv 0] [lindex $_hsv 1] _set_value [lindex $_hsv 2] # Initialize _oldColor which is used to reset the color supplied to # _userCommand if the user cancels. set _oldColor [set _unsavedSelection] set tmp24 [::SelectColor::_24BitRgb $_oldColor] if {[_ValidateColorEntry forced $tmp24]} { set ::SelectColor::_entryColor $tmp24 } else { # Value $tmp24 does not pass entry widget validation and if used # would disable validation. Use this default instead. set _entryColor # } # Validate input to the entry field. # To avoid conflict with the entry -variable (_entryColor), do not set the # latter directly (because a failed validation will switch off subsequent # validations). Either call _SetEntryValue, or set _unsavedSelection which # triggers the trace. $fg.value configure -validate all -validatecommand \ [list SelectColor::_ValidateColorEntry %V %P] # Trace _unsavedSelection # Subsequent modifications to _unsavedSelection will update the entry # widget, if the value is valid. # From now on, this is the only way that: # (1) ::SelectColor::_SetEntryValue is called # (2) ::SelectColor::_entryColor is modified (except by the user typing in # the entry widget) trace add variable ::SelectColor::_unsavedSelection write ::SelectColor::_SetEntryValue $top add -text [lindex [BWidget::getname ok] 0] $top add -text [lindex [BWidget::getname cancel] 0] # Override background color ReColor $path $_bgColor set res [$top draw] if {$res == 0} { set color [$fg.color cget -background] } else { # User has cancelled - call _userCommand to undo any changes made # in the caller. _userCommand $_oldColor set color "" } trace remove variable ::SelectColor::_unsavedSelection write ::SelectColor::_SetEntryValue destroy $top return $color } # ---------------------------------------------------------------------------- # Command SelectColor::setbasecolor # ---------------------------------------------------------------------------- # Exported command, to allow the caller to set the base colors of the palette. proc SelectColor::setbasecolor { idx color } { variable _baseColors set _baseColors [lreplace $_baseColors $idx $idx $color] } # ---------------------------------------------------------------------------- # Command SelectColor::setcolor # ---------------------------------------------------------------------------- proc SelectColor::setcolor { idx color } { variable _userColors set _userColors [lreplace $_userColors $idx $idx $color] } proc SelectColor::_select_rgb {count} { variable _baseColors variable _userColors variable _selection variable _widget variable _hsv variable _unsavedSelection variable _bgColor variable _fgColor set frame $_widget(fcolor) # Use highlight color instead of focus to identify the selected # palette color. Tab traversal of focus now works correctly. if {$_selection >= 0} { $frame.round$_selection configure \ -relief sunken -highlightthickness 1 -borderwidth 2 \ -highlightbackground $_bgColor } $frame.round$count configure \ -relief flat -highlightthickness 2 -borderwidth 1 \ -highlightbackground $_fgColor set _selection $count set bg [$frame.color$count cget -background] set user [expr {$_selection-[llength $_baseColors]}] if {$user >= 0 && [string equal \ [winfo rgb $frame.color$_selection $bg] \ [winfo rgb $frame.color$_selection white]]} { set bg [$frame.color cget -bg] $frame.color$_selection configure -background $bg set _userColors [lreplace $_userColors $user $user $bg] } else { set _hsv [eval rgbToHsv [winfo rgb $frame.color$count $bg]] _set_hue_sat [lindex $_hsv 0] [lindex $_hsv 1] _set_value [lindex $_hsv 2] $frame.color configure -background $bg # Display selected color in entry widget (via trace on # ::SelectColor::_unsavedSelection), and notify caller. set ::SelectColor::_unsavedSelection $bg _userCommand $bg } } proc SelectColor::_set_rgb {rgb} { variable _selection variable _baseColors variable _userColors variable _widget variable _unsavedSelection set frame $_widget(fcolor) $frame.color configure -background $rgb # Display selected color in entry widget (via trace on # ::SelectColor::_unsavedSelection), and notify caller. set ::SelectColor::_unsavedSelection $rgb _userCommand $rgb set user [expr {$_selection-[llength $_baseColors]}] if {$user >= 0} { $frame.color$_selection configure -background $rgb set _userColors [lreplace $_userColors $user $user $rgb] } } proc SelectColor::_select_hue_sat {x y} { variable _widget variable _hsv if {$x < 0} { set x 0 } elseif {$x > 200} { set x 200 } if {$y < 0 } { set y 0 } elseif {$y > 200} { set y 200 } set hue [expr {$x/200.0}] set sat [expr {(200-$y)/200.0}] set _hsv [lreplace $_hsv 0 1 $hue $sat] $_widget(chs) coords target [expr {$x-9}] [expr {$y-9}] _draw_values $hue $sat _set_rgb [eval [list format "\#%04x%04x%04x"] [eval [list hsvToRgb] $_hsv]] } proc SelectColor::_set_hue_sat {hue sat} { variable _widget set x [expr {$hue*200-9}] set y [expr {(1-$sat)*200-9}] $_widget(chs) coords target $x $y _draw_values $hue $sat } proc SelectColor::_select_value {x y} { variable _widget variable _hsv if {$y < 0} { set y 0 } elseif {$y > 200} { set y 200 } $_widget(cv) coords target 0 [expr {$y-5}] 10 $y 0 [expr {$y+5}] set _hsv [lreplace $_hsv 2 2 [expr {(200-$y)/200.0}]] _set_rgb [eval [list format "\#%04x%04x%04x"] [eval [list hsvToRgb] $_hsv]] } proc SelectColor::_draw_values {hue sat} { variable _widget for {set val 0} {$val < 40} {incr val} { set l [hsvToRgb $hue $sat [expr {$val/39.0}]] set col [eval [list format "\#%04x%04x%04x"] $l] $_widget(cv) itemconfigure val$val -fill $col -outline $col } } proc SelectColor::_set_value {value} { variable _widget set y [expr {int((1-$value)*200)}] $_widget(cv) coords target 0 [expr {$y-5}] 10 $y 0 [expr {$y+5}] } # -- # Taken from tk8.0/demos/tcolor.tcl # -- # The procedure below converts an HSB value to RGB. It takes hue, saturation, # and value components (floating-point, 0-1.0) as arguments, and returns a # list containing RGB components (integers, 0-65535) as result. The code # here is a copy of the code on page 616 of "Fundamentals of Interactive # Computer Graphics" by Foley and Van Dam. proc SelectColor::hsvToRgb {hue sat val} { set v [expr {round(65535.0*$val)}] if {$sat == 0} { return [list $v $v $v] } else { set hue [expr {$hue*6.0}] if {$hue >= 6.0} { set hue 0.0 } set i [expr {int($hue)}] set f [expr {$hue-$i}] set p [expr {round(65535.0*$val*(1 - $sat))}] set q [expr {round(65535.0*$val*(1 - ($sat*$f)))}] set t [expr {round(65535.0*$val*(1 - ($sat*(1 - $f))))}] switch $i { 0 {return [list $v $t $p]} 1 {return [list $q $v $p]} 2 {return [list $p $v $t]} 3 {return [list $p $q $v]} 4 {return [list $t $p $v]} 5 {return [list $v $p $q]} } } } # -- # Taken from tk8.0/demos/tcolor.tcl # -- # The procedure below converts an RGB value to HSB. It takes red, green, # and blue components (0-65535) as arguments, and returns a list containing # HSB components (floating-point, 0-1) as result. The code here is a copy # of the code on page 615 of "Fundamentals of Interactive Computer Graphics" # by Foley and Van Dam. proc SelectColor::rgbToHsv {red green blue} { if {$red > $green} { set max $red.0 set min $green.0 } else { set max $green.0 set min $red.0 } if {$blue > $max} { set max $blue.0 } else { if {$blue < $min} { set min $blue.0 } } set range [expr {$max-$min}] if {$max == 0} { set sat 0 } else { set sat [expr {($max-$min)/$max}] } if {$sat == 0} { set hue 0 } else { set rc [expr {($max - $red)/$range}] set gc [expr {($max - $green)/$range}] set bc [expr {($max - $blue)/$range}] if {$red == $max} { set hue [expr {.166667*($bc - $gc)}] } else { if {$green == $max} { set hue [expr {.166667*(2 + $rc - $bc)}] } else { set hue [expr {.166667*(4 + $gc - $rc)}] } } if {$hue < 0.0} { set hue [expr {$hue + 1.0}] } } return [list $hue $sat [expr {$max/65535}]] } # ------------------------------------------------------------------------------ # Command SelectColor::ReColor # ------------------------------------------------------------------------------ # Command to change the background color for the dialog. # # FIXME Ideally this would be called by "$w configure -background $value". # Currently a "configure -background" command is passed to Dialog and Widget # but does not change SelectColor. # HaO: it might also be possible that this is controled by the option data base. # ------------------------------------------------------------------------------ proc SelectColor::ReColor {path newColor} { variable _bgColor variable _rounds set _bgColor $newColor $path configure -bg $_bgColor # Use the internal names of the dialog widget - it would be nicer to # use a colored dialog widget. foreach child { fd fd.f.f1 fd.f.f2 fg fg.base fg.choice fg.user fg.round fg.vround } { $path.frame.$child configure -background $_bgColor } # Special treatment for Aqua native buttons. # FIXME implement a general fix for BWidget Button/ButtonBox/Dialog if {[string equal [tk windowingsystem] "aqua"]} { $path.bbox.b0 configure -highlightbackground $_bgColor \ -highlightthickness 0 $path.bbox.b1 configure -highlightbackground $_bgColor \ -highlightthickness 0 } else { $path.bbox.b0 configure -bg $_bgColor -activebackground $_bgColor \ -highlightbackground $_bgColor $path.bbox.b1 configure -bg $_bgColor -activebackground $_bgColor \ -highlightbackground $_bgColor } foreach fround $_rounds { $fround configure -highlightbackground $_bgColor -bg $_bgColor } return } # ------------------------------------------------------------------------------ # Command SelectColor::_24BitRgb # ------------------------------------------------------------------------------ # Command to convert a hex 12n-bit RGB color to 24-bit, n > 0. # Convert anything else to {}. # Used to process the display in the entry widget. # ------------------------------------------------------------------------------ proc SelectColor::_24BitRgb {col} { set lenny [string length $col] incr lenny -1 if { ($lenny % 3) || ($lenny == 0) || (![regexp {^#[a-fA-F0-9]*$} $col]) } { # Not a multiple of 3, or not leading #, or nothing after #, # or non-HEX digits. return {} } elseif {$lenny == 3} { # 12-bit, pad to 24-bit set val $col set val [string replace $val 3 3 "[string index $val 3]0"] set val [string replace $val 2 2 "[string index $val 2]0"] set val [string replace $val 1 1 "[string index $val 1]0"] return $val } elseif {$lenny == 6} { # 24-bit, return unchanged return $col } else { # Truncate to 24-bit set delta [expr {$lenny / 3}] set delta2 [expr {$delta * 2}] set deltaP1 [incr delta] set deltaP2 [incr delta] set delta2P1 [incr delta2] set delta2P2 [incr delta2] set result # append result [string range $col 1 2] append result [string range $col $deltaP1 $deltaP2] append result [string range $col $delta2P1 $delta2P2] return $result } } # ------------------------------------------------------------------------------ # Command SelectColor::_SetEntryValue # ------------------------------------------------------------------------------ # Command to update the (hexadecimal color displayed in the) entry widget # when there is a change in the color currently selected in the GUI, which is # stored in _unsavedSelection. # # This command is called by a write trace on _unsavedSelection; if the # value of this variable is a valid color (i.e. "#" followed by 3N hex digits), # this command converts the value to 24 bits and sets ::SelectColor::_entryColor # to the result, thereby displaying it in the entry widget. Therefore, # when the user chooses a color by means other than the entry widget, this # command updates the entry widget. # # This command does not update the GUI when the user changes the value in the # entry widget: that is done instead by the -vcmd of the entry widget, which # is SelectColor::_ValidateColorEntry. When the user chooses a color by typing # in the entry widget, the command _ValidateColorEntry copies the value to # _unsavedSelection if a keystroke in the widget makes its contents 3N hex # digits long. # ------------------------------------------------------------------------------ proc SelectColor::_SetEntryValue {argVarName var2 op} { variable _entryColor variable _unsavedSelection if {[string equal $argVarName ::SelectColor::_unsavedSelection] && [string equal $var2 {}] && [string equal $op "write"]} { # OK } else { # Unexpected call return -code error "Unexpected trace of variable\ \"$argVarName\", \"$var2\", \"$op\"" } set col24bit [::SelectColor::_24BitRgb [set $argVarName]] if {[_ValidateColorEntry forced $col24bit]} { set ::SelectColor::_entryColor $col24bit } else { # Value is invalid, and if written to _entryColor this would disable # validation. } return } # ------------------------------------------------------------------------------ # Command SelectColor::_CheckFocus # ------------------------------------------------------------------------------ # This command is called with argument %W as a binding to <1> on the toplevel. # It is also called with argument {.}, by bindings on the entry widget to # <Escape>, <Return>. # # The command does something only if the entry widget has focus, and the # argument (the clicked window) is the Tk window path of somewhere else. Then, # the command removes focus from the entry widget to the default button. # ------------------------------------------------------------------------------ proc SelectColor::_CheckFocus {w} { variable _widget if { (! [string equal $w $_widget(en)]) && ([string equal [focus] $_widget(en)])} { set top [winfo toplevel $_widget(en)] $top setfocus default } return } # ------------------------------------------------------------------------------ # Command SelectColor::_ValidateColorEntry # ------------------------------------------------------------------------------ # This command is the "-validate all -vcmd" of the entry widget. # It is also called by SelectColor::dialog and SelectColor::_SetEntryValue to # check values assigned to _entryColor. # # When the user chooses a color by typing in the entry widget, this command # copies the value to _unsavedSelection if a keystroke in the widget makes its # contents 3N hex digits long. # ------------------------------------------------------------------------------ proc SelectColor::_ValidateColorEntry {percentV percentP} { variable _unsavedSelection set result [regexp -- {^#[0-9a-fA-F]*$} $percentP] set lenny [string length $percentP] if {$result} { if {[string equal $percentV "forced"]} { # Validation only. Don't want a loop. } elseif {[string equal $percentV "key"]} { # Copy to GUI if a valid color. if {($lenny - 1) % 3 || $lenny == 1} { # Not a valid color, which needs 3n+1 characters, n > 0 } else { after idle [list SelectColor::_SetWithoutTrace $percentP] } } elseif {[string equal $percentV "focusout"]} { # If the color is valid it will already have been copied to the GUI # and to _userCommand by the "key" validation above. # # The code below only needs to reset the value in the entry widget. # Remove an invalid value, convert a valid one to 24-bit. # Ignore $percentP, just fire the trace on _unsavedSelection. set color $_unsavedSelection after idle [list set ::SelectColor::_unsavedSelection $color] } } return $result } # ------------------------------------------------------------------------------ # Command SelectColor::_SetWithoutTrace # ------------------------------------------------------------------------------ # This command sets _unsavedSelection (using _set_rgb) without firing the trace # that copies the value to _entryColor. # The command is called by SelectColor::_ValidateColorEntry to avoid a loop. # ------------------------------------------------------------------------------ proc SelectColor::_SetWithoutTrace {value} { trace remove variable ::SelectColor::_unsavedSelection write ::SelectColor::_SetEntryValue _set_rgb $value set _hsv [eval rgbToHsv [winfo rgb . $value]] _set_hue_sat [lindex $_hsv 0] [lindex $_hsv 1] _set_value [lindex $_hsv 2] trace add variable ::SelectColor::_unsavedSelection write ::SelectColor::_SetEntryValue return }