source: branches/1.4/gui/scripts/filechoiceentry.tcl @ 5660

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

Merge r5657:5659 from trunk (whitespace/style)

File size: 10.9 KB
Line 
1# -*- mode: tcl; indent-tabs-mode: nil -*-
2# ----------------------------------------------------------------------
3#  COMPONENT: FileChoiceEntry - 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-2005  Purdue Research Foundation
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::FileChoiceEntry {
17    inherit itk::Widget
18
19    itk_option define -state state State "normal"
20
21    private variable _rebuildPending 0
22
23    constructor {owner path args} {
24        # defined below
25    }
26    destructor {
27        # defined below
28    }
29    public method value {args}
30
31    public method label {}
32    public method tooltip {}
33
34    protected method Rebuild {}
35    protected method NewValue {}
36    protected method Tooltip {}
37    protected method WhenIdle {}
38    private method DoGlob { cwd patterns }
39    private method Glob { pattern }
40
41    private variable _owner ""    ;# thing managing this control
42    private variable _path ""     ;# path in XML to this number
43    private variable _str2val     ;# maps option label => option value
44}
45
46itk::usual FileChoiceEntry {
47    keep -cursor -font
48    keep -foreground -background
49    keep -textforeground -textbackground
50    keep -selectbackground -selectforeground -selectborderwidth
51}
52
53# ----------------------------------------------------------------------
54# CONSTRUCTOR
55# ----------------------------------------------------------------------
56itcl::body Rappture::FileChoiceEntry::constructor {owner path args} {
57    if {[catch {$owner isa Rappture::ControlOwner} valid] != 0 || !$valid} {
58        error "bad object \"$owner\": should be Rappture::ControlOwner"
59    }
60    set _owner $owner
61    set _path $path
62
63    #
64    # Create the widget and configure it properly based on other
65    # hints in the XML.
66    #
67    itk_component add choice {
68        Rappture::Combobox $itk_interior.choice -editable no
69    }
70    pack $itk_component(choice) -expand yes -fill both
71    bind $itk_component(choice) <<Value>> [itcl::code $this NewValue]
72
73    # First time, parse the <pattern> elements to generate notify callbacks
74    # for each template found.
75    foreach cname [$_owner xml children -type pattern $_path] {
76        set glob [string trim [$_owner xml get $_path.$cname]]
77        # Successively replace each template with its value.
78        while { [regexp -indices {@@[^@]*@@} $glob range] } {
79            foreach {first last} $range break
80            set i1 [expr $first + 2]
81            set i2 [expr $last  - 2]
82            set cpath [string range $glob $i1 $i2]
83            set value [$_owner xml get $cpath.$cname]
84            set glob [string replace $glob $first $last $value]
85            $_owner notify add $this $cpath [itcl::code $this WhenIdle]
86        }
87    }
88    $_owner notify sync
89    eval itk_initialize $args
90    Rebuild
91}
92
93# ----------------------------------------------------------------------
94# DESTRUCTOR
95# ----------------------------------------------------------------------
96itcl::body Rappture::FileChoiceEntry::destructor {} {
97    $_owner notify remove $this
98}
99
100# ----------------------------------------------------------------------
101# USAGE: value ?-check? ?<newval>?
102#
103# Clients use this to query/set the value for this widget.  With
104# no args, it returns the current value for the widget.  If the
105# <newval> is specified, it sets the value of the widget and
106# sends a <<Value>> event.  If the -check flag is included, the
107# new value is not actually applied, but just checked for correctness.
108# ----------------------------------------------------------------------
109itcl::body Rappture::FileChoiceEntry::value {args} {
110    set onlycheck 0
111    set i [lsearch -exact $args -check]
112    if {$i >= 0} {
113        set onlycheck 1
114        set args [lreplace $args $i $i]
115    }
116
117    if {[llength $args] == 1} {
118        if {$onlycheck} {
119            # someday we may add validation...
120            return
121        }
122        set newval [lindex $args 0]
123        if {[info exists _str2val($newval)]} {
124            # this is a label -- use it directly
125            $itk_component(choice) value $newval
126            set newval $_str2val($newval)  ;# report the actual value
127        } else {
128            # this is a value -- search for corresponding label
129            foreach str [array names _str2val] {
130                if {$_str2val($str) == $newval} {
131                    $itk_component(choice) value $str
132                    break
133                }
134            }
135        }
136        return $newval
137
138    } elseif {[llength $args] != 0} {
139        error "wrong # args: should be \"value ?-check? ?newval?\""
140    }
141
142    #
143    # Query the value and return.
144    #
145    set str [$itk_component(choice) value]
146    if {[info exists _str2val($str)]} {
147        return $_str2val($str)
148    }
149    return $str
150}
151
152# ----------------------------------------------------------------------
153# USAGE: label
154#
155# Clients use this to query the label associated with this widget.
156# Reaches into the XML and pulls out the appropriate label string.
157# ----------------------------------------------------------------------
158itcl::body Rappture::FileChoiceEntry::label {} {
159    set label [$_owner xml get $_path.about.label]
160    if {"" == $label} {
161        set label "Choice"
162    }
163    return $label
164}
165
166# ----------------------------------------------------------------------
167# USAGE: tooltip
168#
169# Clients use this to query the tooltip associated with this widget.
170# Reaches into the XML and pulls out the appropriate description
171# string.  Returns the string that should be used with the
172# Rappture::Tooltip facility.
173# ----------------------------------------------------------------------
174itcl::body Rappture::FileChoiceEntry::tooltip {} {
175    # query tooltip on-demand based on current choice
176    return "@[itcl::code $this Tooltip]"
177}
178
179# ----------------------------------------------------------------------
180# USAGE: Rebuild
181#
182# Used internally to rebuild the contents of this choice widget
183# whenever something that it depends on changes.  Scans through the
184# information in the XML spec and builds a list of choices for the
185# widget.
186# ----------------------------------------------------------------------
187itcl::body Rappture::FileChoiceEntry::Rebuild {} {
188    set _rebuildPending 0
189    # get rid of any existing choices
190    $itk_component(choice) choices delete 0 end
191    array unset _str2val
192    #
193    # Plug in the various options for the choice.
194    #
195    set max 10
196    $_owner notify sync
197    set allfiles {}
198    foreach cname [$_owner xml children -type pattern $_path] {
199        set glob [string trim [$_owner xml get $_path.$cname]]
200        # Successively replace each template with its value.
201        while { [regexp -indices {@@[^@]*@@} $glob range] } {
202            foreach {first last} $range break
203            set i1 [expr $first + 2]
204            set i2 [expr $last  - 2]
205            set cpath [string range $glob $i1 $i2]
206            set value [$_owner xml get $cpath.current]
207            if { $value == "" } {
208                set value [$_owner xml get $cpath.default]
209            }
210            set glob [string replace $glob $first $last $value]
211        }
212        # Replace the template with the substituted value.
213        set files [Glob $glob]
214        set allfiles [concat $allfiles $files]
215    }
216    set first ""
217    set tail ""
218    foreach file $allfiles {
219        set tail [file tail $file]
220        if { $first == "" } {
221            set first $tail
222        }
223        set root [file root $tail]
224        $itk_component(choice) choices insert end $file $tail
225        set _str2val($tail) $file
226        set len [string length $tail]
227        if {$len > $max} { set max $len }
228    }
229    $itk_component(choice) configure -width $max
230    $itk_component(choice) value $tail
231}
232
233# ----------------------------------------------------------------------
234# USAGE: NewValue
235#
236# Invoked automatically whenever the value in the choice changes.
237# Sends a <<Value>> event to notify clients of the change.
238# ----------------------------------------------------------------------
239itcl::body Rappture::FileChoiceEntry::NewValue {} {
240    event generate $itk_component(hull) <<Value>>
241}
242
243# ----------------------------------------------------------------------
244# USAGE: Tooltip
245#
246# Returns the tooltip for this widget, given the current choice in
247# the selector.  This is normally called by the Rappture::Tooltip
248# facility whenever it is about to pop up a tooltip for this widget.
249# ----------------------------------------------------------------------
250itcl::body Rappture::FileChoiceEntry::Tooltip {} {
251    set tip [string trim [$_owner xml get $_path.about.description]]
252    # get the description for the current choice, if there is one
253    set str [$itk_component(choice) value]
254    set path [$itk_component(choice) translate $str]
255    set desc $path
256    if {$path == ""} {
257        set desc [$_owner xml get $_path.about.description]
258    }
259
260    if {[string length $str] > 0 && [string length $desc] > 0} {
261        append tip "\n\n$str:\n$desc"
262    }
263    return $tip
264}
265
266# ----------------------------------------------------------------------
267# CONFIGURATION OPTION: -state
268# ----------------------------------------------------------------------
269itcl::configbody Rappture::FileChoiceEntry::state {
270    set valid {normal disabled}
271    if {[lsearch -exact $valid $itk_option(-state)] < 0} {
272        error "bad value \"$itk_option(-state)\": should be [join $valid {, }]"
273    }
274    $itk_component(choice) configure -state $itk_option(-state)
275}
276
277itcl::body Rappture::FileChoiceEntry::WhenIdle {} {
278    if { !$_rebuildPending } {
279        after 10 [itcl::code $this Rebuild]
280        set _rebuildPending 1
281    }
282}
283
284itcl::body Rappture::FileChoiceEntry::DoGlob { cwd patterns } {
285    set rest [lrange $patterns 1 end]
286    set pattern [file join $cwd [lindex $patterns 0]]
287    set files ""
288    if { [llength $rest] > 0 } {
289        if { [catch {
290            glob -nocomplain -type d $pattern
291        } dirs] != 0 } {
292            puts stderr "can't glob \"$pattern\": $dirs"
293            return
294        }
295        foreach d $dirs {
296            set files [concat $files [DoGlob $d $rest]]
297        }
298    } else {
299        if { [catch {
300            glob -nocomplain $pattern
301        } files] != 0 } {
302            puts stderr "can't glob \"$pattern\": $files"
303            return
304        }
305    }
306    return [lsort -dictionary $files]
307}
308
309#
310# Glob --
311#
312#       Matches a single pattern for files. This differs from the
313#       Tcl glob by
314#
315#       1. Only matches files, not directories.
316#       2. Doesn't stop on errors (e.g. unreadable directories).
317#
318itcl::body Rappture::FileChoiceEntry::Glob { pattern } {
319    return [DoGlob "" [file split $pattern]]
320}
321
Note: See TracBrowser for help on using the repository browser.