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

Last change on this file since 6235 was 5659, checked in by ldelgass, 9 years ago

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