Context Navigation

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

Last change on this file since 4094 was 3700, checked in by gah, 11 years ago
add experimental tool parameter handling to strings (textentry)
File size: 25.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	# Trimming for now. May need a <verbatim> flag to indicate to leave
106	# the string alone.
107	set str [string trim [$_owner xml get $path.default]]
108	if { [info exists ::Rappture::parameters($path.default)] } {
109	set fileName $::Rappture::parameters($path.default)
110	catch {
111	set f [open $fileName "r"]
112	set contents [read $f]
113	close $f
114	set str $contents
115	}
116	}
117	if {"" != $str} {
118	value $str
119	}
120	}
121
122	# ----------------------------------------------------------------------
123	# USAGE: value ?-check? ?<newval>?
124	#
125	# Clients use this to query/set the value for this widget. With
126	# no args, it returns the current value for the widget. If the
127	# <newval> is specified, it sets the value of the widget and
128	# sends a <<Value>> event. If the -check flag is included, the
129	# new value is not actually applied, but just checked for correctness.
130	# ----------------------------------------------------------------------
131	itcl::body Rappture::TextEntry::value {args} {
132	set onlycheck 0
133	set i [lsearch -exact $args -check]
134	if {$i >= 0} {
135	set onlycheck 1
136	set args [lreplace $args $i $i]
137	}
138
139	if {[llength $args] == 1} {
140	if {$onlycheck} {
141	# someday we may add validation...
142	return
143	}
144	set newval [string trim [lindex $args 0]]
145	_setValue $newval
146	_newValue
147
148	} elseif {[llength $args] != 0} {
149	error "wrong # args: should be \"value ?-check? ?newval?\""
150	}
151
152	#
153	# Query the value and return.
154	#
155	switch -- $_layout {
156	entry {
157	return [$itk_component(entry) get]
158	}
159	text {
160	return [$itk_component(text) get 1.0 end-1char]
161	}
162	binary {
163	return $_value
164	}
165	}
166	return ""
167	}
168
169	# ----------------------------------------------------------------------
170	# USAGE: label
171	#
172	# Clients use this to query the label associated with this widget.
173	# Reaches into the XML and pulls out the appropriate label string.
174	# ----------------------------------------------------------------------
175	itcl::body Rappture::TextEntry::label {} {
176	set label [string trim [$_owner xml get $_path.about.label]]
177	if {"" == $label} {
178	set label "String"
179	}
180	return $label
181	}
182
183	# ----------------------------------------------------------------------
184	# USAGE: tooltip
185	#
186	# Clients use this to query the tooltip associated with this widget.
187	# Reaches into the XML and pulls out the appropriate description
188	# string. Returns the string that should be used with the
189	# Rappture::Tooltip facility.
190	# ----------------------------------------------------------------------
191	itcl::body Rappture::TextEntry::tooltip {} {
192	set str [string trim [$_owner xml get $_path.about.description]]
193	return $str
194	}
195
196	# ----------------------------------------------------------------------
197	# USAGE: _layout
198	#
199	# Used internally to change the layout of this widget depending
200	# on the .size hint and its contents. Switches between an entry
201	# and a text widget.
202	# ----------------------------------------------------------------------
203	itcl::body Rappture::TextEntry::_layout {} {
204	set size $_size
205	if {$size == "" \|\| $size == "auto"} {
206	#
207	# If the size is "auto", then look at the current value
208	# and count its lines/characters.
209	#
210	if {[string length $_value] > 1920} {
211	# if size is really big, don't bother counting lines
212	set size "80x24"
213	} else {
214	set chars 0
215	set lines 0
216	foreach line [split $_value \n] {
217	incr lines
218	if {[string length $line] > $chars} {
219	set chars [string length $line]
220	}
221	}
222	incr chars
223
224	if {$lines > 1} {
225	set size "${chars}x${lines}"
226	} else {
227	set size $chars
228	}
229	}
230	}
231
232	if {$size == "binary" \|\| [Rappture::encoding::is binary $_value]} {
233	set newlayout "binary"
234	} elseif {[regexp {^[0-9]+$} $size]} {
235	set newlayout "entry"
236	} elseif {[regexp {^([0-9]+)x([0-9]+)$} $size match w h]} {
237	set newlayout "text"
238	}
239
240	if {$newlayout != $_layout} {
241	set oldval ""
242	if {$_layout == "entry"} {
243	set oldval [$itk_component(entry) get]
244	} elseif {$_layout == "text"} {
245	set oldval [$itk_component(text) get 1.0 end-1char]
246	}
247
248	# take down any existing widget
249	foreach win [pack slaves $itk_interior] {
250	if { [winfo name $win] != "hints" } {
251	pack forget $win
252	}
253	}
254
255	switch -- $newlayout {
256	entry {
257	# don't have the entry widget yet? then create it
258	if {![winfo exists $itk_interior.entry]} {
259	itk_component add entry {
260	entry $itk_interior.entry
261	} {
262	usual
263	rename -background -textbackground textBackground Background
264	rename -foreground -textforeground textForeground Foreground
265	}
266	$itk_component(entry) configure \
267	-background $itk_option(-textbackground) \
268	-foreground $itk_option(-textforeground)
269
270	# Make sure these event bindings occur after the class bindings.
271	# Otherwise you'll always get the entry value before the edit.
272	bind textentry-$this <KeyPress> \
273	[itcl::code $this _newValue]
274	bind textentry-$this <KeyPress-Return> \
275	[itcl::code $this _edit finalize]
276	bind textentry-$this <Control-KeyPress-a> \
277	"[list $itk_component(entry) selection range 0 end]; break"
278	bind textentry-$this <FocusOut> \
279	[itcl::code $this _edit finalize]
280	bind textentry-$this <Unmap> \
281	[itcl::code $this _edit finalize]
282	set bindtags [bindtags $itk_component(entry)]
283	lappend bindtags textentry-$this
284	bindtags $itk_component(entry) $bindtags
285
286	itk_component add emenu {
287	menu $itk_component(entry).menu -tearoff 0
288	}
289	$itk_component(emenu) add command \
290	-label "Cut" -accelerator "^X" \
291	-command [itcl::code $this _edit action entry cut]
292	$itk_component(emenu) add command \
293	-label "Copy" -accelerator "^C" \
294	-command [itcl::code $this _edit action entry copy]
295	$itk_component(emenu) add command \
296	-label "Paste" -accelerator "^V" \
297	-command [itcl::code $this _edit action entry paste]
298	$itk_component(emenu) add command \
299	-label "Select All" -accelerator "^A" \
300	-command [itcl::code $this _edit action entry selectall]
301	bind $itk_component(entry) <<PopupMenu>> \
302	[itcl::code $this _edit menu emenu %X %Y]
303	}
304
305	# show the entry widget
306	pack $itk_component(entry) -expand yes -fill both
307
308	# load any previous value
309	regsub -all "\n" $oldval "" oldval
310	$itk_component(entry) delete 0 end
311	$itk_component(entry) insert end $oldval
312	}
313
314	text {
315	if {![winfo exists $itk_interior.scrl]} {
316	itk_component add scrollbars {
317	Rappture::Scroller $itk_interior.scrl \
318	-xscrollmode auto -yscrollmode auto
319	}
320
321	itk_component add text {
322	text $itk_component(scrollbars).text \
323	-width 1 -height 1 -wrap char
324	} {
325	usual
326	ignore -highlightthickness -highlightcolor
327	rename -background -textbackground textBackground Background
328	rename -foreground -textforeground textForeground Foreground
329	rename -font -codefont codeFont CodeFont
330	}
331	$itk_component(text) configure \
332	-background $itk_option(-textbackground) \
333	-foreground $itk_option(-textforeground) \
334	-font $itk_option(-codefont) \
335	-highlightthickness 1
336	$itk_component(scrollbars) contents $itk_component(text)
337
338	# Make sure these event bindings occur after the class bindings.
339	# Otherwise you'll always get the text value before the edit.
340	bind textentry-$this <KeyPress> \
341	[itcl::code $this _newValue]
342	# leave [Return] key alone for multi-line text so the user
343	# can enter newlines and keep editing
344	bind textentry-$this <Control-KeyPress-a> \
345	"[list $itk_component(text) tag add sel 1.0 end]; break"
346	bind textentry-$this <FocusOut> \
347	[itcl::code $this _edit finalize]
348	bind textentry-$this <Unmap> \
349	[itcl::code $this _edit finalize]
350	set bindtags [bindtags $itk_component(text)]
351	lappend bindtags textentry-$this
352	bindtags $itk_component(text) $bindtags
353
354	itk_component add tmenu {
355	menu $itk_component(text).menu -tearoff 0
356	}
357	$itk_component(tmenu) add command \
358	-label "Cut" -accelerator "^X" \
359	-command [itcl::code $this _edit action text cut]
360	$itk_component(tmenu) add command \
361	-label "Copy" -accelerator "^C" \
362	-command [itcl::code $this _edit action text copy]
363	$itk_component(tmenu) add command \
364	-label "Paste" -accelerator "^V" \
365	-command [itcl::code $this _edit action text paste]
366	$itk_component(tmenu) add command \
367	-label "Select All" -accelerator "^A" \
368	-command [itcl::code $this _edit action text selectall]
369	$itk_component(tmenu) add separator
370
371	$itk_component(tmenu) add command \
372	-label [Rappture::filexfer::label upload] \
373	-command [itcl::code $this _uploadValue -start]
374	$itk_component(tmenu) add command \
375	-label [Rappture::filexfer::label download] \
376	-command [itcl::code $this _downloadValue]
377
378	bind $itk_component(text) <<PopupMenu>> \
379	[itcl::code $this _edit menu tmenu %X %Y]
380	}
381
382	# show the text editor widget
383	pack $itk_component(scrollbars) -expand yes -fill both
384	$itk_component(text) configure -width $w -height $h
385
386	# load any previous value
387	$itk_component(text) delete 1.0 end
388	$itk_component(text) insert end $oldval
389	}
390
391	binary {
392	if {![winfo exists $itk_interior.bin]} {
393	itk_component add binary {
394	frame $itk_interior.bin
395	}
396	set icon $_icon
397	if { $icon == "" } {
398	set icon [Rappture::icon binary]
399	}
400	itk_component add binicon {
401	::label $itk_component(binary).binicon \
402	-image $icon -borderwidth 0
403	}
404	pack $itk_component(binicon) -side left
405
406	itk_component add bininfo {
407	::label $itk_component(binary).bininfo \
408	-text "Empty\n0 bytes" \
409	-width 5 -justify left -anchor w -borderwidth 0
410	}
411	pack $itk_component(bininfo) -side left -expand yes -fill x -padx 4
412
413	itk_component add bmenu {
414	menu $itk_component(binary).menu -tearoff 0
415	}
416	$itk_component(bmenu) add command \
417	-label [Rappture::filexfer::label upload] \
418	-command [itcl::code $this _uploadValue -start]
419	$itk_component(bmenu) add command \
420	-label [Rappture::filexfer::label download] \
421	-command [itcl::code $this _downloadValue]
422
423	bind $itk_component(binicon) <<PopupMenu>> \
424	[itcl::code $this _edit menu bmenu %X %Y]
425	bind $itk_component(bininfo) <<PopupMenu>> \
426	[itcl::code $this _edit menu bmenu %X %Y]
427	}
428
429	# show the binary mode rep
430	pack $itk_component(binary) -side top -fill x
431
432	}
433	default {
434	error "don't know how to handle mode \"$newlayout\" for string editor"
435	}
436	}
437	set _layout $newlayout
438	}
439
440	#
441	# Fix the overall widget size according to -width / -height
442	#
443	if {$itk_option(-width) == 0 && $itk_option(-height) == 0} {
444	pack propagate $itk_component(hull) yes
445	} else {
446	pack propagate $itk_component(hull) no
447	component hull configure \
448	-width $itk_option(-width) -height $itk_option(-width)
449	}
450	}
451
452	# ----------------------------------------------------------------------
453	# USAGE: _setValue <newValue>
454	#
455	# Used internally to set the value for this widget. If the <newValue>
456	# string is ASCII, then it is stored directly and the widget is enabled
457	# for editing. Otherwise, the value is cached and a representation of
458	# the data is displayed.
459	# ----------------------------------------------------------------------
460	itcl::body Rappture::TextEntry::_setValue {newval} {
461	if {[Rappture::encoding::is binary $newval]} {
462	# looks like a binary file
463	set _value $newval
464	} else {
465	# ascii file -- map carriage returns to line feeds
466	regsub -all "\r\n" $newval "\n" newval
467	regsub -all "\r" $newval "\n" newval
468	set _value $newval
469	}
470
471	# fix up the layout so the display widgets exist, then load the new value
472	_layout
473
474	switch -- $_layout {
475	entry {
476	$itk_component(entry) configure -state normal
477	$itk_component(entry) delete 0 end
478	$itk_component(entry) insert end $_value
479	$itk_component(entry) configure -state $itk_option(-state)
480	}
481	text {
482	$itk_component(text) configure -state normal
483	$itk_component(text) delete 1.0 end
484	$itk_component(text) insert end $_value
485	$itk_component(text) configure -state $itk_option(-state)
486	}
487	binary {
488	set desc [Rappture::utils::datatype $_value]
489	append desc "\n[Rappture::utils::binsize [string length $_value]]"
490	$itk_component(bininfo) configure -text $desc
491	}
492	}
493	}
494
495	# ----------------------------------------------------------------------
496	# USAGE: _newValue
497	#
498	# Invoked automatically whenever the value in the entry changes.
499	# Sends a <<Value>> event to notify clients of the change.
500	# ----------------------------------------------------------------------
501	itcl::body Rappture::TextEntry::_newValue {} {
502	event generate $itk_component(hull) <<Value>>
503	}
504
505	# ----------------------------------------------------------------------
506	# USAGE: _edit action <which> <action>
507	# USAGE: _edit menu <which> <X> <Y>
508	# USAGE: _edit finalize
509	# USAGE: _edit log
510	#
511	# Used internally to manage edit operations.
512	# ----------------------------------------------------------------------
513	itcl::body Rappture::TextEntry::_edit {option args} {
514	if {$itk_option(-state) == "disabled"} {
515	return ;# disabled? then bail out here!
516	}
517	switch -- $option {
518	action {
519	if {[llength $args] != 2} {
520	error "wrong # args: should be \"_edit $option which action\""
521	}
522	set widget [lindex $args 0]
523	set action [lindex $args 1]
524	switch -- $action {
525	cut - copy - paste {
526	set event "<<[string totitle $action]>>"
527	event generate $itk_component($widget) $event
528	}
529	selectall {
530	switch -- $widget {
531	entry { $itk_component(entry) selection range 0 end }
532	text { $itk_component(text) tag add sel 1.0 end }
533	default { error "don't know how to select for $widget" }
534	}
535	}
536	default {
537	error "don't know how to handle action $action"
538	}
539	}
540	Rappture::Logger::log input $_path -action $action
541	}
542	menu {
543	if {[llength $args] != 3} {
544	error "wrong # args: should be \"_edit $option which x y\""
545	}
546	set mname [lindex $args 0]
547	set x [lindex $args 1]
548	set y [lindex $args 2]
549	tk_popup $itk_component($mname) $x $y
550	}
551	finalize {
552	event generate $itk_component(hull) <<Final>>
553
554	# log each final value
555	set newval [value]
556	if {$newval ne $_value} {
557	Rappture::Logger::log input $_path $newval
558	set _value $newval
559	}
560	}
561	default {
562	error "bad option \"$option\": should be action, menu, log"
563	}
564	}
565	}
566
567	# ----------------------------------------------------------------------
568	# USAGE: _uploadValue -start
569	# USAGE: _uploadValue -assign <key> <value> <key> <value> ...
570	#
571	# Used internally to initiate an upload operation. Prompts the
572	# user to upload into the text area of this widget.
573	# ----------------------------------------------------------------------
574	itcl::body Rappture::TextEntry::_uploadValue {args} {
575	switch -- $_layout {
576	entry { set widget $itk_component(entry) }
577	text { set widget $itk_component(text) }
578	default { set widget $itk_component(hull) }
579	}
580
581	set opt [string trim [lindex $args 0]]
582	switch -- $opt {
583	-start {
584	set tool [Rappture::Tool::resources -appname]
585	set cntls [list $_path [label] [tooltip]]
586	Rappture::filexfer::upload \
587	$tool $cntls [itcl::code $this _uploadValue -assign]
588	}
589	-assign {
590	array set data [lrange $args 1 end] ;# skip option
591	if {[info exists data(error)]} {
592	Rappture::Tooltip::cue $widget $data(error)
593	Rappture::Logger::log warning $_path $data(error)
594	}
595	if {[info exists data(data)]} {
596	Rappture::Tooltip::cue hide ;# take down note about the popup
597	_setValue $data(data)
598	_newValue
599	Rappture::Logger::log upload $_path $data(data)
600	}
601	}
602	default {
603	error "bad option \"$opt\": should be -start or -assign"
604	}
605	}
606	}
607
608	# ----------------------------------------------------------------------
609	# USAGE: _downloadValue
610	#
611	# Used internally to initiate a download operation. Takes the current
612	# value and downloads it to the user in a new browser window.
613	# ----------------------------------------------------------------------
614	itcl::body Rappture::TextEntry::_downloadValue {} {
615	set mesg [Rappture::filexfer::download [value] input.txt]
616
617	if {$mesg ne ""} {
618	switch -- $_layout {
619	entry { set widget $itk_component(entry) }
620	text { set widget $itk_component(text) }
621	default { set widget $itk_component(hull) }
622	}
623	Rappture::Tooltip::cue $widget $mesg
624	Rappture::Logger::log warning $_path $mesg
625	} else {
626	Rappture::Logger::log download $_path
627	}
628	}
629
630	# ----------------------------------------------------------------------
631	# CONFIGURATION OPTION: -state
632	# ----------------------------------------------------------------------
633	itcl::configbody Rappture::TextEntry::state {
634	set valid {normal disabled}
635	if {[lsearch -exact $valid $itk_option(-state)] < 0} {
636	error "bad value \"$itk_option(-state)\": should be [join $valid {, }]"
637	}
638	if {[info exists itk_component(text)]} {
639	$itk_component(text) configure -state $itk_option(-state)
640	$itk_component(tmenu) entryconfigure "Cut" -state $itk_option(-state)
641	$itk_component(tmenu) entryconfigure "Copy" -state $itk_option(-state)
642	$itk_component(tmenu) entryconfigure "Paste" -state $itk_option(-state)
643	if {$itk_option(-state) == "disabled"} {
644	$itk_component(text) configure \
645	-foreground $itk_option(-disabledforeground) \
646	-background $itk_option(-disabledbackground)
647	} else {
648	$itk_component(text) configure \
649	-foreground $itk_option(-foreground) \
650	-background $itk_option(-textbackground)
651	}
652	}
653	if {[info exists itk_component(entry)]} {
654	$itk_component(entry) configure -state $itk_option(-state)
655	$itk_component(emenu) entryconfigure "Cut" -state $itk_option(-state)
656	$itk_component(emenu) entryconfigure "Copy" -state $itk_option(-state)
657	$itk_component(emenu) entryconfigure "Paste" -state $itk_option(-state)
658	}
659	}
660
661	# ----------------------------------------------------------------------
662	# CONFIGURATION OPTION: -width
663	# ----------------------------------------------------------------------
664	itcl::configbody Rappture::TextEntry::width {
665	# check size to see if it has the proper form
666	winfo pixels $itk_component(hull) $itk_option(-width)
667	$_dispatcher event -idle !layout
668	}
669
670	# ----------------------------------------------------------------------
671	# CONFIGURATION OPTION: -height
672	# ----------------------------------------------------------------------
673	itcl::configbody Rappture::TextEntry::height {
674	# check size to see if it has the proper form
675	winfo pixels $itk_component(hull) $itk_option(-height)
676	$_dispatcher event -idle !layout
677	}
678
679

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

Download in other formats: