Context Navigation

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

Last change on this file since 3513 was 3513, checked in by gah, 11 years ago
Add string trim to select 'xml get' calls
File size: 24.6 KB

Line
1	# -- mode: tcl; indent-tabs-mode: nil --
2	# ----------------------------------------------------------------------
3	# COMPONENT: textentry - general-purpose text entry widget
4	#
5	# This widget is a cross between the Tk entry and text widgets. For
6	# one-line messages, it acts like an entry widget. For larger
7	# messages, it morphs into a text widget.
8	# ======================================================================
9	# AUTHOR: Michael McLennan, Purdue University
10	# Copyright (c) 2004-2012 HUBzero Foundation, LLC
11	#
12	# See the file "license.terms" for information on usage and
13	# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
14	# ======================================================================
15	package require Itk
16
17	option add *TextEntry.size auto widgetDefault
18	option add *TextEntry.width 0 widgetDefault
19	option add *TextEntry.height 0 widgetDefault
20	option add *TextEntry.textBackground white widgetDefault
21	option add TextEntrydisabledForeground #a3a3a3 widgetDefault
22	option add TextEntrydisabledBackground white widgetDefault
23
24	option add *TextEntry.hintForeground gray50 widgetDefault
25	option add *TextEntry.hintFont \
26	--helvetica-medium-r-normal--10-* widgetDefault
27	option add *TextEntry.codeFont \
28	--courier-medium-r-normal--12-* widgetDefault
29
30
31	itcl::class Rappture::TextEntry {
32	inherit itk::Widget
33
34	itk_option define -state state State "normal"
35	itk_option define -disabledforeground disabledForeground DisabledForeground ""
36	itk_option define -disabledbackground disabledBackground DisabledBackground ""
37	itk_option define -width width Width 0
38	itk_option define -height height Height 0
39
40	constructor {owner path args} {
41	# defined below
42	}
43
44	public method value {args}
45
46	public method label {}
47	public method tooltip {}
48	public method size {} { return $_size }
49
50	protected method _layout {}
51	protected method _setValue {value}
52	protected method _newValue {}
53	protected method _edit {option args}
54	protected method _uploadValue {args}
55	protected method _downloadValue {}
56
57	private variable _dispatcher "" ;# dispatcher for !events
58	private variable _owner "" ;# thing managing this control
59	private variable _path "" ;# path in XML to this number
60
61	private variable _layout "" ;# entry or full text size
62	private variable _value "" ;# value inside the widget
63	private variable _size "" ;# size hint from XML
64	private variable _icon "" ;# size hint from XML
65	}
66
67	itk::usual TextEntry {
68	keep -foreground -background -textbackground -font -cursor
69	}
70
71	# ----------------------------------------------------------------------
72	# CONSTRUCTOR
73	# ----------------------------------------------------------------------
74	itcl::body Rappture::TextEntry::constructor {owner path args} {
75	if {[catch {$owner isa Rappture::ControlOwner} valid] != 0 \|\| !$valid} {
76	error "bad object \"$owner\": should be Rappture::ControlOwner"
77	}
78	set _owner $owner
79	set _path $path
80
81	Rappture::dispatcher _dispatcher
82	$_dispatcher register !layout
83	$_dispatcher dispatch $this !layout "[itcl::code $this _layout]; list"
84
85	set _size [string trim [$_owner xml get $path.size]]
86
87	set hints [string trim [$_owner xml get $path.about.hints]]
88	set icon [string trim [$_owner xml get $path.about.icon]]
89	if {[string length $icon] > 0} {
90	set _icon [image create photo -data $icon]
91	}
92	if {[string length $hints] > 0} {
93	itk_component add hints {
94	::label $itk_interior.hints -anchor w -text $hints
95	} {
96	usual
97	rename -foreground -hintforeground hintForeground Foreground
98	rename -font -hintfont hintFont Font
99	}
100	pack $itk_component(hints) -side bottom -fill x
101	}
102
103	eval itk_initialize $args
104
105	# Don't trim the text default value. Assume that any leading/trailing
106	# whitespace is wanted.
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	# ----------------------------------------------------------------------
122	itcl::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	# ----------------------------------------------------------------------
166	itcl::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	# ----------------------------------------------------------------------
182	itcl::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	# ----------------------------------------------------------------------
194	itcl::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-$this <KeyPress> \
264	[itcl::code $this _newValue]
265	bind textentry-$this <Control-KeyPress-a> \
266	"[list $itk_component(entry) selection range 0 end]; break"
267	bind textentry-$this <FocusOut> \
268	[itcl::code $this _edit log]
269	set bindtags [bindtags $itk_component(entry)]
270	lappend bindtags textentry-$this
271	bindtags $itk_component(entry) $bindtags
272
273	itk_component add emenu {
274	menu $itk_component(entry).menu -tearoff 0
275	}
276	$itk_component(emenu) add command \
277	-label "Cut" -accelerator "^X" \
278	-command [itcl::code $this _edit action entry cut]
279	$itk_component(emenu) add command \
280	-label "Copy" -accelerator "^C" \
281	-command [itcl::code $this _edit action entry copy]
282	$itk_component(emenu) add command \
283	-label "Paste" -accelerator "^V" \
284	-command [itcl::code $this _edit action entry paste]
285	$itk_component(emenu) add command \
286	-label "Select All" -accelerator "^A" \
287	-command [itcl::code $this _edit action entry selectall]
288	bind $itk_component(entry) <<PopupMenu>> \
289	[itcl::code $this _edit menu emenu %X %Y]
290	}
291
292	# show the entry widget
293	pack $itk_component(entry) -expand yes -fill both
294
295	# load any previous value
296	regsub -all "\n" $oldval "" oldval
297	$itk_component(entry) delete 0 end
298	$itk_component(entry) insert end $oldval
299	}
300
301	text {
302	if {![winfo exists $itk_interior.scrl]} {
303	itk_component add scrollbars {
304	Rappture::Scroller $itk_interior.scrl \
305	-xscrollmode auto -yscrollmode auto
306	}
307
308	itk_component add text {
309	text $itk_component(scrollbars).text \
310	-width 1 -height 1 -wrap char
311	} {
312	usual
313	rename -background -textbackground textBackground Background
314	rename -foreground -textforeground textForeground Foreground
315	rename -font -codefont codeFont CodeFont
316	}
317	$itk_component(text) configure \
318	-background $itk_option(-textbackground) \
319	-foreground $itk_option(-textforeground) \
320	-font $itk_option(-codefont)
321	$itk_component(scrollbars) contents $itk_component(text)
322
323	# Make sure these event bindings occur after the class bindings.
324	# Otherwise you'll always get the text value before the edit.
325	bind textentry-$this <KeyPress> \
326	[itcl::code $this _newValue]
327	bind textentry-$this <Control-KeyPress-a> \
328	"[list $itk_component(text) tag add sel 1.0 end]; break"
329	bind textentry-$this <FocusOut> \
330	[itcl::code $this _edit log]
331	set bindtags [bindtags $itk_component(text)]
332	lappend bindtags textentry-$this
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 [itcl::code $this _edit action text cut]
341	$itk_component(tmenu) add command \
342	-label "Copy" -accelerator "^C" \
343	-command [itcl::code $this _edit action text copy]
344	$itk_component(tmenu) add command \
345	-label "Paste" -accelerator "^V" \
346	-command [itcl::code $this _edit action text paste]
347	$itk_component(tmenu) add command \
348	-label "Select All" -accelerator "^A" \
349	-command [itcl::code $this _edit action text selectall]
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	# ----------------------------------------------------------------------
441	itcl::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	# ----------------------------------------------------------------------
482	itcl::body Rappture::TextEntry::_newValue {} {
483	event generate $itk_component(hull) <<Value>>
484	}
485
486	# ----------------------------------------------------------------------
487	# USAGE: _edit action <which> <action>
488	# USAGE: _edit menu <which> <X> <Y>
489	# USAGE: _edit log
490	#
491	# Used internally to manage edit operations.
492	# ----------------------------------------------------------------------
493	itcl::body Rappture::TextEntry::_edit {option args} {
494	puts "_edit $option $args"
495	if {$itk_option(-state) == "disabled"} {
496	return ;# disabled? then bail out here!
497	}
498	switch -- $option {
499	action {
500	if {[llength $args] != 2} {
501	error "wrong # args: should be \"_edit $option which action\""
502	}
503	set widget [lindex $args 0]
504	set action [lindex $args 1]
505	switch -- $action {
506	cut - copy - paste {
507	set event "<<[string totitle $action]>>"
508	event generate $itk_component($widget) $event
509	}
510	selectall {
511	switch -- $widget {
512	entry { $itk_component(entry) selection range 0 end }
513	text { $itk_component(text) tag add sel 1.0 end }
514	default { error "don't know how to select for $widget" }
515	}
516	}
517	default {
518	error "don't know how to handle action $action"
519	}
520	}
521	Rappture::Logger::log input $_path -action $action
522	}
523	menu {
524	if {[llength $args] != 3} {
525	error "wrong # args: should be \"_edit $option which x y\""
526	}
527	set mname [lindex $args 0]
528	set x [lindex $args 1]
529	set y [lindex $args 2]
530	tk_popup $itk_component($mname) $x $y
531	}
532	log {
533	set newval [value]
534	if {$newval ne $_value} {
535	Rappture::Logger::log input $_path $newval
536	set _value $newval
537	}
538	}
539	default {
540	error "bad option \"$option\": should be action, menu, log"
541	}
542	}
543	}
544
545	# ----------------------------------------------------------------------
546	# USAGE: _uploadValue -start
547	# USAGE: _uploadValue -assign <key> <value> <key> <value> ...
548	#
549	# Used internally to initiate an upload operation. Prompts the
550	# user to upload into the text area of this widget.
551	# ----------------------------------------------------------------------
552	itcl::body Rappture::TextEntry::_uploadValue {args} {
553	switch -- $_layout {
554	entry { set widget $itk_component(entry) }
555	text { set widget $itk_component(text) }
556	default { set widget $itk_component(hull) }
557	}
558
559	set opt [lindex $args 0]
560	switch -- $opt {
561	-start {
562	set tool [Rappture::Tool::resources -appname]
563	set cntls [list $_path [label] [tooltip]]
564	Rappture::filexfer::upload \
565	$tool $cntls [itcl::code $this _uploadValue -assign]
566	}
567	-assign {
568	array set data [lrange $args 1 end] ;# skip option
569	if {[info exists data(error)]} {
570	Rappture::Tooltip::cue $widget $data(error)
571	Rappture::Logger::log warning $_path $data(error)
572	}
573	if {[info exists data(data)]} {
574	Rappture::Tooltip::cue hide ;# take down note about the popup
575	_setValue $data(data)
576	_newValue
577	Rappture::Logger::log upload $_path $data(data)
578	}
579	}
580	default {
581	error "bad option \"$opt\": should be -start or -assign"
582	}
583	}
584	}
585
586	# ----------------------------------------------------------------------
587	# USAGE: _downloadValue
588	#
589	# Used internally to initiate a download operation. Takes the current
590	# value and downloads it to the user in a new browser window.
591	# ----------------------------------------------------------------------
592	itcl::body Rappture::TextEntry::_downloadValue {} {
593	set mesg [Rappture::filexfer::download [value] input.txt]
594
595	if {$mesg ne ""} {
596	switch -- $_layout {
597	entry { set widget $itk_component(entry) }
598	text { set widget $itk_component(text) }
599	default { set widget $itk_component(hull) }
600	}
601	Rappture::Tooltip::cue $widget $mesg
602	Rappture::Logger::log warning $_path $mesg
603	} else {
604	Rappture::Logger::log download $_path
605	}
606	}
607
608	# ----------------------------------------------------------------------
609	# CONFIGURATION OPTION: -state
610	# ----------------------------------------------------------------------
611	itcl::configbody Rappture::TextEntry::state {
612	set valid {normal disabled}
613	if {[lsearch -exact $valid $itk_option(-state)] < 0} {
614	error "bad value \"$itk_option(-state)\": should be [join $valid {, }]"
615	}
616	if {[info exists itk_component(text)]} {
617	$itk_component(text) configure -state $itk_option(-state)
618	$itk_component(tmenu) entryconfigure "Cut" -state $itk_option(-state)
619	$itk_component(tmenu) entryconfigure "Copy" -state $itk_option(-state)
620	$itk_component(tmenu) entryconfigure "Paste" -state $itk_option(-state)
621	if {$itk_option(-state) == "disabled"} {
622	$itk_component(text) configure \
623	-foreground $itk_option(-disabledforeground) \
624	-background $itk_option(-disabledbackground)
625	} else {
626	$itk_component(text) configure \
627	-foreground $itk_option(-foreground) \
628	-background $itk_option(-textbackground)
629	}
630	}
631	if {[info exists itk_component(entry)]} {
632	$itk_component(entry) configure -state $itk_option(-state)
633	$itk_component(emenu) entryconfigure "Cut" -state $itk_option(-state)
634	$itk_component(emenu) entryconfigure "Copy" -state $itk_option(-state)
635	$itk_component(emenu) entryconfigure "Paste" -state $itk_option(-state)
636	}
637	}
638
639	# ----------------------------------------------------------------------
640	# CONFIGURATION OPTION: -width
641	# ----------------------------------------------------------------------
642	itcl::configbody Rappture::TextEntry::width {
643	# check size to see if it has the proper form
644	winfo pixels $itk_component(hull) $itk_option(-width)
645	$_dispatcher event -idle !layout
646	}
647
648	# ----------------------------------------------------------------------
649	# CONFIGURATION OPTION: -height
650	# ----------------------------------------------------------------------
651	itcl::configbody Rappture::TextEntry::height {
652	# check size to see if it has the proper form
653	winfo pixels $itk_component(hull) $itk_option(-height)
654	$_dispatcher event -idle !layout
655	}
656
657

Note: See TracBrowser for help on using the repository browser.

Download in other formats: