Context Navigation

source: branches/r9/gui/scripts/textentry.tcl @ 4348

Last change on this file since 4348 was 4276, checked in by gah, 10 years ago
fix: race condition in _layout, finalize called when widgets deleted
File size: 26.4 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	# Set the _layout here because unpacking the widgets triggers
249	# the "_edit finalize" method (focus change).
250
251	set _layout $newlayout
252
253	# take down any existing widget
254	foreach win [pack slaves $itk_interior] {
255	if { [winfo name $win] != "hints" } {
256	pack forget $win
257	}
258	}
259
260	switch -- $newlayout {
261	entry {
262	# don't have the entry widget yet? then create it
263	if {![winfo exists $itk_interior.entry]} {
264	itk_component add entry {
265	entry $itk_interior.entry
266	} {
267	usual
268	rename -background -textbackground textBackground Background
269	rename -foreground -textforeground textForeground Foreground
270	}
271	$itk_component(entry) configure \
272	-background $itk_option(-textbackground) \
273	-foreground $itk_option(-textforeground)
274
275	# Make sure these event bindings occur after the class bindings.
276	# Otherwise you'll always get the entry value before the edit.
277	bind textentry-$this <KeyPress> \
278	[itcl::code $this _newValue]
279	bind textentry-$this <KeyPress-Return> \
280	[itcl::code $this _edit finalize]
281	bind textentry-$this <Control-KeyPress-a> \
282	"[list $itk_component(entry) selection range 0 end]; break"
283	bind textentry-$this <FocusOut> \
284	[itcl::code $this _edit finalize]
285	bind textentry-$this <Unmap> \
286	[itcl::code $this _edit finalize]
287	set bindtags [bindtags $itk_component(entry)]
288	lappend bindtags textentry-$this
289	bindtags $itk_component(entry) $bindtags
290
291	itk_component add emenu {
292	menu $itk_component(entry).menu -tearoff 0
293	}
294	$itk_component(emenu) add command \
295	-label "Cut" -accelerator "^X" \
296	-command [itcl::code $this _edit action entry cut]
297	$itk_component(emenu) add command \
298	-label "Copy" -accelerator "^C" \
299	-command [itcl::code $this _edit action entry copy]
300	$itk_component(emenu) add command \
301	-label "Paste" -accelerator "^V" \
302	-command [itcl::code $this _edit action entry paste]
303	$itk_component(emenu) add command \
304	-label "Select All" -accelerator "^A" \
305	-command [itcl::code $this _edit action entry selectall]
306	bind $itk_component(entry) <<PopupMenu>> \
307	[itcl::code $this _edit menu emenu %X %Y]
308	}
309
310	# show the entry widget
311	pack $itk_component(entry) -expand yes -fill both
312
313	# load any previous value
314	regsub -all "\n" $oldval "" oldval
315	$itk_component(entry) delete 0 end
316	$itk_component(entry) insert end $oldval
317	}
318
319	text {
320	if {![winfo exists $itk_interior.scrl]} {
321	itk_component add scrollbars {
322	Rappture::Scroller $itk_interior.scrl \
323	-xscrollmode auto -yscrollmode auto
324	}
325
326	itk_component add text {
327	text $itk_component(scrollbars).text \
328	-width 1 -height 1 -wrap char
329	} {
330	usual
331	ignore -highlightthickness -highlightcolor
332	rename -background -textbackground textBackground Background
333	rename -foreground -textforeground textForeground Foreground
334	rename -font -codefont codeFont CodeFont
335	}
336	$itk_component(text) configure \
337	-background $itk_option(-textbackground) \
338	-foreground $itk_option(-textforeground) \
339	-font $itk_option(-codefont) \
340	-highlightthickness 1
341	$itk_component(scrollbars) contents $itk_component(text)
342
343	# Make sure these event bindings occur after the class bindings.
344	# Otherwise you'll always get the text value before the edit.
345	bind textentry-$this <KeyPress> \
346	[itcl::code $this _newValue]
347	# leave [Return] key alone for multi-line text so the user
348	# can enter newlines and keep editing
349	bind textentry-$this <Control-KeyPress-a> \
350	"[list $itk_component(text) tag add sel 1.0 end]; break"
351	bind textentry-$this <FocusOut> \
352	[itcl::code $this _edit finalize]
353	bind textentry-$this <Unmap> \
354	[itcl::code $this _edit finalize]
355	set bindtags [bindtags $itk_component(text)]
356	lappend bindtags textentry-$this
357	bindtags $itk_component(text) $bindtags
358
359	itk_component add tmenu {
360	menu $itk_component(text).menu -tearoff 0
361	}
362	$itk_component(tmenu) add command \
363	-label "Cut" -accelerator "^X" \
364	-command [itcl::code $this _edit action text cut]
365	$itk_component(tmenu) add command \
366	-label "Copy" -accelerator "^C" \
367	-command [itcl::code $this _edit action text copy]
368	$itk_component(tmenu) add command \
369	-label "Paste" -accelerator "^V" \
370	-command [itcl::code $this _edit action text paste]
371	$itk_component(tmenu) add command \
372	-label "Select All" -accelerator "^A" \
373	-command [itcl::code $this _edit action text selectall]
374	$itk_component(tmenu) add separator
375
376	$itk_component(tmenu) add command \
377	-label [Rappture::filexfer::label upload] \
378	-command [itcl::code $this _uploadValue -start]
379	$itk_component(tmenu) add command \
380	-label [Rappture::filexfer::label download] \
381	-command [itcl::code $this _downloadValue]
382
383	bind $itk_component(text) <<PopupMenu>> \
384	[itcl::code $this _edit menu tmenu %X %Y]
385	}
386
387	# show the text editor widget
388	pack $itk_component(scrollbars) -expand yes -fill both
389	$itk_component(text) configure -width $w -height $h
390
391	# load any previous value
392	$itk_component(text) delete 1.0 end
393	$itk_component(text) insert end $oldval
394	}
395
396	binary {
397	if {![winfo exists $itk_interior.bin]} {
398	itk_component add binary {
399	frame $itk_interior.bin
400	}
401	set icon $_icon
402	if { $icon == "" } {
403	set icon [Rappture::icon binary]
404	}
405	itk_component add binicon {
406	::label $itk_component(binary).binicon \
407	-image $icon -borderwidth 0
408	}
409	pack $itk_component(binicon) -side left
410
411	itk_component add bininfo {
412	::label $itk_component(binary).bininfo \
413	-text "Empty\n0 bytes" \
414	-width 5 -justify left -anchor w -borderwidth 0
415	}
416	pack $itk_component(bininfo) -side left -expand yes -fill x -padx 4
417
418	itk_component add bmenu {
419	menu $itk_component(binary).menu -tearoff 0
420	}
421	$itk_component(bmenu) add command \
422	-label [Rappture::filexfer::label upload] \
423	-command [itcl::code $this _uploadValue -start]
424	$itk_component(bmenu) add command \
425	-label [Rappture::filexfer::label download] \
426	-command [itcl::code $this _downloadValue]
427
428	bind $itk_component(binicon) <<PopupMenu>> \
429	[itcl::code $this _edit menu bmenu %X %Y]
430	bind $itk_component(bininfo) <<PopupMenu>> \
431	[itcl::code $this _edit menu bmenu %X %Y]
432	}
433
434	# show the binary mode rep
435	pack $itk_component(binary) -side top -fill x
436
437	}
438	default {
439	error "don't know how to handle mode \"$newlayout\" for string editor"
440	}
441	}
442	}
443
444	#
445	# Fix the overall widget size according to -width / -height
446	#
447	if {$itk_option(-width) == 0 && $itk_option(-height) == 0} {
448	pack propagate $itk_component(hull) yes
449	} else {
450	pack propagate $itk_component(hull) no
451	component hull configure \
452	-width $itk_option(-width) -height $itk_option(-width)
453	}
454	}
455
456	# ----------------------------------------------------------------------
457	# USAGE: _setValue <newValue>
458	#
459	# Used internally to set the value for this widget. If the <newValue>
460	# string is ASCII, then it is stored directly and the widget is enabled
461	# for editing. Otherwise, the value is cached and a representation of
462	# the data is displayed.
463	# ----------------------------------------------------------------------
464	itcl::body Rappture::TextEntry::_setValue {newval} {
465	if {[Rappture::encoding::is binary $newval]} {
466	# looks like a binary file
467	set _value $newval
468	} else {
469	# ascii file -- map carriage returns to line feeds
470	regsub -all "\r\n" $newval "\n" newval
471	regsub -all "\r" $newval "\n" newval
472	set _value $newval
473	}
474
475	# fix up the layout so the display widgets exist, then load the new value
476	_layout
477
478	switch -- $_layout {
479	entry {
480	$itk_component(entry) configure -state normal
481	$itk_component(entry) delete 0 end
482	$itk_component(entry) insert end $_value
483	$itk_component(entry) configure -state $itk_option(-state)
484	}
485	text {
486	$itk_component(text) configure -state normal
487	$itk_component(text) delete 1.0 end
488	$itk_component(text) insert end $_value
489	$itk_component(text) configure -state $itk_option(-state)
490	}
491	binary {
492	set desc [Rappture::utils::datatype $_value]
493	append desc "\n[Rappture::utils::binsize [string length $_value]]"
494	$itk_component(bininfo) configure -text $desc
495	}
496	}
497	}
498
499	# ----------------------------------------------------------------------
500	# USAGE: _newValue
501	#
502	# Invoked automatically whenever the value in the entry changes.
503	# Sends a <<Value>> event to notify clients of the change.
504	# ----------------------------------------------------------------------
505	itcl::body Rappture::TextEntry::_newValue {} {
506	event generate $itk_component(hull) <<Value>>
507	}
508
509	# ----------------------------------------------------------------------
510	# USAGE: _edit action <which> <action>
511	# USAGE: _edit menu <which> <X> <Y>
512	# USAGE: _edit finalize
513	# USAGE: _edit log
514	#
515	# Used internally to manage edit operations.
516	# ----------------------------------------------------------------------
517	itcl::body Rappture::TextEntry::_edit {option args} {
518	if {$itk_option(-state) == "disabled"} {
519	return ;# disabled? then bail out here!
520	}
521	switch -- $option {
522	action {
523	if {[llength $args] != 2} {
524	error "wrong # args: should be \"_edit $option which action\""
525	}
526	set widget [lindex $args 0]
527	set action [lindex $args 1]
528	switch -- $action {
529	cut - copy - paste {
530	set event "<<[string totitle $action]>>"
531	event generate $itk_component($widget) $event
532	}
533	selectall {
534	switch -- $widget {
535	entry { $itk_component(entry) selection range 0 end }
536	text { $itk_component(text) tag add sel 1.0 end }
537	default { error "don't know how to select for $widget" }
538	}
539	}
540	default {
541	error "don't know how to handle action $action"
542	}
543	}
544	Rappture::Logger::log input $_path -action $action
545	}
546	menu {
547	if {[llength $args] != 3} {
548	error "wrong # args: should be \"_edit $option which x y\""
549	}
550	set mname [lindex $args 0]
551	set x [lindex $args 1]
552	set y [lindex $args 2]
553	tk_popup $itk_component($mname) $x $y
554	}
555	finalize {
556	event generate $itk_component(hull) <<Final>>
557
558	# log each final value
559	set newval [value]
560	if {$newval ne $_value} {
561	Rappture::Logger::log input $_path $newval
562	set _value $newval
563	}
564	}
565	default {
566	error "bad option \"$option\": should be action, menu, log"
567	}
568	}
569	}
570
571	# ----------------------------------------------------------------------
572	# USAGE: _uploadValue -start
573	# USAGE: _uploadValue -assign <key> <value> <key> <value> ...
574	#
575	# Used internally to initiate an upload operation. Prompts the
576	# user to upload into the text area of this widget.
577	# ----------------------------------------------------------------------
578	itcl::body Rappture::TextEntry::_uploadValue {args} {
579	switch -- $_layout {
580	entry { set widget $itk_component(entry) }
581	text { set widget $itk_component(text) }
582	default { set widget $itk_component(hull) }
583	}
584
585	set opt [string trim [lindex $args 0]]
586	switch -- $opt {
587	-start {
588	set tool [Rappture::Tool::resources -appname]
589	set cntls [list $_path [label] [tooltip]]
590	Rappture::filexfer::upload \
591	$tool $cntls [itcl::code $this _uploadValue -assign]
592	}
593	-assign {
594	array set data [lrange $args 1 end] ;# skip option
595	if {[info exists data(error)]} {
596	Rappture::Tooltip::cue $widget $data(error)
597	Rappture::Logger::log warning $_path $data(error)
598	}
599	if {[info exists data(data)]} {
600	Rappture::Tooltip::cue hide ;# take down note about the popup
601	_setValue $data(data)
602	_newValue
603	Rappture::Logger::log upload $_path $data(data)
604	}
605	}
606	default {
607	error "bad option \"$opt\": should be -start or -assign"
608	}
609	}
610	}
611
612	# ----------------------------------------------------------------------
613	# USAGE: _downloadValue
614	#
615	# Used internally to initiate a download operation. Takes the current
616	# value and downloads it to the user in a new browser window.
617	# ----------------------------------------------------------------------
618	itcl::body Rappture::TextEntry::_downloadValue {} {
619	set mesg [Rappture::filexfer::download [value] input.txt]
620
621	if {$mesg ne ""} {
622	switch -- $_layout {
623	entry { set widget $itk_component(entry) }
624	text { set widget $itk_component(text) }
625	default { set widget $itk_component(hull) }
626	}
627	Rappture::Tooltip::cue $widget $mesg
628	Rappture::Logger::log warning $_path $mesg
629	} else {
630	Rappture::Logger::log download $_path
631	}
632	}
633
634	# ----------------------------------------------------------------------
635	# CONFIGURATION OPTION: -state
636	# ----------------------------------------------------------------------
637	itcl::configbody Rappture::TextEntry::state {
638	set valid {normal disabled}
639	if {[lsearch -exact $valid $itk_option(-state)] < 0} {
640	error "bad value \"$itk_option(-state)\": should be [join $valid {, }]"
641	}
642	if {[info exists itk_component(text)]} {
643	$itk_component(text) configure -state $itk_option(-state)
644	$itk_component(tmenu) entryconfigure "Cut" -state $itk_option(-state)
645	$itk_component(tmenu) entryconfigure "Copy" -state $itk_option(-state)
646	$itk_component(tmenu) entryconfigure "Paste" -state $itk_option(-state)
647	if {$itk_option(-state) == "disabled"} {
648	$itk_component(text) configure \
649	-foreground $itk_option(-disabledforeground) \
650	-background $itk_option(-disabledbackground)
651	} else {
652	$itk_component(text) configure \
653	-foreground $itk_option(-foreground) \
654	-background $itk_option(-textbackground)
655	}
656	}
657	if {[info exists itk_component(entry)]} {
658	$itk_component(entry) configure -state $itk_option(-state)
659	$itk_component(emenu) entryconfigure "Cut" -state $itk_option(-state)
660	$itk_component(emenu) entryconfigure "Copy" -state $itk_option(-state)
661	$itk_component(emenu) entryconfigure "Paste" -state $itk_option(-state)
662	}
663	}
664
665	# ----------------------------------------------------------------------
666	# CONFIGURATION OPTION: -width
667	# ----------------------------------------------------------------------
668	itcl::configbody Rappture::TextEntry::width {
669	# check size to see if it has the proper form
670	winfo pixels $itk_component(hull) $itk_option(-width)
671	$_dispatcher event -idle !layout
672	}
673
674	# ----------------------------------------------------------------------
675	# CONFIGURATION OPTION: -height
676	# ----------------------------------------------------------------------
677	itcl::configbody Rappture::TextEntry::height {
678	# check size to see if it has the proper form
679	winfo pixels $itk_component(hull) $itk_option(-height)
680	$_dispatcher event -idle !layout
681	}
682
683

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

Download in other formats: