source: trunk/gui/scripts/choiceentry.tcl @ 2505

Last change on this file since 2505 was 1929, checked in by gah, 14 years ago
File size: 10.7 KB
Line 
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
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.
12# ======================================================================
13package require Itk
14
15itcl::class Rappture::ChoiceEntry {
16    inherit itk::Widget
17
18    itk_option define -state state State "normal"
19
20    constructor {owner path args} { # defined below }
21    destructor { # defined below }
22
23    public method value {args}
24
25    public method label {}
26    public method tooltip {}
27
28    protected method _rebuild {}
29    protected method _newValue {}
30    protected method _tooltip {}
31
32    private variable _owner ""    ;# thing managing this control
33    private variable _path ""     ;# path in XML to this number
34    private variable _str2val     ;# maps option label => option value
35}
36
37itk::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# ----------------------------------------------------------------------
47itcl::body Rappture::ChoiceEntry::constructor {owner path args} {
48    if {[catch {$owner isa Rappture::ControlOwner} valid] != 0 || !$valid} {
49        error "bad object \"$owner\": should be Rappture::ControlOwner"
50    }
51    set _owner $owner
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 {
59        Rappture::Combobox $itk_interior.choice -editable no
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
66    _rebuild
67}
68
69# ----------------------------------------------------------------------
70# DESTRUCTOR
71# ----------------------------------------------------------------------
72itcl::body Rappture::ChoiceEntry::destructor {} {
73    $_owner notify remove $this
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# ----------------------------------------------------------------------
85itcl::body Rappture::ChoiceEntry::value {args} {
86    set onlycheck 0
87    set i [lsearch -exact $args -check]
88    if {$i >= 0} {
89        set onlycheck 1
90        set args [lreplace $args $i $i]
91    }
92
93    if {[llength $args] == 1} {
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
113
114    } elseif {[llength $args] != 0} {
115        error "wrong # args: should be \"value ?-check? ?newval?\""
116    }
117
118    #
119    # Query the value and return.
120    #
121    set str [$itk_component(choice) value]
122    if {[info exists _str2val($str)]} {
123        return $_str2val($str)
124    }
125    return $str
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# ----------------------------------------------------------------------
134itcl::body Rappture::ChoiceEntry::label {} {
135    set label [$_owner xml get $_path.about.label]
136    if {"" == $label} {
137        set label "Choice"
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# ----------------------------------------------------------------------
150itcl::body Rappture::ChoiceEntry::tooltip {} {
151    # query tooltip on-demand based on current choice
152    return "@[itcl::code $this _tooltip]"
153}
154
155# ----------------------------------------------------------------------
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# ----------------------------------------------------------------------
163itcl::body Rappture::ChoiceEntry::_rebuild {} {
164    # get rid of any existing choices
165    $itk_component(choice) choices delete 0 end
166    catch {unset _str2val}
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] {
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]
191
192                set label [string trim [$_owner xml get $_path.$cname.about.label]]
193                if {"" == $label} {
194                    set label "%type #%n"
195                }
196
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        }
236    }
237    $itk_component(choice) configure -width $max
238
239    #
240    # Assign the default value to this widget, if there is one.
241    #
242    set defval [$_owner xml get $_path.default]
243    if {"" != $defval} {
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        }
254    }
255}
256
257# ----------------------------------------------------------------------
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# ----------------------------------------------------------------------
263itcl::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# ----------------------------------------------------------------------
274itcl::body Rappture::ChoiceEntry::_tooltip {} {
275    set tip [string trim [$_owner xml get $_path.about.description]]
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]
280    set desc ""
281    if {$path != ""} {
282        set desc [$_owner xml get $path.about.description]
283    }
284
285    if {[string length $str] > 0 && [string length $desc] > 0} {
286        append tip "\n\n$str:\n$desc"
287    }
288    return $tip
289}
290
291# ----------------------------------------------------------------------
292# CONFIGURATION OPTION: -state
293# ----------------------------------------------------------------------
294itcl::configbody Rappture::ChoiceEntry::state {
295    set valid {normal disabled}
296    if {[lsearch -exact $valid $itk_option(-state)] < 0} {
297        error "bad value \"$itk_option(-state)\": should be [join $valid {, }]"
298    }
299    $itk_component(choice) configure -state $itk_option(-state)
300}
Note: See TracBrowser for help on using the repository browser.