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

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

Fixed all fonts to set pixelsize instead of pointsize, so that fonts in
the latest X distribution look right.

Added initial Rappture::bugreport::submit command for submitting bug
reports to nanoHUB.org. This isn't tied in yet, but it's a start.
File size: 22.5 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        set size [string length $newval]
353        foreach {factor units} {
354            1073741824 GB
355            1048576 MB
356            1024 kB
357            1 bytes
358        } {
359            if {$size/$factor > 0} {
360                if {$factor > 1} {
361                    set size [format "%.2f" [expr {double($size)/$factor}]]
362                }
363                break
364            }
365        }
366
367        if {$_layout == "entry" || [string match {*x[01]} $_size]} {
368            set newval "<binary> $size $units"
369        } else {
370            set newval "<binary> $size $units\n\n"
371            set tail ""
372            set len [string length $_value]
373            if {$len > 1600} {
374                set len 1600
375                set tail "...more..."
376            }
377
378            for {set i 0} {$i < $len} {incr i 8} {
379                append newval [format "%#06x: " $i]
380                set ascii ""
381                for {set j 0} {$j < 8} {incr j} {
382                    if {$i+$j < $len} {
383                        set char [string index $_value [expr {$i+$j}]]
384                        binary scan $char c ichar
385                        set hexchar [format "%02x" [expr {0xff & $ichar}]]
386                    } else {
387                        set char " "
388                        set hexchar "  "
389                    }
390                    append newval "$hexchar "
391                    if {[regexp {[\000-\037\177-\377]} $char]} {
392                        append ascii "."
393                    } else {
394                        append ascii $char
395                    }
396                }
397                append newval " | $ascii\n"
398            }
399            append newval $tail
400        }
401
402        set _value [Rappture::encoding::encode -as z $_value]
403
404    } else {
405        # ascii file -- map carriage returns to line feeds
406        set _mode "ascii"
407        set _value ""
408        regsub -all "\r" $newval "\n" newval
409    }
410
411    if {$_layout == "entry"} {
412        $itk_component(entry) configure -state normal
413        $itk_component(emenu) entryconfigure "Cut" -state normal
414        $itk_component(emenu) entryconfigure "Paste" -state normal
415        $itk_component(entry) delete 0 end
416        $itk_component(entry) insert 0 $newval
417        if {!$itk_option(-editable) || $_mode == "binary"} {
418            $itk_component(entry) configure -state disabled
419            $itk_component(emenu) entryconfigure "Cut" -state disabled
420            $itk_component(emenu) entryconfigure "Paste" -state disabled
421        }
422    } elseif {$_layout == "text"} {
423        $itk_component(text) configure -state normal
424        $itk_component(tmenu) entryconfigure "Cut" -state normal
425        $itk_component(tmenu) entryconfigure "Paste" -state normal
426        $itk_component(text) delete 1.0 end
427        $itk_component(text) insert end $newval
428        if {!$itk_option(-editable) || $_mode == "binary"} {
429            set hull $itk_component(hull)
430            set dfg [option get $hull disabledForeground Foreground]
431            set dbg [option get $hull disabledBackground Background]
432            $itk_component(text) configure -state disabled \
433                -background $dbg -foreground $dfg
434            $itk_component(tmenu) entryconfigure "Cut" -state disabled
435            $itk_component(tmenu) entryconfigure "Paste" -state disabled
436        } else {
437            $itk_component(text) configure \
438                -background $itk_option(-textbackground) \
439                -foreground $itk_option(-textforeground)
440        }
441    }
442}
443
444# ----------------------------------------------------------------------
445# USAGE: _newValue
446#
447# Invoked automatically whenever the value in the entry changes.
448# Sends a <<Value>> event to notify clients of the change.
449# ----------------------------------------------------------------------
450itcl::body Rappture::TextEntry::_newValue {} {
451    event generate $itk_component(hull) <<Value>>
452}
453
454# ----------------------------------------------------------------------
455# USAGE: _edit menu <which> <X> <Y>
456#
457# Used internally to manage edit operations.
458# ----------------------------------------------------------------------
459itcl::body Rappture::TextEntry::_edit {option args} {
460    if {$itk_option(-state) == "disabled"} {
461        return  ;# disabled? then bail out here!
462    }
463    switch -- $option {
464        menu {
465            if {[llength $args] != 3} {
466                error "wrong # args: should be \"_edit $option which x y\""
467            }
468            set mname [lindex $args 0]
469            set x [lindex $args 1]
470            set y [lindex $args 2]
471            tk_popup $itk_component($mname) $x $y
472        }
473        default {
474            error "bad option \"$option\": should be menu"
475        }
476    }
477}
478
479# ----------------------------------------------------------------------
480# USAGE: _fixState
481#
482# Used internally to update the internal widgets whenever the
483# -state/-editable options change.  Enables or disables various
484# widgets.
485# ----------------------------------------------------------------------
486itcl::body Rappture::TextEntry::_fixState {} {
487    if {$itk_option(-editable) && $itk_option(-state) == "normal"} {
488        set state normal
489    } else {
490        set state disabled
491    }
492    if {$_layout == "entry"} {
493        $itk_component(entry) configure -state $state
494        $itk_component(emenu) entryconfigure "Cut" -state $state
495        $itk_component(emenu) entryconfigure "Copy" -state $state
496        $itk_component(emenu) entryconfigure "Paste" -state $state
497    } elseif {$_layout == "text"} {
498        $itk_component(text) configure -state $state
499        $itk_component(tmenu) entryconfigure "Cut" -state $state
500        $itk_component(tmenu) entryconfigure "Copy" -state $state
501        $itk_component(tmenu) entryconfigure "Paste" -state $state
502    }
503}
504
505# ----------------------------------------------------------------------
506# USAGE: _uploadValue -start
507# USAGE: _uploadValue -assign <key> <value> <key> <value> ...
508#
509# Used internally to initiate an upload operation.  Prompts the
510# user to upload into the text area of this widget.
511# ----------------------------------------------------------------------
512itcl::body Rappture::TextEntry::_uploadValue {args} {
513    switch -- $_layout {
514        entry   { set widget $itk_component(entry) }
515        text    { set widget $itk_component(text) }
516        default { set widget $itk_component(hull) }
517    }
518
519    set opt [lindex $args 0]
520    switch -- $opt {
521        -start {
522            set tool [[$_owner tool] get -name]
523            set cntls [list $_path [label] [tooltip]]
524            set mesg [Rappture::filexfer::upload \
525                $tool $cntls [itcl::code $this _uploadValue -assign]]
526
527            if {"" != $mesg} {
528                Rappture::Tooltip::cue $widget $mesg
529            }
530        }
531        -assign {
532            array set data [lrange $args 2 end] ;# skip option and path
533            if {[info exists data(error)]} {
534                Rappture::Tooltip::cue $widget $data(error)
535            }
536            if {[info exists data(data)]} {
537                Rappture::Tooltip::cue hide  ;# take down note about the popup
538                _setValue $data(data)
539            }
540        }
541        default {
542            error "bad option \"$opt\": should be -start or -assign"
543        }
544    }
545}
546
547# ----------------------------------------------------------------------
548# USAGE: _downloadValue
549#
550# Used internally to initiate a download operation.  Takes the current
551# value and downloads it to the user in a new browser window.
552# ----------------------------------------------------------------------
553itcl::body Rappture::TextEntry::_downloadValue {} {
554    set mesg [Rappture::filexfer::download [value] input.txt]
555
556    if {"" != $mesg} {
557        switch -- $_layout {
558            entry   { set widget $itk_component(entry) }
559            text    { set widget $itk_component(text) }
560            default { set widget $itk_component(hull) }
561        }
562        Rappture::Tooltip::cue $widget $mesg
563    }
564}
565
566# ----------------------------------------------------------------------
567# CONFIGURATION OPTION: -editable
568# ----------------------------------------------------------------------
569itcl::configbody Rappture::TextEntry::editable {
570    if {![string is boolean -strict $itk_option(-editable)]} {
571        error "bad value \"$itk_option(-editable)\": should be boolean"
572    }
573    _fixState
574}
575
576# ----------------------------------------------------------------------
577# CONFIGURATION OPTION: -state
578# ----------------------------------------------------------------------
579itcl::configbody Rappture::TextEntry::state {
580    set valid {normal disabled}
581    if {[lsearch -exact $valid $itk_option(-state)] < 0} {
582        error "bad value \"$itk_option(-state)\": should be [join $valid {, }]"
583    }
584    if {$_layout == "text"} {
585        if {$itk_option(-state) == "disabled"} {
586            set fg [option get $itk_component(text) disabledForeground Foreground]
587        } else {
588            set fg $itk_option(-foreground)
589        }
590        $itk_component(text) configure -foreground $fg
591    }
592    _fixState
593}
594
595# ----------------------------------------------------------------------
596# CONFIGURATION OPTION: -width
597# ----------------------------------------------------------------------
598itcl::configbody Rappture::TextEntry::width {
599    # check size to see if it has the proper form
600    winfo pixels $itk_component(hull) $itk_option(-width)
601    $_dispatcher event -idle !layout
602}
603
604# ----------------------------------------------------------------------
605# CONFIGURATION OPTION: -height
606# ----------------------------------------------------------------------
607itcl::configbody Rappture::TextEntry::height {
608    # check size to see if it has the proper form
609    winfo pixels $itk_component(hull) $itk_option(-height)
610    $_dispatcher event -idle !layout
611}
Note: See TracBrowser for help on using the repository browser.