source: trunk/gui/scripts/textentry.tcl @ 856

Last change on this file since 856 was 724, checked in by mmc, 17 years ago

Fixed the bugreport component to automatically register all "Oops!"
errors with the ticketing system on the hosting hub. When the
RAPPTURE_VERSION environment variable is set to "current", the
dialog automatically registers errors. Otherwise, it pops up a
dialog showing the error to the developer. It also registers errors
that come from launching jobs ("Problem launching job" messages).

Fixed the Makefile to install all scripts/*.tcl files, so we don't
have to modify configure each time a file is added.
File size: 21.1 KB
Line 
1# ----------------------------------------------------------------------
2#  COMPONENT: textentry - general-purpose text entry widget
3#
4#  This widget is a cross between the Tk entry and text widgets.  For
5#  one-line messages, it acts like an entry widget.  For larger
6#  messages, it morphs into a text widget.
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
16option add *TextEntry.size auto widgetDefault
17option add *TextEntry.width 0 widgetDefault
18option add *TextEntry.height 0 widgetDefault
19option add *TextEntry.editable yes widgetDefault
20option add *TextEntry.textBackground white widgetDefault
21option add *TextEntry*disabledForeground #a3a3a3 widgetDefault
22option add *TextEntry*disabledBackground white widgetDefault
23
24option add *TextEntry.hintForeground gray50 widgetDefault
25option add *TextEntry.hintFont \
26    -*-helvetica-medium-r-normal-*-10-* widgetDefault
27option add *TextEntry.codeFont \
28    -*-courier-medium-r-normal-*-12-* widgetDefault
29
30
31itcl::class Rappture::TextEntry {
32    inherit itk::Widget
33
34    itk_option define -editable editable Editable ""
35    itk_option define -state state State "normal"
36    itk_option define -width width Width 0
37    itk_option define -height height Height 0
38
39    constructor {owner path args} { # defined below }
40
41    public method value {args}
42
43    public method label {}
44    public method tooltip {}
45    public method size {} { return $_size }
46
47    protected method _layout {}
48    protected method _setValue {value}
49    protected method _newValue {}
50    protected method _edit {option args}
51    protected method _fixState {}
52    protected method _uploadValue {args}
53    protected method _downloadValue {}
54
55    private variable _dispatcher "" ;# dispatcher for !events
56    private variable _owner ""      ;# thing managing this control
57    private variable _path ""       ;# path in XML to this number
58
59    private variable _layout ""     ;# entry or full text size
60    private variable _mode "ascii"  ;# ascii text or binary data
61    private variable _value ""      ;# value inside the widget
62    private variable _size ""       ;# size hint from XML
63}
64                                                                               
65itk::usual TextEntry {
66}
67
68# ----------------------------------------------------------------------
69# CONSTRUCTOR
70# ----------------------------------------------------------------------
71itcl::body Rappture::TextEntry::constructor {owner path args} {
72    if {[catch {$owner isa Rappture::ControlOwner} valid] != 0 || !$valid} {
73        error "bad object \"$owner\": should be Rappture::ControlOwner"
74    }
75    set _owner $owner
76    set _path $path
77
78    Rappture::dispatcher _dispatcher
79    $_dispatcher register !layout
80    $_dispatcher dispatch $this !layout "[itcl::code $this _layout]; list"
81
82    set _size [$_owner xml get $path.size]
83
84    set hints [$_owner xml get $path.about.hints]
85    if {[string length $hints] > 0} {
86        itk_component add hints {
87            ::label $itk_interior.hints -anchor w -text $hints
88        } {
89            usual
90            rename -foreground -hintforeground hintForeground Foreground
91            rename -font -hintfont hintFont Font
92        }
93        pack $itk_component(hints) -side bottom -fill x
94    }
95
96    eval itk_initialize $args
97
98    set str [$_owner xml get $path.default]
99    if {"" != $str} {
100        _layout  ;# must fix layout or value won't take
101        value $str
102    }
103}
104
105# ----------------------------------------------------------------------
106# USAGE: value ?-check? ?<newval>?
107#
108# Clients use this to query/set the value for this widget.  With
109# no args, it returns the current value for the widget.  If the
110# <newval> is specified, it sets the value of the widget and
111# sends a <<Value>> event.  If the -check flag is included, the
112# new value is not actually applied, but just checked for correctness.
113# ----------------------------------------------------------------------
114itcl::body Rappture::TextEntry::value {args} {
115    set onlycheck 0
116    set i [lsearch -exact $args -check]
117    if {$i >= 0} {
118        set onlycheck 1
119        set args [lreplace $args $i $i]
120    }
121
122    if {[llength $args] == 1} {
123        if {$onlycheck} {
124            # someday we may add validation...
125            return
126        }
127        set newval [lindex $args 0]
128        _setValue $newval
129
130        $_dispatcher event -idle !layout
131        event generate $itk_component(hull) <<Value>>
132        return $newval
133
134    } elseif {[llength $args] != 0} {
135        error "wrong # args: should be \"value ?-check? ?newval?\""
136    }
137
138    #
139    # Query the value and return.
140    #
141    if {$_mode == "ascii"} {
142        if {$_layout == "entry"} {
143            return [$itk_component(entry) get]
144        } elseif {$_layout == "text"} {
145            return [$itk_component(text) get 1.0 end-1char]
146        }
147    } else {
148        return $_value
149    }
150    return ""
151}
152
153# ----------------------------------------------------------------------
154# USAGE: label
155#
156# Clients use this to query the label associated with this widget.
157# Reaches into the XML and pulls out the appropriate label string.
158# ----------------------------------------------------------------------
159itcl::body Rappture::TextEntry::label {} {
160    set label [$_owner xml get $_path.about.label]
161    if {"" == $label} {
162        set label "String"
163    }
164    return $label
165}
166
167# ----------------------------------------------------------------------
168# USAGE: tooltip
169#
170# Clients use this to query the tooltip associated with this widget.
171# Reaches into the XML and pulls out the appropriate description
172# string.  Returns the string that should be used with the
173# Rappture::Tooltip facility.
174# ----------------------------------------------------------------------
175itcl::body Rappture::TextEntry::tooltip {} {
176    set str [$_owner xml get $_path.about.description]
177    return [string trim $str]
178}
179
180# ----------------------------------------------------------------------
181# USAGE: _layout
182#
183# Used internally to change the layout of this widget depending
184# on the .size hint and its contents.  Switches between an entry
185# and a text widget.
186# ----------------------------------------------------------------------
187itcl::body Rappture::TextEntry::_layout {} {
188    set size $_size
189    if {$size == "" || $size == "auto"} {
190        #
191        # If the size is "auto", then look at the current value
192        # and count its lines/characters.
193        #
194        set val ""
195        if {$_layout == "entry"} {
196            set val [$itk_component(entry) get]
197        } elseif {$_layout == "text"} {
198            set val [$itk_component(text) get 1.0 end-1char]
199        }
200
201        set chars 0
202        set lines 0
203        foreach line [split $val \n] {
204            incr lines
205            if {[string length $line] > $chars} {
206                set chars [string length $line]
207            }
208        }
209        incr chars
210
211        if {$lines > 1} {
212            set size "${chars}x${lines}"
213        } else {
214            set size $chars
215        }
216    }
217
218    if {[regexp {^[0-9]+$} $size]} {
219        #
220        # If the size is WW, then flip to entry mode, with
221        # a requested size of WW characters.
222        #
223        if {$_layout != "entry"} {
224            set val ""
225            if {$_layout == "text"} {
226                set val [$itk_component(text) get 1.0 end-1char]
227                destroy $itk_component(text)
228                destroy $itk_component(scrollbars)
229            }
230
231            itk_component add entry {
232                entry $itk_interior.entry
233            } {
234                usual
235                rename -background -textbackground textBackground Background
236                rename -foreground -textforeground textForeground Foreground
237            }
238            pack $itk_component(entry) -expand yes -fill both
239            $itk_component(entry) configure \
240                -background $itk_option(-textbackground) \
241                -foreground $itk_option(-textforeground)
242
243            bind $itk_component(entry) <KeyPress> [itcl::code $this _newValue]
244            bind $itk_component(entry) <Control-KeyPress-a> \
245                "[list $itk_component(entry) selection range 0 end]; break"
246
247            itk_component add emenu {
248                menu $itk_component(entry).menu -tearoff 0
249            }
250            $itk_component(emenu) add command -label "Cut" -accelerator "^X" \
251                -command [list event generate $itk_component(entry) <<Cut>>]
252            $itk_component(emenu) add command -label "Copy" -accelerator "^C" \
253                -command [list event generate $itk_component(entry) <<Copy>>]
254            $itk_component(emenu) add command -label "Paste" -accelerator "^V" \
255                -command [list event generate $itk_component(entry) <<Paste>>]
256            $itk_component(emenu) add command -label "Select All" -accelerator "^A" -command [list $itk_component(entry) selection range 0 end]
257            bind $itk_component(entry) <<PopupMenu>> \
258                [itcl::code $this _edit menu emenu %X %Y]
259
260            set _layout "entry"
261            _setValue $val
262        }
263        $itk_component(entry) configure -width $size
264
265    } elseif {[regexp {^([0-9]+)x([0-9]+)$} $size match w h]} {
266        #
267        # If the size is WWxHH, then flip to text mode, with
268        # a requested size of HH lines by WW characters.
269        #
270        if {$_layout != "text"} {
271            set val ""
272            if {$_layout == "entry"} {
273                set val [$itk_component(entry) get]
274                destroy $itk_component(entry)
275            }
276
277            itk_component add scrollbars {
278                Rappture::Scroller $itk_interior.scrl \
279                     -xscrollmode auto -yscrollmode auto
280            }
281            pack $itk_component(scrollbars) -expand yes -fill both
282
283            itk_component add text {
284                text $itk_component(scrollbars).text \
285                    -width 1 -height 1 -wrap char
286            } {
287                usual
288                rename -background -textbackground textBackground Background
289                rename -foreground -textforeground textForeground Foreground
290                rename -font -codefont codeFont CodeFont
291            }
292            $itk_component(text) configure \
293                -background $itk_option(-textbackground) \
294                -foreground $itk_option(-textforeground) \
295                -font $itk_option(-codefont)
296            $itk_component(scrollbars) contents $itk_component(text)
297
298            bind $itk_component(text) <KeyPress> [itcl::code $this _newValue]
299            bind $itk_component(text) <Control-KeyPress-a> \
300                "[list $itk_component(text) tag add sel 1.0 end]; break"
301
302            itk_component add tmenu {
303                menu $itk_component(text).menu -tearoff 0
304            }
305            $itk_component(tmenu) add command -label "Cut" -accelerator "^X" \
306                -command [list event generate $itk_component(text) <<Cut>>]
307            $itk_component(tmenu) add command -label "Copy" -accelerator "^C" \
308                -command [list event generate $itk_component(text) <<Copy>>]
309            $itk_component(tmenu) add command -label "Paste" -accelerator "^V" \
310                -command [list event generate $itk_component(text) <<Paste>>]
311            $itk_component(tmenu) add command -label "Select All" -accelerator "^A" -command [list $itk_component(text) tag add sel 1.0 end]
312            $itk_component(tmenu) add separator
313            $itk_component(tmenu) add command -label "Upload..." \
314                -command [itcl::code $this _uploadValue -start]
315            $itk_component(tmenu) add command -label "Download" \
316                -command [itcl::code $this _downloadValue]
317            bind $itk_component(text) <<PopupMenu>> \
318                [itcl::code $this _edit menu tmenu %X %Y]
319
320            set _layout "text"
321            _setValue $val
322        }
323        $itk_component(text) configure -width $w -height $h
324    }
325
326    #
327    # Fix the overall widget size according to -width / -height
328    #
329    if {$itk_option(-width) == 0 && $itk_option(-height) == 0} {
330        pack propagate $itk_component(hull) yes
331    } else {
332        pack propagate $itk_component(hull) no
333        component hull configure \
334            -width $itk_option(-width) -height $itk_option(-width)
335    }
336}
337
338# ----------------------------------------------------------------------
339# USAGE: _setValue <newValue>
340#
341# Used internally to set the value for this widget.  If the <newValue>
342# string is ASCII, then it is stored directly and the widget is enabled
343# for editing.  Otherwise, the value is cached and a representation of
344# the data is displayed.
345# ----------------------------------------------------------------------
346itcl::body Rappture::TextEntry::_setValue {newval} {
347    if {[Rappture::encoding::is binary $newval]} {
348        # looks like a binary file
349        set _mode "binary"
350        set _value $newval
351
352        if {$_layout == "entry" || [string match {*x[01]} $_size]} {
353            set newval [Rappture::utils::hexdump -lines 0 $_value]
354        } else {
355            set newval [Rappture::utils::hexdump -lines 1000 $_value]
356        }
357    } else {
358        # ascii file -- map carriage returns to line feeds
359        set _mode "ascii"
360        set _value ""
361        regsub -all "\r\n" $newval "\n" newval
362        regsub -all "\r" $newval "\n" newval
363    }
364
365    if {$_layout == "entry"} {
366        $itk_component(entry) configure -state normal
367        $itk_component(emenu) entryconfigure "Cut" -state normal
368        $itk_component(emenu) entryconfigure "Paste" -state normal
369        $itk_component(entry) delete 0 end
370        $itk_component(entry) insert 0 $newval
371        if {!$itk_option(-editable) || $_mode == "binary"} {
372            $itk_component(entry) configure -state disabled
373            $itk_component(emenu) entryconfigure "Cut" -state disabled
374            $itk_component(emenu) entryconfigure "Paste" -state disabled
375        }
376    } elseif {$_layout == "text"} {
377        $itk_component(text) configure -state normal
378        $itk_component(tmenu) entryconfigure "Cut" -state normal
379        $itk_component(tmenu) entryconfigure "Paste" -state normal
380        $itk_component(text) delete 1.0 end
381        $itk_component(text) insert end $newval
382        if {!$itk_option(-editable) || $_mode == "binary"} {
383            set hull $itk_component(hull)
384            set dfg [option get $hull disabledForeground Foreground]
385            set dbg [option get $hull disabledBackground Background]
386            $itk_component(text) configure -state disabled \
387                -background $dbg -foreground $dfg
388            $itk_component(tmenu) entryconfigure "Cut" -state disabled
389            $itk_component(tmenu) entryconfigure "Paste" -state disabled
390        } else {
391            $itk_component(text) configure \
392                -background $itk_option(-textbackground) \
393                -foreground $itk_option(-textforeground)
394        }
395    }
396}
397
398# ----------------------------------------------------------------------
399# USAGE: _newValue
400#
401# Invoked automatically whenever the value in the entry changes.
402# Sends a <<Value>> event to notify clients of the change.
403# ----------------------------------------------------------------------
404itcl::body Rappture::TextEntry::_newValue {} {
405    event generate $itk_component(hull) <<Value>>
406}
407
408# ----------------------------------------------------------------------
409# USAGE: _edit menu <which> <X> <Y>
410#
411# Used internally to manage edit operations.
412# ----------------------------------------------------------------------
413itcl::body Rappture::TextEntry::_edit {option args} {
414    if {$itk_option(-state) == "disabled"} {
415        return  ;# disabled? then bail out here!
416    }
417    switch -- $option {
418        menu {
419            if {[llength $args] != 3} {
420                error "wrong # args: should be \"_edit $option which x y\""
421            }
422            set mname [lindex $args 0]
423            set x [lindex $args 1]
424            set y [lindex $args 2]
425            tk_popup $itk_component($mname) $x $y
426        }
427        default {
428            error "bad option \"$option\": should be menu"
429        }
430    }
431}
432
433# ----------------------------------------------------------------------
434# USAGE: _fixState
435#
436# Used internally to update the internal widgets whenever the
437# -state/-editable options change.  Enables or disables various
438# widgets.
439# ----------------------------------------------------------------------
440itcl::body Rappture::TextEntry::_fixState {} {
441    if {$itk_option(-editable) && $itk_option(-state) == "normal"} {
442        set state normal
443    } else {
444        set state disabled
445    }
446    if {$_layout == "entry"} {
447        $itk_component(entry) configure -state $state
448        $itk_component(emenu) entryconfigure "Cut" -state $state
449        $itk_component(emenu) entryconfigure "Copy" -state $state
450        $itk_component(emenu) entryconfigure "Paste" -state $state
451    } elseif {$_layout == "text"} {
452        $itk_component(text) configure -state $state
453        $itk_component(tmenu) entryconfigure "Cut" -state $state
454        $itk_component(tmenu) entryconfigure "Copy" -state $state
455        $itk_component(tmenu) entryconfigure "Paste" -state $state
456    }
457}
458
459# ----------------------------------------------------------------------
460# USAGE: _uploadValue -start
461# USAGE: _uploadValue -assign <key> <value> <key> <value> ...
462#
463# Used internally to initiate an upload operation.  Prompts the
464# user to upload into the text area of this widget.
465# ----------------------------------------------------------------------
466itcl::body Rappture::TextEntry::_uploadValue {args} {
467    switch -- $_layout {
468        entry   { set widget $itk_component(entry) }
469        text    { set widget $itk_component(text) }
470        default { set widget $itk_component(hull) }
471    }
472
473    set opt [lindex $args 0]
474    switch -- $opt {
475        -start {
476            set tool [Rappture::Tool::resources -appname]
477            set cntls [list $_path [label] [tooltip]]
478            Rappture::filexfer::upload \
479                $tool $cntls [itcl::code $this _uploadValue -assign]
480        }
481        -assign {
482            array set data [lrange $args 1 end] ;# skip option
483            if {[info exists data(error)]} {
484                Rappture::Tooltip::cue $widget $data(error)
485            }
486            if {[info exists data(data)]} {
487                Rappture::Tooltip::cue hide  ;# take down note about the popup
488                _setValue $data(data)
489                _newValue
490            }
491        }
492        default {
493            error "bad option \"$opt\": should be -start or -assign"
494        }
495    }
496}
497
498# ----------------------------------------------------------------------
499# USAGE: _downloadValue
500#
501# Used internally to initiate a download operation.  Takes the current
502# value and downloads it to the user in a new browser window.
503# ----------------------------------------------------------------------
504itcl::body Rappture::TextEntry::_downloadValue {} {
505    set mesg [Rappture::filexfer::download [value] input.txt]
506
507    if {"" != $mesg} {
508        switch -- $_layout {
509            entry   { set widget $itk_component(entry) }
510            text    { set widget $itk_component(text) }
511            default { set widget $itk_component(hull) }
512        }
513        Rappture::Tooltip::cue $widget $mesg
514    }
515}
516
517# ----------------------------------------------------------------------
518# CONFIGURATION OPTION: -editable
519# ----------------------------------------------------------------------
520itcl::configbody Rappture::TextEntry::editable {
521    if {![string is boolean -strict $itk_option(-editable)]} {
522        error "bad value \"$itk_option(-editable)\": should be boolean"
523    }
524    _fixState
525}
526
527# ----------------------------------------------------------------------
528# CONFIGURATION OPTION: -state
529# ----------------------------------------------------------------------
530itcl::configbody Rappture::TextEntry::state {
531    set valid {normal disabled}
532    if {[lsearch -exact $valid $itk_option(-state)] < 0} {
533        error "bad value \"$itk_option(-state)\": should be [join $valid {, }]"
534    }
535    if {$_layout == "text"} {
536        if {$itk_option(-state) == "disabled"} {
537            set fg [option get $itk_component(text) disabledForeground Foreground]
538        } else {
539            set fg $itk_option(-foreground)
540        }
541        $itk_component(text) configure -foreground $fg
542    }
543    _fixState
544}
545
546# ----------------------------------------------------------------------
547# CONFIGURATION OPTION: -width
548# ----------------------------------------------------------------------
549itcl::configbody Rappture::TextEntry::width {
550    # check size to see if it has the proper form
551    winfo pixels $itk_component(hull) $itk_option(-width)
552    $_dispatcher event -idle !layout
553}
554
555# ----------------------------------------------------------------------
556# CONFIGURATION OPTION: -height
557# ----------------------------------------------------------------------
558itcl::configbody Rappture::TextEntry::height {
559    # check size to see if it has the proper form
560    winfo pixels $itk_component(hull) $itk_option(-height)
561    $_dispatcher event -idle !layout
562}
Note: See TracBrowser for help on using the repository browser.