source: branches/multichoice/gui/scripts/multichoiceentry.tcl @ 6317

Last change on this file since 6317 was 6317, checked in by dkearney, 8 years ago

fix multichoice widget to return the value string for chosen labels, if available, instead of returning the label.
File size: 11.5 KB
Line 
1# -*- mode: tcl; indent-tabs-mode: nil -*-
2# ----------------------------------------------------------------------
3#  COMPONENT: MultiChoiceEntry - widget for entering a choice of strings
4#
5#  This widget represents a <multichoice> 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::MultiChoiceEntry {
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 MultiChoiceEntry {
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::MultiChoiceEntry::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::Combochecks $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::MultiChoiceEntry::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::MultiChoiceEntry::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 result ""
125    set str [$itk_component(choice) value]
126    regsub -all {, } $str {,} str
127    foreach lbl [split $str {,}] {
128        if {[info exists _str2val($lbl)]} {
129            set lbl $_str2val($lbl)
130        }
131        lappend result $lbl
132    }
133    return [join $result {, }]
134}
135
136# ----------------------------------------------------------------------
137# USAGE: label
138#
139# Clients use this to query the label associated with this widget.
140# Reaches into the XML and pulls out the appropriate label string.
141# ----------------------------------------------------------------------
142itcl::body Rappture::MultiChoiceEntry::label {} {
143    set label [string trim [$_owner xml get $_path.about.label]]
144    if {"" == $label} {
145        set label "MultiChoice"
146    }
147    return $label
148}
149
150# ----------------------------------------------------------------------
151# USAGE: tooltip
152#
153# Clients use this to query the tooltip associated with this widget.
154# Reaches into the XML and pulls out the appropriate description
155# string.  Returns the string that should be used with the
156# Rappture::Tooltip facility.
157# ----------------------------------------------------------------------
158itcl::body Rappture::MultiChoiceEntry::tooltip {} {
159    # query tooltip on-demand based on current choice
160    return "@[itcl::code $this _tooltip]"
161}
162
163# ----------------------------------------------------------------------
164# USAGE: _rebuild
165#
166# Used internally to rebuild the contents of this choice widget
167# whenever something that it depends on changes.  Scans through the
168# information in the XML spec and builds a list of choices for the
169# widget.
170# ----------------------------------------------------------------------
171itcl::body Rappture::MultiChoiceEntry::_rebuild {} {
172    # get rid of any existing choices
173    $itk_component(choice) choices delete 0 end
174    catch {unset _str2val}
175
176    #
177    # Plug in the various options for the choice.
178    #
179    set max 10
180    foreach cname [$_owner xml children -type option $_path] {
181        set path [string trim [$_owner xml get $_path.$cname.path]]
182        if {"" != $path} {
183            # look for the input element controlling this path
184            set found 0
185            foreach cntl [Rappture::entities [$_owner xml object] "input"] {
186                set len [string length $cntl]
187                if {[string equal -length $len $cntl $path]} {
188                    set found 1
189                    break
190                }
191            }
192            if {$found} {
193                #
194                # Choice comes from a list of matching entities at
195                # a particular XML path.  Use the <label> as a template
196                # for each item on the path.
197                #
198                $_owner notify add $this $cntl [itcl::code $this _rebuild]
199
200                set label \
201                    [string trim [$_owner xml get $_path.$cname.about.label]]
202                if {"" == $label} {
203                    set label "%type #%n"
204                }
205
206                set ppath [Rappture::LibraryObj::path2list $path]
207                set leading [join [lrange $ppath 0 end-1] .]
208                set tail [lindex $ppath end]
209                set n 1
210                foreach ccname [$_owner xml children $leading] {
211                    if {[string match $tail $ccname]} {
212                        set subst(%n) $n
213                        set subst(%type) [$_owner xml element -as type $leading.$ccname]
214                        set subst(%id) [$_owner xml element -as id $leading.$ccname]
215                        foreach detail [$_owner xml children $leading.$ccname] {
216                            set subst(%$detail) \
217                                [$_owner xml get $leading.$ccname.$detail]
218                        }
219                        set str [string map [array get subst] $label]
220                        $itk_component(choice) choices insert end \
221                            $leading.$ccname $str
222                        incr n
223                    }
224                }
225                $itk_component(choice) value ""
226            } else {
227                puts "can't find controlling entity for path \"$path\""
228            }
229        } else {
230            #
231            # Choice is an ordinary LABEL.
232            # Add the label as-is into the list of choices.
233            #
234            set val [string trim [$_owner xml get $_path.$cname.value]]
235            set str [string trim [$_owner xml get $_path.$cname.about.label]]
236            if {"" == $val} {
237                set val $str
238            }
239            if {"" != $str} {
240                set _str2val($str) $val
241                $itk_component(choice) choices insert end $_path.$cname $str
242                set len [string length $str]
243                if {$len > $max} { set max $len }
244            }
245        }
246    }
247    $itk_component(choice) configure -width $max
248
249    #
250    # Assign the default value to this widget, if there is one.
251    #
252    set defval [string trim [$_owner xml get $_path.default]]
253    if {"" != $defval} {
254        if {[info exists _str2val($defval)]} {
255            $itk_component(choice) value $defval
256        } else {
257            foreach str [array names _str2val] {
258                if {$_str2val($str) == $defval} {
259                    $itk_component(choice) value $str
260                    break
261                }
262            }
263        }
264    }
265}
266
267# ----------------------------------------------------------------------
268# USAGE: _newValue
269#
270# Invoked automatically whenever the value in the choice changes.
271# Sends a <<Value>> event to notify clients of the change.
272# ----------------------------------------------------------------------
273itcl::body Rappture::MultiChoiceEntry::_newValue {} {
274    event generate $itk_component(hull) <<Value>>
275}
276
277# ----------------------------------------------------------------------
278# USAGE: _tooltip
279#
280# Returns the tooltip for this widget, given the current choice in
281# the selector.  This is normally called by the Rappture::Tooltip
282# facility whenever it is about to pop up a tooltip for this widget.
283# ----------------------------------------------------------------------
284itcl::body Rappture::MultiChoiceEntry::_tooltip {} {
285    set tip [string trim [$_owner xml get $_path.about.description]]
286
287    # get the description for the current choice, if there is one
288    set str [$itk_component(choice) value]
289    set path [$itk_component(choice) translate $str]
290    set desc ""
291    if {$path != ""} {
292        set desc [string trim [$_owner xml get $path.about.description]]
293    }
294
295    if {[string length $str] > 0 && [string length $desc] > 0} {
296        append tip "\n\n$str:\n$desc"
297    }
298    return $tip
299}
300
301# ----------------------------------------------------------------------
302# USAGE: _log
303#
304# Used internally to send info to the logging mechanism.  Calls the
305# Rappture::Logger mechanism to log the change to this input.
306# ----------------------------------------------------------------------
307itcl::body Rappture::MultiChoiceEntry::_log {} {
308    Rappture::Logger::log input $_path [$itk_component(choice) value]
309}
310
311# ----------------------------------------------------------------------
312# CONFIGURATION OPTION: -state
313# ----------------------------------------------------------------------
314itcl::configbody Rappture::MultiChoiceEntry::state {
315    set valid {normal disabled}
316    if {[lsearch -exact $valid $itk_option(-state)] < 0} {
317        error "bad value \"$itk_option(-state)\": should be [join $valid {, }]"
318    }
319    $itk_component(choice) configure -state $itk_option(-state)
320}
Note: See TracBrowser for help on using the repository browser.