[11] | 1 | # ---------------------------------------------------------------------- |
---|
| 2 | # COMPONENT: ChoiceEntry - widget for entering a choice of strings |
---|
| 3 | # |
---|
| 4 | # This widget represents a <choice> entry on a control panel. |
---|
| 5 | # It is used to choose one of several mutually-exclusive strings. |
---|
| 6 | # ====================================================================== |
---|
| 7 | # AUTHOR: Michael McLennan, Purdue University |
---|
[115] | 8 | # Copyright (c) 2004-2005 Purdue Research Foundation |
---|
| 9 | # |
---|
| 10 | # See the file "license.terms" for information on usage and |
---|
| 11 | # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
---|
[11] | 12 | # ====================================================================== |
---|
| 13 | package require Itk |
---|
| 14 | |
---|
| 15 | itcl::class Rappture::ChoiceEntry { |
---|
| 16 | inherit itk::Widget |
---|
| 17 | |
---|
[437] | 18 | itk_option define -state state State "normal" |
---|
| 19 | |
---|
[22] | 20 | constructor {owner path args} { # defined below } |
---|
| 21 | destructor { # defined below } |
---|
[11] | 22 | |
---|
| 23 | public method value {args} |
---|
| 24 | |
---|
| 25 | public method label {} |
---|
| 26 | public method tooltip {} |
---|
| 27 | |
---|
[22] | 28 | protected method _rebuild {} |
---|
[11] | 29 | protected method _newValue {} |
---|
| 30 | protected method _tooltip {} |
---|
| 31 | |
---|
[22] | 32 | private variable _owner "" ;# thing managing this control |
---|
[11] | 33 | private variable _path "" ;# path in XML to this number |
---|
[429] | 34 | private variable _str2val ;# maps option label => option value |
---|
[11] | 35 | } |
---|
| 36 | |
---|
| 37 | itk::usual ChoiceEntry { |
---|
| 38 | keep -cursor -font |
---|
| 39 | keep -foreground -background |
---|
| 40 | keep -textforeground -textbackground |
---|
| 41 | keep -selectbackground -selectforeground -selectborderwidth |
---|
| 42 | } |
---|
| 43 | |
---|
| 44 | # ---------------------------------------------------------------------- |
---|
| 45 | # CONSTRUCTOR |
---|
| 46 | # ---------------------------------------------------------------------- |
---|
[22] | 47 | itcl::body Rappture::ChoiceEntry::constructor {owner path args} { |
---|
| 48 | if {[catch {$owner isa Rappture::ControlOwner} valid] != 0 || !$valid} { |
---|
[1342] | 49 | error "bad object \"$owner\": should be Rappture::ControlOwner" |
---|
[11] | 50 | } |
---|
[22] | 51 | set _owner $owner |
---|
[11] | 52 | set _path $path |
---|
| 53 | |
---|
| 54 | # |
---|
| 55 | # Create the widget and configure it properly based on other |
---|
| 56 | # hints in the XML. |
---|
| 57 | # |
---|
| 58 | itk_component add choice { |
---|
[1342] | 59 | Rappture::Combobox $itk_interior.choice -editable no |
---|
[11] | 60 | } |
---|
| 61 | pack $itk_component(choice) -expand yes -fill both |
---|
| 62 | bind $itk_component(choice) <<Value>> [itcl::code $this _newValue] |
---|
| 63 | |
---|
| 64 | eval itk_initialize $args |
---|
| 65 | |
---|
[22] | 66 | _rebuild |
---|
| 67 | } |
---|
[11] | 68 | |
---|
[22] | 69 | # ---------------------------------------------------------------------- |
---|
| 70 | # DESTRUCTOR |
---|
| 71 | # ---------------------------------------------------------------------- |
---|
| 72 | itcl::body Rappture::ChoiceEntry::destructor {} { |
---|
| 73 | $_owner notify remove $this |
---|
[11] | 74 | } |
---|
| 75 | |
---|
| 76 | # ---------------------------------------------------------------------- |
---|
| 77 | # USAGE: value ?-check? ?<newval>? |
---|
| 78 | # |
---|
| 79 | # Clients use this to query/set the value for this widget. With |
---|
| 80 | # no args, it returns the current value for the widget. If the |
---|
| 81 | # <newval> is specified, it sets the value of the widget and |
---|
| 82 | # sends a <<Value>> event. If the -check flag is included, the |
---|
| 83 | # new value is not actually applied, but just checked for correctness. |
---|
| 84 | # ---------------------------------------------------------------------- |
---|
| 85 | itcl::body Rappture::ChoiceEntry::value {args} { |
---|
| 86 | set onlycheck 0 |
---|
| 87 | set i [lsearch -exact $args -check] |
---|
| 88 | if {$i >= 0} { |
---|
[1342] | 89 | set onlycheck 1 |
---|
| 90 | set args [lreplace $args $i $i] |
---|
[11] | 91 | } |
---|
| 92 | |
---|
| 93 | if {[llength $args] == 1} { |
---|
[1342] | 94 | if {$onlycheck} { |
---|
| 95 | # someday we may add validation... |
---|
| 96 | return |
---|
| 97 | } |
---|
| 98 | set newval [lindex $args 0] |
---|
| 99 | if {[info exists _str2val($newval)]} { |
---|
| 100 | # this is a label -- use it directly |
---|
| 101 | $itk_component(choice) value $newval |
---|
| 102 | set newval $_str2val($newval) ;# report the actual value |
---|
| 103 | } else { |
---|
| 104 | # this is a value -- search for corresponding label |
---|
| 105 | foreach str [array names _str2val] { |
---|
| 106 | if {$_str2val($str) == $newval} { |
---|
| 107 | $itk_component(choice) value $str |
---|
| 108 | break |
---|
| 109 | } |
---|
| 110 | } |
---|
| 111 | } |
---|
| 112 | return $newval |
---|
[11] | 113 | |
---|
| 114 | } elseif {[llength $args] != 0} { |
---|
[1342] | 115 | error "wrong # args: should be \"value ?-check? ?newval?\"" |
---|
[11] | 116 | } |
---|
| 117 | |
---|
| 118 | # |
---|
| 119 | # Query the value and return. |
---|
| 120 | # |
---|
[429] | 121 | set str [$itk_component(choice) value] |
---|
| 122 | if {[info exists _str2val($str)]} { |
---|
[1342] | 123 | return $_str2val($str) |
---|
[429] | 124 | } |
---|
| 125 | return $str |
---|
[11] | 126 | } |
---|
| 127 | |
---|
| 128 | # ---------------------------------------------------------------------- |
---|
| 129 | # USAGE: label |
---|
| 130 | # |
---|
| 131 | # Clients use this to query the label associated with this widget. |
---|
| 132 | # Reaches into the XML and pulls out the appropriate label string. |
---|
| 133 | # ---------------------------------------------------------------------- |
---|
| 134 | itcl::body Rappture::ChoiceEntry::label {} { |
---|
[22] | 135 | set label [$_owner xml get $_path.about.label] |
---|
[11] | 136 | if {"" == $label} { |
---|
[1342] | 137 | set label "Choice" |
---|
[11] | 138 | } |
---|
| 139 | return $label |
---|
| 140 | } |
---|
| 141 | |
---|
| 142 | # ---------------------------------------------------------------------- |
---|
| 143 | # USAGE: tooltip |
---|
| 144 | # |
---|
| 145 | # Clients use this to query the tooltip associated with this widget. |
---|
| 146 | # Reaches into the XML and pulls out the appropriate description |
---|
| 147 | # string. Returns the string that should be used with the |
---|
| 148 | # Rappture::Tooltip facility. |
---|
| 149 | # ---------------------------------------------------------------------- |
---|
| 150 | itcl::body Rappture::ChoiceEntry::tooltip {} { |
---|
| 151 | # query tooltip on-demand based on current choice |
---|
| 152 | return "@[itcl::code $this _tooltip]" |
---|
| 153 | } |
---|
| 154 | |
---|
| 155 | # ---------------------------------------------------------------------- |
---|
[22] | 156 | # USAGE: _rebuild |
---|
| 157 | # |
---|
| 158 | # Used internally to rebuild the contents of this choice widget |
---|
| 159 | # whenever something that it depends on changes. Scans through the |
---|
| 160 | # information in the XML spec and builds a list of choices for the |
---|
| 161 | # widget. |
---|
| 162 | # ---------------------------------------------------------------------- |
---|
| 163 | itcl::body Rappture::ChoiceEntry::_rebuild {} { |
---|
| 164 | # get rid of any existing choices |
---|
| 165 | $itk_component(choice) choices delete 0 end |
---|
[429] | 166 | catch {unset _str2val} |
---|
[22] | 167 | |
---|
| 168 | # |
---|
| 169 | # Plug in the various options for the choice. |
---|
| 170 | # |
---|
| 171 | set max 10 |
---|
| 172 | foreach cname [$_owner xml children -type option $_path] { |
---|
[1342] | 173 | set path [string trim [$_owner xml get $_path.$cname.path]] |
---|
| 174 | if {"" != $path} { |
---|
| 175 | # look for the input element controlling this path |
---|
| 176 | set found 0 |
---|
| 177 | foreach cntl [Rappture::entities [$_owner xml object] "input"] { |
---|
| 178 | set len [string length $cntl] |
---|
| 179 | if {[string equal -length $len $cntl $path]} { |
---|
| 180 | set found 1 |
---|
| 181 | break |
---|
| 182 | } |
---|
| 183 | } |
---|
| 184 | if {$found} { |
---|
| 185 | # |
---|
| 186 | # Choice comes from a list of matching entities at |
---|
| 187 | # a particular XML path. Use the <label> as a template |
---|
| 188 | # for each item on the path. |
---|
| 189 | # |
---|
| 190 | $_owner notify add $this $cntl [itcl::code $this _rebuild] |
---|
[22] | 191 | |
---|
[1342] | 192 | set label [string trim [$_owner xml get $_path.$cname.about.label]] |
---|
| 193 | if {"" == $label} { |
---|
| 194 | set label "%type #%n" |
---|
| 195 | } |
---|
[22] | 196 | |
---|
[1342] | 197 | set ppath [Rappture::LibraryObj::path2list $path] |
---|
| 198 | set leading [join [lrange $ppath 0 end-1] .] |
---|
| 199 | set tail [lindex $ppath end] |
---|
| 200 | set n 1 |
---|
| 201 | foreach ccname [$_owner xml children $leading] { |
---|
| 202 | if {[string match $tail $ccname]} { |
---|
| 203 | set subst(%n) $n |
---|
| 204 | set subst(%type) [$_owner xml element -as type $leading.$ccname] |
---|
| 205 | set subst(%id) [$_owner xml element -as id $leading.$ccname] |
---|
| 206 | foreach detail [$_owner xml children $leading.$ccname] { |
---|
| 207 | set subst(%$detail) [$_owner xml get $leading.$ccname.$detail] |
---|
| 208 | } |
---|
| 209 | set str [string map [array get subst] $label] |
---|
| 210 | $itk_component(choice) choices insert end \ |
---|
| 211 | $leading.$ccname $str |
---|
| 212 | incr n |
---|
| 213 | } |
---|
| 214 | } |
---|
| 215 | $itk_component(choice) value "" |
---|
| 216 | } else { |
---|
| 217 | puts "can't find controlling entity for path \"$path\"" |
---|
| 218 | } |
---|
| 219 | } else { |
---|
| 220 | # |
---|
| 221 | # Choice is an ordinary LABEL. |
---|
| 222 | # Add the label as-is into the list of choices. |
---|
| 223 | # |
---|
| 224 | set val [string trim [$_owner xml get $_path.$cname.value]] |
---|
| 225 | set str [string trim [$_owner xml get $_path.$cname.about.label]] |
---|
| 226 | if {"" == $val} { |
---|
| 227 | set val $str |
---|
| 228 | } |
---|
| 229 | if {"" != $str} { |
---|
| 230 | set _str2val($str) $val |
---|
| 231 | $itk_component(choice) choices insert end $_path.$cname $str |
---|
| 232 | set len [string length $str] |
---|
| 233 | if {$len > $max} { set max $len } |
---|
| 234 | } |
---|
| 235 | } |
---|
[22] | 236 | } |
---|
| 237 | $itk_component(choice) configure -width $max |
---|
| 238 | |
---|
| 239 | # |
---|
| 240 | # Assign the default value to this widget, if there is one. |
---|
| 241 | # |
---|
[429] | 242 | set defval [$_owner xml get $_path.default] |
---|
| 243 | if {"" != $defval} { |
---|
[1342] | 244 | if {[info exists _str2val($defval)]} { |
---|
| 245 | $itk_component(choice) value $defval |
---|
| 246 | } else { |
---|
| 247 | foreach str [array names _str2val] { |
---|
| 248 | if {$_str2val($str) == $defval} { |
---|
| 249 | $itk_component(choice) value $str |
---|
| 250 | break |
---|
| 251 | } |
---|
| 252 | } |
---|
| 253 | } |
---|
[429] | 254 | } |
---|
[22] | 255 | } |
---|
| 256 | |
---|
| 257 | # ---------------------------------------------------------------------- |
---|
[11] | 258 | # USAGE: _newValue |
---|
| 259 | # |
---|
| 260 | # Invoked automatically whenever the value in the choice changes. |
---|
| 261 | # Sends a <<Value>> event to notify clients of the change. |
---|
| 262 | # ---------------------------------------------------------------------- |
---|
| 263 | itcl::body Rappture::ChoiceEntry::_newValue {} { |
---|
| 264 | event generate $itk_component(hull) <<Value>> |
---|
| 265 | } |
---|
| 266 | |
---|
| 267 | # ---------------------------------------------------------------------- |
---|
| 268 | # USAGE: _tooltip |
---|
| 269 | # |
---|
| 270 | # Returns the tooltip for this widget, given the current choice in |
---|
| 271 | # the selector. This is normally called by the Rappture::Tooltip |
---|
| 272 | # facility whenever it is about to pop up a tooltip for this widget. |
---|
| 273 | # ---------------------------------------------------------------------- |
---|
| 274 | itcl::body Rappture::ChoiceEntry::_tooltip {} { |
---|
[22] | 275 | set tip [string trim [$_owner xml get $_path.about.description]] |
---|
[11] | 276 | |
---|
| 277 | # get the description for the current choice, if there is one |
---|
| 278 | set str [$itk_component(choice) value] |
---|
| 279 | set path [$itk_component(choice) translate $str] |
---|
[429] | 280 | set desc "" |
---|
| 281 | if {$path != ""} { |
---|
[1342] | 282 | set desc [$_owner xml get $path.about.description] |
---|
[429] | 283 | } |
---|
[11] | 284 | |
---|
[429] | 285 | if {[string length $str] > 0 && [string length $desc] > 0} { |
---|
[1342] | 286 | append tip "\n\n$str:\n$desc" |
---|
[11] | 287 | } |
---|
| 288 | return $tip |
---|
| 289 | } |
---|
[437] | 290 | |
---|
| 291 | # ---------------------------------------------------------------------- |
---|
| 292 | # CONFIGURATION OPTION: -state |
---|
| 293 | # ---------------------------------------------------------------------- |
---|
| 294 | itcl::configbody Rappture::ChoiceEntry::state { |
---|
| 295 | set valid {normal disabled} |
---|
| 296 | if {[lsearch -exact $valid $itk_option(-state)] < 0} { |
---|
[1342] | 297 | error "bad value \"$itk_option(-state)\": should be [join $valid {, }]" |
---|
[437] | 298 | } |
---|
| 299 | $itk_component(choice) configure -state $itk_option(-state) |
---|
| 300 | } |
---|