library/clrpick.tcl

   1 # clrpick.tcl --
   2 #
   3 #       Color selection dialog.
   4 #       standard color selection dialog.
   5 #
   6 # Copyright (c) 1996 Sun Microsystems, Inc.
   7 # Copyright (c) 1999 Christian Werner
   8 #
   9 # See the file "license.terms" for information on usage and redistribution
  10 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11
  12 # ck_chooseColor --
  13 #
  14 #       Create a color dialog and let the user choose a color. This function
  15 #       should not be called directly. It is called by the tk_chooseColor
  16 #       function when a native color selector widget does not exist
  17
  18 proc ck_chooseColor args {
  19     global ckPriv
  20     set w .__ck__color
  21     upvar #0 $w data
  22     if {[winfo depth .] == 1} {
  23         set data(colors) {black white}
  24         set data(rcolors) {white black}
  25     } else {
  26         set data(colors) {black blue cyan green magenta red white yellow}
  27         set data(rcolors) {white white white white white white black black}
  28     }
  29     ckColorDialog_Config $w $args
  30
  31     if {![winfo exists $w]} {
  32         toplevel $w -class CkColorDialog -border {
  33             ulcorner hline urcorner vline lrcorner hline llcorner vline
  34         }
  35         ckColorDialog_BuildDialog $w
  36     }
  37     place $w -relx 0.5 -rely 0.5 -anchor center
  38
  39     # Set the focus.
  40
  41     set oldFocus [focus]
  42     focus $w.bot.ok
  43
  44     # Wait for the user to respond, then restore the focus and
  45     # return the index of the selected button.  Restore the focus
  46     # before deleting the window, since otherwise the window manager
  47     # may take the focus away so we can't redirect it.  Finally,
  48     # restore any grab that was in effect.
  49
  50     tkwait variable ckPriv(selectColor)
  51     catch {focus $oldFocus}
  52     destroy $w
  53     unset data
  54     return $ckPriv(selectColor)
  55 }
  56
  57 # ckColorDialog_Config  --
  58 #
  59 #       Parses the command line arguments to tk_chooseColor
  60 #
  61 proc ckColorDialog_Config {w argList} {
  62     global ckPriv
  63     upvar #0 $w data
  64     set specs {
  65         {-initialcolor "" "" ""}
  66         {-parent "" "" "."}
  67         {-title "" "" "Color"}
  68     }
  69     tclParseConfigSpec $w $specs "" $argList
  70     if {![string compare $data(-initialcolor) ""]} {
  71         if {[info exists ckPriv(selectColor)] && \
  72                 [string compare $ckPriv(selectColor) ""]} {
  73             set data(-initialcolor) $ckPriv(selectColor)
  74         } else {
  75             set data(-initialcolor) [. cget -background]
  76         }
  77     } elseif {[lsearch -exact $data(colors) $data(-initialcolor)] <= 0} {
  78         error "illegal -initialcolor"
  79     }
  80     if {![winfo exists $data(-parent)]} {
  81         error "bad window path name \"$data(-parent)\""
  82     }
  83 }
  84
  85 # ckColorDialog_BuildDialog --
  86 #
  87 #       Build the dialog.
  88 #
  89 proc ckColorDialog_BuildDialog w {
  90     upvar #0 $w data
  91     label $w.title -text "Select Color"
  92     pack $w.title -side top -fill x -pady 1
  93     frame $w.top
  94     pack $w.top -side top -fill x -padx 1
  95     set count 0
  96     foreach i $data(colors) {
  97         radiobutton $w.top.$i -background $i -text $i -value $i \
  98             -variable ${w}(finalColor) \
  99             -foreground [lindex $data(rcolors) $count] \
 100             -selectcolor [lindex $data(rcolors) $count]
 101         if {[winfo depth .] > 1} {
 102             $w.top.$i configure -activeforeground \
 103                 [$w.top.$i cget -background] -activeattributes bold \
 104                 -activebackground [$w.top.$i cget -foreground]
 105         }
 106         pack $w.top.$i -side top -fill x
 107         incr count
 108     }
 109     frame $w.bot
 110     pack $w.bot -side top -fill x -padx 1 -pady 1
 111     button $w.bot.ok -text OK -width 8 -underline 0 \
 112         -command [list ckColorDialog_OkCmd $w]
 113     button $w.bot.cancel -text Cancel -width 8 -underline 0 \
 114         -command [list ckColorDialog_CancelCmd $w]
 115     pack $w.bot.ok $w.bot.cancel -side left -expand 1
 116     # Accelerator bindings
 117     bind $w <Escape> [list ckButtonInvoke $w.bot.cancel]
 118     bind $w <c> [list ckButtonInvoke $w.bot.cancel]
 119     bind $w <C> [list ckButtonInvoke $w.bot.cancel]
 120     bind $w <o> [list ckButtonInvoke $w.bot.ok]
 121     bind $w <O> [list ckButtonInvoke $w.bot.ok]
 122     set data(finalColor) $data(-initialcolor)
 123 }
 124
 125 proc ckColorDialog_OkCmd {w} {
 126     global ckPriv
 127     upvar #0 $w data
 128     set ckPriv(selectColor) $data(finalColor)
 129 }
 130
 131 proc ckColorDialog_CancelCmd {w} {
 132     global ckPriv
 133     set ckPriv(selectColor) ""
 134 }
 135