source: branches/blt4/gui/scripts/textentry.tcl

Last change on this file was 3158, checked in by gah, 12 years ago

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