Context Navigation

← Previous Revision
Next Revision →
Blame
Revision Log

tkcon.tcl

Last change on this file was 986, checked in by toby, 14 years ago
tkcon fixes; implement gnome-terminal if xterm is not found
Property svn:executable set to ``*
File size: 186.5 KB

Line
1	#!/bin/sh
2	# \
3	exec wish "$0" ${1+"$@"}
4
5	#
6	## tkcon.tcl
7	## Enhanced Tk Console, part of the VerTcl system
8	##
9	## Originally based off Brent Welch's Tcl Shell Widget
10	## (from "Practical Programming in Tcl and Tk")
11	##
12	## Thanks to the following (among many) for early bug reports & code ideas:
13	## Steven Wahl, Jan Nijtmans, Mark Crimmins, Wart
14	##
15	## Copyright (c) 1995-2004 Jeffrey Hobbs, jeff(a)hobbs(.)org
16	## Initiated: Thu Aug 17 15:36:47 PDT 1995
17	##
18	## source standard_disclaimer.tcl
19	## source bourbon_ware.tcl
20	##
21
22	# Proxy support for retrieving the current version of Tkcon.
23	#
24	# Mon Jun 25 12:19:56 2001 - Pat Thoyts
25	#
26	# In your tkcon.cfg or .tkconrc file put your proxy details into the
27	# `proxy' member of the `PRIV' array. e.g.:
28	#
29	# set ::tkcon::PRIV(proxy) wwwproxy:8080
30	#
31	# If you want to be prompted for proxy authentication details (eg for
32	# an NT proxy server) make the second element of this variable non-nil - eg:
33	#
34	# set ::tkcon::PRIV(proxy) {wwwproxy:8080 1}
35	#
36	# Or you can set the above variable from within tkcon by calling
37	#
38	# tkcon master set ::tkcon:PRIV(proxy) wwwproxy:8080
39	#
40
41	if {$tcl_version < 8.0} {
42	return -code error "tkcon requires at least Tcl/Tk8"
43	} else {
44	# package require -exact Tk $tcl_version; # exact causes a problem with Tk 8.5+
45	package require Tk $tcl_version
46	}
47
48	# We need to load some package to get what's available, and we
49	# choose ctext because we'll use it if its available in the editor
50	catch {package require ctext}
51	foreach pkg [info loaded {}] {
52	set file [lindex $pkg 0]
53	set name [lindex $pkg 1]
54	if {![catch {set version [package require $name]}]} {
55	if {[string match {} [package ifneeded $name $version]]} {
56	package ifneeded $name $version [list load $file $name]
57	}
58	}
59	}
60	catch {unset pkg file name version}
61
62	# Tk 8.4 makes previously exposed stuff private.
63	# FIX: Update tkcon to not rely on the private Tk code.
64	#
65	if {![llength [info globals tkPriv]]} {
66	::tk::unsupported::ExposePrivateVariable tkPriv
67	}
68	foreach cmd {SetCursor UpDownLine Transpose ScrollPages} {
69	if {![llength [info commands tkText$cmd]]} {
70	::tk::unsupported::ExposePrivateCommand tkText$cmd
71	}
72	}
73
74	# Initialize the ::tkcon namespace
75	#
76	namespace eval ::tkcon {
77	# when modifying this line, make sure that the auto-upgrade check
78	# for version still works.
79	variable VERSION "2.4"
80	# The OPT variable is an array containing most of the optional
81	# info to configure. COLOR has the color data.
82	variable OPT
83	variable COLOR
84
85	# PRIV is used for internal data that only tkcon should fiddle with.
86	variable PRIV
87	set PRIV(WWW) [info exists embed_args]
88
89	variable EXPECT 0
90	}
91
92	## ::tkcon::Init - inits tkcon
93	#
94	# Calls: ::tkcon::InitUI
95	# Outputs: errors found in tkcon's resource file
96	##
97	proc ::tkcon::Init {args} {
98	variable VERSION
99	variable OPT
100	variable COLOR
101	variable PRIV
102	global tcl_platform env tcl_interactive errorInfo
103
104	set tcl_interactive 1
105	set argc [llength $args]
106
107	##
108	## When setting up all the default values, we always check for
109	## prior existence. This allows users who embed tkcon to modify
110	## the initial state before tkcon initializes itself.
111	##
112
113	# bg == {} will get bg color from the main toplevel (in InitUI)
114	foreach {key default} {
115	bg {}
116	blink \#FFFF00
117	cursor \#000000
118	disabled \#4D4D4D
119	proc \#008800
120	var \#FFC0D0
121	prompt \#8F4433
122	stdin \#000000
123	stdout \#0000FF
124	stderr \#FF0000
125	} {
126	if {![info exists COLOR($key)]} { set COLOR($key) $default }
127	}
128
129	# expandorder could also include 'Xotcl' (before Procname)
130	foreach {key default} {
131	autoload {}
132	blinktime 500
133	blinkrange 1
134	buffer 512
135	maxlinelen 0
136	calcmode 0
137	cols 80
138	debugPrompt {(level \#$level) debug [history nextid] > }
139	dead {}
140	edit edit
141	expandorder {Pathname Variable Procname}
142	font {}
143	history 48
144	hoterrors 1
145	library {}
146	lightbrace 1
147	lightcmd 1
148	maineval {}
149	maxmenu 18
150	nontcl 0
151	prompt1 {ignore this, it's set below}
152	rows 20
153	scrollypos right
154	showmenu 1
155	showmultiple 1
156	showstatusbar 1
157	slaveeval {}
158	slaveexit close
159	subhistory 1
160	gc-delay 60000
161	gets {congets}
162	overrideexit 1
163	usehistory 1
164
165	exec slave
166	} {
167	if {![info exists OPT($key)]} { set OPT($key) $default }
168	}
169
170	foreach {key default} {
171	app {}
172	appname {}
173	apptype slave
174	namesp ::
175	cmd {}
176	cmdbuf {}
177	cmdsave {}
178	event 1
179	deadapp 0
180	deadsock 0
181	debugging 0
182	displayWin .
183	histid 0
184	find {}
185	find,case 0
186	find,reg 0
187	errorInfo {}
188	protocol exit
189	showOnStartup 1
190	slaveprocs {
191	alias clear dir dump echo idebug lremove
192	tkcon_puts tkcon_gets observe observe_var unalias which what
193	}
194	RCS {RCS: @(#) $Id: tkcon.tcl,v 1.89 2005/09/12 19:07:17 hobbs Exp $}
195	HEADURL {http://cvs.sourceforge.net/viewcvs.py/checkout/tkcon/tkcon/tkcon.tcl?rev=HEAD}
196
197	docs "http://tkcon.sourceforge.net/"
198	email {jeff(a)hobbs(.)org}
199	root .
200	uid 0
201	tabs {}
202	} {
203	if {![info exists PRIV($key)]} { set PRIV($key) $default }
204	}
205	foreach {key default} {
206	slavealias { $OPT(edit) more less tkcon }
207	} {
208	if {![info exists PRIV($key)]} { set PRIV($key) [subst $default] }
209	}
210	set PRIV(version) $VERSION
211
212	option add *Menu.tearOff 0
213	option add *takeFocus 0
214
215	if {[info exists PRIV(name)]} {
216	set title $PRIV(name)
217	} else {
218	MainInit
219	# some main initialization occurs later in this proc,
220	# to go after the UI init
221	set MainInit 1
222	set title Main
223	}
224
225	## NOTES FOR STAYING IN PRIMARY INTERPRETER:
226	##
227	## If you set ::tkcon::OPT(exec) to {}, then instead of a multiple
228	## interp model, you get tkcon operating in the main interp by default.
229	## This can be useful when attaching to programs that like to operate
230	## in the main interpter (for example, based on special wish'es).
231	## You can set this from the command line with -exec ""
232	## A side effect is that all tkcon command line args will be used
233	## by the first console only.
234	#set OPT(exec) {}
235
236	if {$PRIV(WWW)} {
237	lappend PRIV(slavealias) history
238	set OPT(prompt1) {[history nextid] % }
239	} else {
240	lappend PRIV(slaveprocs) tcl_unknown unknown
241	set OPT(prompt1) {([file tail [pwd]]) [history nextid] % }
242	}
243
244	## If we are using the default '.' toplevel, and there appear to be
245	## children of '.', then make sure we use a disassociated toplevel.
246	if {$PRIV(root) == "." && [llength [winfo children .]]} {
247	set PRIV(root) .tkcon
248	}
249
250	## Do platform specific configuration here, other than defaults
251	### Use tkcon.cfg filename for resource filename on non-unix systems
252	### Determine what directory the resource file should be in
253	switch $tcl_platform(platform) {
254	macintosh {
255	if {![interp issafe]} {cd [file dirname [info script]]}
256	set envHome PREF_FOLDER
257	set rcfile tkcon.cfg
258	set histfile tkcon.hst
259	catch {console hide}
260	}
261	windows {
262	set envHome HOME
263	set rcfile tkcon.cfg
264	set histfile tkcon.hst
265	}
266	unix {
267	set envHome HOME
268	set rcfile .tkconrc
269	set histfile .tkcon_history
270	}
271	}
272	if {[info exists env($envHome)]} {
273	set home $env($envHome)
274	if {[file pathtype $home] == "volumerelative"} {
275	# Convert 'C:' to 'C:/' if necessary, innocuous otherwise
276	append home /
277	}
278	if {![info exists PRIV(rcfile)]} {
279	set PRIV(rcfile) [file join $home $rcfile]
280	}
281	if {![info exists PRIV(histfile)]} {
282	set PRIV(histfile) [file join $home $histfile]
283	}
284	}
285
286	## Handle command line arguments before sourcing resource file to
287	## find if resource file is being specified (let other args pass).
288	if {[set i [lsearch -exact $args -rcfile]] != -1} {
289	set PRIV(rcfile) [lindex $args [incr i]]
290	}
291
292	if {!$PRIV(WWW) && [file exists $PRIV(rcfile)]} {
293	set code [catch {uplevel \#0 [list source $PRIV(rcfile)]} err]
294	}
295
296	if {[info exists env(TK_CON_LIBRARY)]} {
297	lappend ::auto_path $env(TK_CON_LIBRARY)
298	} elseif {$OPT(library) != ""} {
299	lappend ::auto_path $OPT(library)
300	}
301
302	if {![info exists ::tcl_pkgPath]} {
303	set dir [file join [file dirname [info nameofexec]] lib]
304	if {[llength [info commands @scope]]} {
305	set dir [file join $dir itcl]
306	}
307	catch {source [file join $dir pkgIndex.tcl]}
308	}
309	catch {tclPkgUnknown dummy-name dummy-version}
310
311	## Handle rest of command line arguments after sourcing resource file
312	## and slave is created, but before initializing UI or setting packages.
313	set slaveargs {}
314	set slavefiles {}
315	set truth {^(1\|yes\|true\|on)$}
316	for {set i 0} {$i < $argc} {incr i} {
317	set arg [lindex $args $i]
318	if {[string match {-*} $arg]} {
319	set val [lindex $args [incr i]]
320	## Handle arg based options
321	switch -glob -- $arg {
322	-- - -argv - -args {
323	set argv [concat -- [lrange $argv $i end]]
324	set argc [llength $argv]
325	break
326	}
327	-color-* { set COLOR([string range $arg 7 end]) $val }
328	-exec { set OPT(exec) $val }
329	-main - -e - -eval { append OPT(maineval) \n$val\n }
330	-package - -load { lappend OPT(autoload) $val }
331	-slave { append OPT(slaveeval) \n$val\n }
332	-nontcl { set OPT(nontcl) [regexp -nocase $truth $val]}
333	-root { set PRIV(root) $val }
334	-font { set OPT(font) $val }
335	-rcfile {}
336	default { lappend slaveargs $arg; incr i -1 }
337	}
338	} elseif {[file isfile $arg]} {
339	lappend slavefiles $arg
340	} else {
341	lappend slaveargs $arg
342	}
343	}
344
345	## Create slave executable
346	if {"" != $OPT(exec)} {
347	uplevel \#0 ::tkcon::InitSlave $OPT(exec) $slaveargs
348	} else {
349	set argc [llength $slaveargs]
350	set args $slaveargs
351	uplevel \#0 $slaveargs
352	}
353
354	## Attach to the slave, EvalAttached will then be effective
355	Attach $PRIV(appname) $PRIV(apptype)
356	InitUI $title
357	if {"" != $OPT(exec)} {
358	# override exit to DeleteTab now that tab has been created
359	$OPT(exec) alias exit ::tkcon::DeleteTab $PRIV(curtab) $OPT(exec)
360	}
361
362	## swap puts and gets with the tkcon versions to make sure all
363	## input and output is handled by tkcon
364	if {![catch {rename ::puts ::tkcon_tcl_puts}]} {
365	interp alias {} ::puts {} ::tkcon_puts
366	}
367	if {($OPT(gets) != "") && ![catch {rename ::gets ::tkcon_tcl_gets}]} {
368	interp alias {} ::gets {} ::tkcon_gets
369	}
370
371	EvalSlave history keep $OPT(history)
372	if {[info exists MainInit]} {
373	# Source history file only for the main console, as all slave
374	# consoles will adopt from the main's history, but still
375	# keep separate histories
376	if {!$PRIV(WWW) && $OPT(usehistory) && [file exists $PRIV(histfile)]} {
377	puts -nonewline "loading history file ... "
378	# The history file is built to be loaded in and
379	# understood by tkcon
380	if {[catch {uplevel \#0 [list source $PRIV(histfile)]} herr]} {
381	puts stderr "error:\n$herr"
382	append PRIV(errorInfo) $errorInfo\n
383	}
384	set PRIV(event) [EvalSlave history nextid]
385	puts "[expr {$PRIV(event)-1}] events added"
386	}
387	}
388
389	## Autoload specified packages in slave
390	set pkgs [EvalSlave package names]
391	foreach pkg $OPT(autoload) {
392	puts -nonewline "autoloading package \"$pkg\" ... "
393	if {[lsearch -exact $pkgs $pkg]>-1} {
394	if {[catch {EvalSlave package require [list $pkg]} pkgerr]} {
395	puts stderr "error:\n$pkgerr"
396	append PRIV(errorInfo) $errorInfo\n
397	} else { puts "OK" }
398	} else {
399	puts stderr "error: package does not exist"
400	}
401	}
402
403	## Evaluate maineval in slave
404	if {[string compare {} $OPT(maineval)] && \
405	[catch {uplevel \#0 $OPT(maineval)} merr]} {
406	puts stderr "error in eval:\n$merr"
407	append PRIV(errorInfo) $errorInfo\n
408	}
409
410	## Source extra command line argument files into slave executable
411	foreach fn $slavefiles {
412	puts -nonewline "slave sourcing \"$fn\" ... "
413	if {[catch {EvalSlave source [list $fn]} fnerr]} {
414	puts stderr "error:\n$fnerr"
415	append PRIV(errorInfo) $errorInfo\n
416	} else { puts "OK" }
417	}
418
419	## Evaluate slaveeval in slave
420	if {[string compare {} $OPT(slaveeval)] && \
421	[catch {interp eval $OPT(exec) $OPT(slaveeval)} serr]} {
422	puts stderr "error in slave eval:\n$serr"
423	append PRIV(errorInfo) $errorInfo\n
424	}
425	## Output any error/output that may have been returned from rcfile
426	if {[info exists code] && $code && [string compare {} $err]} {
427	puts stderr "error in $PRIV(rcfile):\n$err"
428	append PRIV(errorInfo) $errorInfo
429	}
430	if {[string compare {} $OPT(exec)]} {
431	StateCheckpoint [concat $PRIV(name) $OPT(exec)] slave
432	}
433	StateCheckpoint $PRIV(name) slave
434
435	puts "buffer line limit:\
436	[expr {$OPT(buffer)?$OPT(buffer):{unlimited}}] \
437	max line length:\
438	[expr {$OPT(maxlinelen)?$OPT(maxlinelen):{unlimited}}]"
439
440	Prompt "$title console display active (Tcl$::tcl_patchLevel / Tk$::tk_patchLevel)\n"
441	}
442
443	## ::tkcon::InitSlave - inits the slave by placing key procs and aliases in it
444	## It's arg[cv] are based on passed in options, while argv0 is the same as
445	## the master. tcl_interactive is the same as the master as well.
446	# ARGS: slave - name of slave to init. If it does not exist, it is created.
447	# args - args to pass to a slave as argv/argc
448	##
449	proc ::tkcon::InitSlave {slave args} {
450	variable OPT
451	variable COLOR
452	variable PRIV
453	global argv0 tcl_interactive tcl_library env auto_path tk_library
454
455	if {[string match {} $slave]} {
456	return -code error "Don't init the master interpreter, goofball"
457	}
458	if {![interp exists $slave]} { interp create $slave }
459	if {[interp eval $slave info command source] == ""} {
460	$slave alias source SafeSource $slave
461	$slave alias load SafeLoad $slave
462	$slave alias open SafeOpen $slave
463	$slave alias file file
464	interp eval $slave \
465	[list set auto_path [lremove $auto_path $tk_library]]
466	interp eval $slave [dump var -nocomplain tcl_library env]
467	interp eval $slave { catch {source [file join $tcl_library init.tcl]} }
468	interp eval $slave { catch unknown }
469	}
470	# This will likely be overridden to call DeleteTab where possible
471	$slave alias exit exit
472	interp eval $slave {
473	# Do package require before changing around puts/gets
474	catch {package require bogus-package-name}
475	catch {rename ::puts ::tkcon_tcl_puts}
476	}
477	foreach cmd $PRIV(slaveprocs) { $slave eval [dump proc $cmd] }
478	foreach cmd $PRIV(slavealias) { $slave alias $cmd $cmd }
479	interp alias $slave ::ls $slave ::dir -full
480	interp alias $slave ::puts $slave ::tkcon_puts
481	if {$OPT(gets) != ""} {
482	interp eval $slave { catch {rename ::gets ::tkcon_tcl_gets} }
483	interp alias $slave ::gets $slave ::tkcon_gets
484	}
485	if {[info exists argv0]} {interp eval $slave [list set argv0 $argv0]}
486	interp eval $slave set tcl_interactive $tcl_interactive \; \
487	set auto_path [list [lremove $auto_path $tk_library]] \; \
488	set argc [llength $args] \; \
489	set argv [list $args] \; {
490	if {![llength [info command bgerror]]} {
491	proc bgerror err {
492	global errorInfo
493	set body [info body bgerror]
494	rename ::bgerror {}
495	if {[auto_load bgerror]} { return [bgerror $err] }
496	proc bgerror err $body
497	tkcon bgerror $err $errorInfo
498	}
499	}
500	}
501
502	foreach pkg [lremove [package names] Tcl] {
503	foreach v [package versions $pkg] {
504	interp eval $slave [list package ifneeded $pkg $v \
505	[package ifneeded $pkg $v]]
506	}
507	}
508	}
509
510	## ::tkcon::InitInterp - inits an interpreter by placing key
511	## procs and aliases in it.
512	# ARGS: name - interp name
513	# type - interp type (slave\|interp)
514	##
515	proc ::tkcon::InitInterp {name type} {
516	variable OPT
517	variable PRIV
518
519	## Don't allow messing up a local master interpreter
520	if {[string match namespace $type] \|\| ([string match slave $type] && \
521	[regexp {^([Mm]ain\|Slave[0-9]+)$} $name])} return
522	set old [Attach]
523	set oldname $PRIV(namesp)
524	catch {
525	Attach $name $type
526	EvalAttached { catch {rename ::puts ::tkcon_tcl_puts} }
527	foreach cmd $PRIV(slaveprocs) { EvalAttached [dump proc $cmd] }
528	switch -exact $type {
529	slave {
530	foreach cmd $PRIV(slavealias) {
531	Main interp alias $name ::$cmd $PRIV(name) ::$cmd
532	}
533	}
534	interp {
535	set thistkcon [::send::appname]
536	foreach cmd $PRIV(slavealias) {
537	EvalAttached "proc $cmd args { ::send::send [list $thistkcon] $cmd \$args }"
538	}
539	}
540	}
541	## Catch in case it's a 7.4 (no 'interp alias') interp
542	EvalAttached {
543	catch {interp alias {} ::ls {} ::dir -full}
544	if {[catch {interp alias {} ::puts {} ::tkcon_puts}]} {
545	catch {rename ::tkcon_puts ::puts}
546	}
547	}
548	if {$OPT(gets) != ""} {
549	EvalAttached {
550	catch {rename ::gets ::tkcon_tcl_gets}
551	if {[catch {interp alias {} ::gets {} ::tkcon_gets}]} {
552	catch {rename ::tkcon_gets ::gets}
553	}
554	}
555	}
556	return
557	} {err}
558	eval Attach $old
559	AttachNamespace $oldname
560	if {[string compare {} $err]} { return -code error $err }
561	}
562
563	## ::tkcon::InitUI - inits UI portion (console) of tkcon
564	## Creates all elements of the console window and sets up the text tags
565	# ARGS: root - widget pathname of the tkcon console root
566	# title - title for the console root and main (.) windows
567	# Calls: ::tkcon::InitMenus, ::tkcon::Prompt
568	##
569	proc ::tkcon::InitUI {title} {
570	variable OPT
571	variable PRIV
572	variable COLOR
573
574	set root $PRIV(root)
575	if {[string match . $root]} { set w {} } else { set w [toplevel $root] }
576	if {!$PRIV(WWW)} {
577	wm withdraw $root
578	wm protocol $root WM_DELETE_WINDOW $PRIV(protocol)
579	}
580	set PRIV(base) $w
581
582	catch {font create tkconfixed -family Courier -size -12}
583	catch {font create tkconfixedbold -family Courier -size -12 -weight bold}
584
585	set PRIV(statusbar) [set sbar [frame $w.fstatus]]
586	set PRIV(tabframe) [frame $sbar.tabs]
587	set PRIV(X) [button $sbar.deltab -text "X" -command ::tkcon::DeleteTab \
588	-activeforeground red -fg red -font tkconfixedbold \
589	-highlightthickness 0 -padx 2 -pady 0 -bd 1 \
590	-state disabled -relief flat]
591	catch {$PRIV(X) configure -overrelief raised}
592	label $sbar.cursor -relief sunken -bd 1 -anchor e -width 6 \
593	-textvariable ::tkcon::PRIV(StatusCursor)
594	set padx [expr {![info exists ::tcl_platform(os)]
595	\|\| ![string match "Windows CE" $::tcl_platform(os)]}]
596	grid $PRIV(X) $PRIV(tabframe) $sbar.cursor -sticky news -padx $padx
597	grid configure $PRIV(tabframe) -sticky nsw
598	grid configure $PRIV(X) -pady 0 -padx 0
599	grid columnconfigure $sbar 1 -weight 1
600	grid rowconfigure $sbar 0 -weight 1
601	grid rowconfigure $PRIV(tabframe) 0 -weight 1
602	if {$::tcl_version >= 8.4 && [tk windowingsystem] == "aqua"} {
603	# resize control space
604	grid columnconfigure $sbar [lindex [grid size $sbar] 0] -minsize 16
605	}
606
607	## Create console tab
608	set con [InitTab $w]
609	set PRIV(curtab) $con
610
611	# Only apply this for the first console
612	$con configure -setgrid 1 -width $OPT(cols) -height $OPT(rows)
613	bind $PRIV(root) <Configure> {
614	if {"%W" == $::tkcon::PRIV(root)} {
615	scan [wm geometry [winfo toplevel %W]] "%%dx%%d" \
616	::tkcon::OPT(cols) ::tkcon::OPT(rows)
617	if {[info exists ::tkcon::EXP(spawn_id)]} {
618	catch {stty rows $::tkcon::OPT(rows) columns \
619	$::tkcon::OPT(cols) < $::tkcon::EXP(slave,name)}
620	}
621	}
622	}
623
624	# scrollbar
625	set sy [scrollbar $w.sy -takefocus 0 -bd 1 -command [list $con yview]]
626	if {!$PRIV(WWW) && [string match "Windows CE" $::tcl_platform(os)]} {
627	$w.sy configure -width 10
628	}
629
630	$con configure -yscrollcommand [list $sy set]
631	set PRIV(console) $con
632	set PRIV(scrolly) $sy
633
634	## Menus
635	## catch against use in plugin
636	if {[catch {menu $w.mbar} PRIV(menubar)]} {
637	set PRIV(menubar) [frame $w.mbar -relief raised -bd 1]
638	}
639
640	InitMenus $PRIV(menubar) $title
641	Bindings
642
643	if {$OPT(showmenu)} {
644	$root configure -menu $PRIV(menubar)
645	}
646
647	grid $con -row 1 -column 1 -sticky news
648	grid $sy -row 1 -column [expr {$OPT(scrollypos)=="left"?0:2}] -sticky ns
649	grid $sbar -row 2 -column 0 -columnspan 3 -sticky ew
650
651	grid columnconfigure $root 1 -weight 1
652	grid rowconfigure $root 1 -weight 1
653
654	if {!$OPT(showstatusbar)} {
655	grid remove $sbar
656	}
657
658	if {!$PRIV(WWW)} {
659	wm title $root "tkcon $PRIV(version) $title"
660	if {$PRIV(showOnStartup)} { wm deiconify $root }
661	}
662	if {$PRIV(showOnStartup)} { focus -force $PRIV(console) }
663	if {$OPT(gc-delay)} {
664	after $OPT(gc-delay) ::tkcon::GarbageCollect
665	}
666	}
667
668	proc ::tkcon::InitTab {w} {
669	variable OPT
670	variable PRIV
671	variable COLOR
672	variable ATTACH
673
674	# text console
675	set con $w.tab[incr PRIV(uid)]
676	text $con -wrap char -foreground $COLOR(stdin) \
677	-insertbackground $COLOR(cursor)
678	$con mark set output 1.0
679	$con mark set limit 1.0
680	if {[string compare {} $COLOR(bg)]} {
681	$con configure -background $COLOR(bg)
682	}
683	set COLOR(bg) [$con cget -background]
684	if {[string compare {} $OPT(font)]} {
685	## Set user-requested font, if any
686	$con configure -font $OPT(font)
687	} elseif {[string compare unix $::tcl_platform(platform)]} {
688	## otherwise make sure the font is monospace
689	set font [$con cget -font]
690	if {![font metrics $font -fixed]} {
691	$con configure -font tkconfixed
692	}
693	} else {
694	$con configure -font tkconfixed
695	}
696	set OPT(font) [$con cget -font]
697	bindtags $con [list $con TkConsole TkConsolePost $PRIV(root) all]
698
699	# scrollbar
700	if {!$PRIV(WWW)} {
701	if {[string match "Windows CE" $::tcl_platform(os)]} {
702	font configure tkconfixed -family Tahoma -size 8
703	$con configure -font tkconfixed -bd 0 -padx 0 -pady 0
704	set cw [font measure tkconfixed "0"]
705	set ch [font metrics tkconfixed -linespace]
706	set sw [winfo screenwidth $con]
707	set sh [winfo screenheight $con]
708	# We need the magic hard offsets until I find a way to
709	# correctly assume size
710	if {$cw*($OPT(cols)+2) > $sw} {
711	set OPT(cols) [expr {($sw / $cw) - 2}]
712	}
713	if {$ch*($OPT(rows)+3) > $sh} {
714	set OPT(rows) [expr {($sh / $ch) - 3}]
715	}
716	# Place it so that the titlebar underlaps the CE titlebar
717	wm geometry $PRIV(root) +0+0
718	}
719	}
720	$con configure -height $OPT(rows) -width $OPT(cols)
721
722	foreach col {prompt stdout stderr stdin proc} {
723	$con tag configure $col -foreground $COLOR($col)
724	}
725	$con tag configure var -background $COLOR(var)
726	$con tag raise sel
727	$con tag configure blink -background $COLOR(blink)
728	$con tag configure find -background $COLOR(blink)
729
730	set ATTACH($con) [Attach]
731	set rb [radiobutton $PRIV(tabframe).cb[winfo name $con] \
732	-textvariable ::tkcon::ATTACH($con) \
733	-selectcolor white -relief sunken \
734	-indicatoron 0 -padx 0 -pady 0 -bd 1 \
735	-variable ::tkcon::PRIV(curtab) -value $con \
736	-command [list ::tkcon::GotoTab $con]]
737	if {$::tcl_version >= 8.4} {
738	$rb configure -offrelief flat -overrelief raised
739	}
740	grid $rb -row 0 -column [lindex [grid size $PRIV(tabframe)] 0] -sticky ns
741	grid $con -row 1 -column 1 -sticky news
742
743	lappend PRIV(tabs) $con
744	return $con
745	}
746
747	proc ::tkcon::GotoTab {con} {
748	variable PRIV
749	variable ATTACH
750
751	set numtabs [llength $PRIV(tabs)]
752	#if {$numtabs == 1} { return }
753
754	if {[regexp {^[0-9]+$} $con]} {
755	set curtab [lsearch -exact $PRIV(tabs) $PRIV(console)]
756	set nexttab [expr {$curtab + $con}]
757	if {$nexttab >= $numtabs} {
758	set nexttab 0
759	} elseif {$nexttab < 0} {
760	set nexttab "end"
761	}
762	set con [lindex $PRIV(tabs) $nexttab]
763	} elseif {$con == $PRIV(console)} {
764	return
765	}
766
767	# adjust console
768	if {[winfo exists $PRIV(console)]} {
769	lower $PRIV(console)
770	$PRIV(console) configure -yscrollcommand {}
771	set ATTACH($PRIV(console)) [Attach]
772	}
773	set PRIV(console) $con
774	$con configure -yscrollcommand [list $PRIV(scrolly) set]
775	$PRIV(scrolly) configure -command [list $con yview]
776
777	# adjust attach
778	eval [linsert $ATTACH($con) 0 Attach]
779
780	set PRIV(curtab) $con
781
782	raise $con
783
784	if {[$con compare 1.0 == end-1c]} {
785	Prompt
786	}
787
788	# set StatusCursor
789	set PRIV(StatusCursor) [$con index insert]
790
791	focus -force $con
792	}
793
794	proc ::tkcon::NewTab {{con {}}} {
795	variable PRIV
796	variable ATTACH
797
798	set con [InitTab $PRIV(base)]
799	set slave [interp create Slave[GetSlaveNum]]
800	InitSlave $slave
801	$slave alias exit ::tkcon::DeleteTab $con $slave
802	set ATTACH($con) [list $slave slave]
803	$PRIV(X) configure -state normal
804	MenuConfigure Console "Delete Tab" -state normal
805	GotoTab $con
806	}
807
808	# The extra code arg is for the alias of exit to this function
809	proc ::tkcon::DeleteTab {{con {}} {slave {}} {code 0}} {
810	variable PRIV
811
812	set numtabs [llength $PRIV(tabs)]
813	if {$numtabs <= 2} {
814	$PRIV(X) configure -state disabled
815	MenuConfigure Console "Delete Tab" -state disabled
816	}
817	if {$numtabs == 1} {
818	# in the master, it should do the right thing
819	# currently the first master still exists - need rearch to fix
820	exit
821	# we might end up here, depending on how exit is rerouted
822	return
823	}
824
825	if {$con == ""} {
826	set con $PRIV(console)
827	}
828	catch {unset ATTACH($con)}
829	set curtab [lsearch -exact $PRIV(tabs) $con]
830	set PRIV(tabs) [lreplace $PRIV(tabs) $curtab $curtab]
831
832	set numtabs [llength $PRIV(tabs)]
833	set nexttab $curtab
834	if {$nexttab >= $numtabs} {
835	set nexttab end
836	}
837	set nexttab [lindex $PRIV(tabs) $nexttab]
838
839	GotoTab $nexttab
840
841	if {$slave != "" && $slave != $::tkcon::OPT(exec)} {
842	interp delete $slave
843	}
844	destroy $PRIV(tabframe).cb[winfo name $con]
845	destroy $con
846	}
847
848	## ::tkcon::GarbageCollect - do various cleanup ops periodically to our setup
849	##
850	proc ::tkcon::GarbageCollect {} {
851	variable OPT
852	variable PRIV
853
854	foreach w $PRIV(tabs) {
855	if {[winfo exists $w]} {
856	## Remove error tags that no longer span anything
857	## Make sure the tag pattern matches the unique tag prefix
858	foreach tag [$w tag names] {
859	if {[string match _tag* $tag]
860	&& ![llength [$w tag ranges $tag]]} {
861	$w tag delete $tag
862	}
863	}
864	}
865	}
866	if {$OPT(gc-delay)} {
867	after $OPT(gc-delay) ::tkcon::GarbageCollect
868	}
869	}
870
871	## ::tkcon::Eval - evaluates commands input into console window
872	## This is the first stage of the evaluating commands in the console.
873	## They need to be broken up into consituent commands (by ::tkcon::CmdSep) in
874	## case a multiple commands were pasted in, then each is eval'ed (by
875	## ::tkcon::EvalCmd) in turn. Any uncompleted command will not be eval'ed.
876	# ARGS: w - console text widget
877	# Calls: ::tkcon::CmdGet, ::tkcon::CmdSep, ::tkcon::EvalCmd
878	##
879	proc ::tkcon::Eval {w} {
880	set incomplete [CmdSep [CmdGet $w] cmds last]
881	$w mark set insert end-1c
882	$w insert end \n
883	if {[llength $cmds]} {
884	foreach c $cmds {EvalCmd $w $c}
885	$w insert insert $last {}
886	} elseif {!$incomplete} {
887	EvalCmd $w $last
888	}
889	if {[winfo exists $w]} {
890	$w see insert
891	}
892	}
893
894	## ::tkcon::EvalCmd - evaluates a single command, adding it to history
895	# ARGS: w - console text widget
896	# cmd - the command to evaluate
897	# Calls: ::tkcon::Prompt
898	# Outputs: result of command to stdout (or stderr if error occured)
899	# Returns: next event number
900	##
901	proc ::tkcon::EvalCmd {w cmd} {
902	variable OPT
903	variable PRIV
904
905	$w mark set output end
906	if {[string compare {} $cmd]} {
907	set code 0
908	if {$OPT(subhistory)} {
909	set ev [EvalSlave history nextid]
910	incr ev -1
911	## FIX: calcmode doesn't work with requesting history events
912	if {[string match !! $cmd]} {
913	set code [catch {EvalSlave history event $ev} cmd]
914	if {!$code} {$w insert output $cmd\n stdin}
915	} elseif {[regexp {^!(.+)$} $cmd dummy event]} {
916	## Check last event because history event is broken
917	set code [catch {EvalSlave history event $ev} cmd]
918	if {!$code && ![string match ${event}* $cmd]} {
919	set code [catch {EvalSlave history event $event} cmd]
920	}
921	if {!$code} {$w insert output $cmd\n stdin}
922	} elseif {[regexp {^\^([^^])\^([^^])\^?$} $cmd dummy old new]} {
923	set code [catch {EvalSlave history event $ev} cmd]
924	if {!$code} {
925	regsub -all -- $old $cmd $new cmd
926	$w insert output $cmd\n stdin
927	}
928	} elseif {$OPT(calcmode) && ![catch {expr $cmd} err]} {
929	AddSlaveHistory $cmd
930	set cmd $err
931	set code -1
932	}
933	}
934	if {$code} {
935	$w insert output $cmd\n stderr
936	} else {
937	## We are about to evaluate the command, so move the limit
938	## mark to ensure that further <Return>s don't cause double
939	## evaluation of this command - for cases like the command
940	## has a vwait or something in it
941	$w mark set limit end
942	if {$OPT(nontcl) && [string match interp $PRIV(apptype)]} {
943	set code [catch {EvalSend $cmd} res]
944	if {$code == 1} {
945	set PRIV(errorInfo) "Non-Tcl errorInfo not available"
946	}
947	} elseif {[string match socket $PRIV(apptype)]} {
948	set code [catch {EvalSocket $cmd} res]
949	if {$code == 1} {
950	set PRIV(errorInfo) "Socket-based errorInfo not available"
951	}
952	} else {
953	set code [catch {EvalAttached $cmd} res]
954	if {$code == 1} {
955	if {[catch {EvalAttached [list set errorInfo]} err]} {
956	set PRIV(errorInfo) "Error getting errorInfo:\n$err"
957	} else {
958	set PRIV(errorInfo) $err
959	}
960	}
961	}
962	if {![winfo exists $w]} {
963	# early abort - must be a deleted tab
964	return
965	}
966	AddSlaveHistory $cmd
967	catch {EvalAttached [list set _ $res]}
968	set maxlen $OPT(maxlinelen)
969	set trailer ""
970	if {($maxlen > 0) && ([string length $res] > $maxlen)} {
971	# If we exceed maximum desired output line length, truncate
972	# the result and add "...+${num}b" in error coloring
973	set trailer ...+[expr {[string length $res]-$maxlen}]b
974	set res [string range $res 0 $maxlen]
975	}
976	if {$code} {
977	if {$OPT(hoterrors)} {
978	set tag [UniqueTag $w]
979	$w insert output $res [list stderr $tag] \n$trailer stderr
980	$w tag bind $tag <Enter> \
981	[list $w tag configure $tag -under 1]
982	$w tag bind $tag <Leave> \
983	[list $w tag configure $tag -under 0]
984	$w tag bind $tag <ButtonRelease-1> \
985	"if {!\[info exists tkPriv(mouseMoved)\] \|\| !\$tkPriv(mouseMoved)} \
986	{[list $OPT(edit) -attach [Attach] -type error -- $PRIV(errorInfo)]}"
987	} else {
988	$w insert output $res\n$trailer stderr
989	}
990	} elseif {[string compare {} $res]} {
991	$w insert output $res stdout $trailer stderr \n stdout
992	}
993	}
994	}
995	Prompt
996	set PRIV(event) [EvalSlave history nextid]
997	}
998
999	## ::tkcon::EvalSlave - evaluates the args in the associated slave
1000	## args should be passed to this procedure like they would be at
1001	## the command line (not like to 'eval').
1002	# ARGS: args - the command and args to evaluate
1003	##
1004	proc ::tkcon::EvalSlave args {
1005	interp eval $::tkcon::OPT(exec) $args
1006	}
1007
1008	## ::tkcon::EvalOther - evaluate a command in a foreign interp or slave
1009	## without attaching to it. No check for existence is made.
1010	# ARGS: app - interp/slave name
1011	# type - (slave\|interp)
1012	##
1013	proc ::tkcon::EvalOther { app type args } {
1014	if {[string compare slave $type]==0} {
1015	return [Slave $app $args]
1016	} else {
1017	return [uplevel 1 ::send::send [list $app] $args]
1018	}
1019	}
1020
1021	## ::tkcon::AddSlaveHistory -
1022	## Command is added to history only if different from previous command.
1023	## This also doesn't cause the history id to be incremented, although the
1024	## command will be evaluated.
1025	# ARGS: cmd - command to add
1026	##
1027	proc ::tkcon::AddSlaveHistory cmd {
1028	set ev [EvalSlave history nextid]
1029	incr ev -1
1030	set code [catch {EvalSlave history event $ev} lastCmd]
1031	if {$code \|\| [string compare $cmd $lastCmd]} {
1032	EvalSlave history add $cmd
1033	}
1034	}
1035
1036	## ::tkcon::EvalSend - sends the args to the attached interpreter
1037	## Varies from 'send' by determining whether attachment is dead
1038	## when an error is received
1039	# ARGS: cmd - the command string to send across
1040	# Returns: the result of the command
1041	##
1042	proc ::tkcon::EvalSend cmd {
1043	variable OPT
1044	variable PRIV
1045
1046	if {$PRIV(deadapp)} {
1047	if {[lsearch -exact [::send::interps] $PRIV(app)]<0} {
1048	return
1049	} else {
1050	set PRIV(appname) [string range $PRIV(appname) 5 end]
1051	set PRIV(deadapp) 0
1052	Prompt "\n\"$PRIV(app)\" alive\n" [CmdGet $PRIV(console)]
1053	}
1054	}
1055	set code [catch {::send::send -displayof $PRIV(displayWin) $PRIV(app) $cmd} result]
1056	if {$code && [lsearch -exact [::send::interps] $PRIV(app)]<0} {
1057	## Interpreter disappeared
1058	if {[string compare leave $OPT(dead)] && \
1059	([string match ignore $OPT(dead)] \|\| \
1060	[tk_messageBox -title "Dead Attachment" -type yesno \
1061	-icon info -message \
1062	"\"$PRIV(app)\" appears to have died.\
1063	\nReturn to primary slave interpreter?"]=="no")} {
1064	set PRIV(appname) "DEAD:$PRIV(appname)"
1065	set PRIV(deadapp) 1
1066	} else {
1067	set err "Attached Tk interpreter \"$PRIV(app)\" died."
1068	Attach {}
1069	set PRIV(deadapp) 0
1070	EvalSlave set errorInfo $err
1071	}
1072	Prompt \n [CmdGet $PRIV(console)]
1073	}
1074	return -code $code $result
1075	}
1076
1077	## ::tkcon::EvalSocket - sends the string to an interpreter attached via
1078	## a tcp/ip socket
1079	##
1080	## In the EvalSocket case, ::tkcon::PRIV(app) is the socket id
1081	##
1082	## Must determine whether socket is dead when an error is received
1083	# ARGS: cmd - the data string to send across
1084	# Returns: the result of the command
1085	##
1086	proc ::tkcon::EvalSocket cmd {
1087	variable OPT
1088	variable PRIV
1089	global tcl_version
1090
1091	if {$PRIV(deadapp)} {
1092	if {![info exists PRIV(app)] \|\| \
1093	[catch {eof $PRIV(app)} eof] \|\| $eof} {
1094	return
1095	} else {
1096	set PRIV(appname) [string range $PRIV(appname) 5 end]
1097	set PRIV(deadapp) 0
1098	Prompt "\n\"$PRIV(app)\" alive\n" [CmdGet $PRIV(console)]
1099	}
1100	}
1101	# Sockets get \'s interpreted, so that users can
1102	# send things like \n\r or explicit hex values
1103	set cmd [subst -novariables -nocommands $cmd]
1104	#puts [list $PRIV(app) $cmd]
1105	set code [catch {puts $PRIV(app) $cmd ; flush $PRIV(app)} result]
1106	if {$code && [eof $PRIV(app)]} {
1107	## Interpreter died or disappeared
1108	puts "$code eof [eof $PRIV(app)]"
1109	EvalSocketClosed $PRIV(app)
1110	}
1111	return -code $code $result
1112	}
1113
1114	## ::tkcon::EvalSocketEvent - fileevent command for an interpreter attached
1115	## via a tcp/ip socket
1116	## Must determine whether socket is dead when an error is received
1117	# ARGS: args - the args to send across
1118	# Returns: the result of the command
1119	##
1120	proc ::tkcon::EvalSocketEvent {sock} {
1121	variable PRIV
1122
1123	if {[gets $sock line] == -1} {
1124	if {[eof $sock]} {
1125	EvalSocketClosed $sock
1126	}
1127	return
1128	}
1129	puts $line
1130	}
1131
1132	## ::tkcon::EvalSocketClosed - takes care of handling a closed eval socket
1133	##
1134	# ARGS: args - the args to send across
1135	# Returns: the result of the command
1136	##
1137	proc ::tkcon::EvalSocketClosed {sock} {
1138	variable OPT
1139	variable PRIV
1140
1141	catch {close $sock}
1142	if {![string match $sock $PRIV(app)]} {
1143	# If we are not still attached to that socket, just return.
1144	# Might be nice to tell the user the socket closed ...
1145	return
1146	}
1147	if {[string compare leave $OPT(dead)] && \
1148	([string match ignore $OPT(dead)] \|\| \
1149	[tk_messageBox -title "Dead Attachment" -type yesno \
1150	-icon question \
1151	-message "\"$PRIV(app)\" appears to have died.\
1152	\nReturn to primary slave interpreter?"] == "no")} {
1153	set PRIV(appname) "DEAD:$PRIV(appname)"
1154	set PRIV(deadapp) 1
1155	} else {
1156	set err "Attached Tk interpreter \"$PRIV(app)\" died."
1157	Attach {}
1158	set PRIV(deadapp) 0
1159	EvalSlave set errorInfo $err
1160	}
1161	Prompt \n [CmdGet $PRIV(console)]
1162	}
1163
1164	## ::tkcon::EvalNamespace - evaluates the args in a particular namespace
1165	## This is an override for ::tkcon::EvalAttached for when the user wants
1166	## to attach to a particular namespace of the attached interp
1167	# ARGS: attached
1168	# namespace the namespace to evaluate in
1169	# args the args to evaluate
1170	# RETURNS: the result of the command
1171	##
1172	proc ::tkcon::EvalNamespace { attached namespace args } {
1173	if {[llength $args]} {
1174	uplevel \#0 $attached \
1175	[list [concat [list namespace eval $namespace] $args]]
1176	}
1177	}
1178
1179
1180	## ::tkcon::Namespaces - return all the namespaces descendent from $ns
1181	##
1182	#
1183	##
1184	proc ::tkcon::Namespaces {{ns ::} {l {}}} {
1185	if {[string compare {} $ns]} { lappend l $ns }
1186	foreach i [EvalAttached [list namespace children $ns]] {
1187	set l [Namespaces $i $l]
1188	}
1189	return $l
1190	}
1191
1192	## ::tkcon::CmdGet - gets the current command from the console widget
1193	# ARGS: w - console text widget
1194	# Returns: text which compromises current command line
1195	##
1196	proc ::tkcon::CmdGet w {
1197	if {![llength [$w tag nextrange prompt limit end]]} {
1198	$w tag add stdin limit end-1c
1199	return [$w get limit end-1c]
1200	}
1201	}
1202
1203	## ::tkcon::CmdSep - separates multiple commands into a list and remainder
1204	# ARGS: cmd - (possible) multiple command to separate
1205	# list - varname for the list of commands that were separated.
1206	# last - varname of any remainder (like an incomplete final command).
1207	# If there is only one command, it's placed in this var.
1208	# Returns: constituent command info in varnames specified by list & rmd.
1209	##
1210	proc ::tkcon::CmdSep {cmd list last} {
1211	upvar 1 $list cmds $last inc
1212	set inc {}
1213	set cmds {}
1214	foreach c [split [string trimleft $cmd] \n] {
1215	if {[string compare $inc {}]} {
1216	append inc \n$c
1217	} else {
1218	append inc [string trimleft $c]
1219	}
1220	if {[info complete $inc] && ![regexp {[^\\]\\$} $inc]} {
1221	if {[regexp "^\[^#\]" $inc]} {lappend cmds $inc}
1222	set inc {}
1223	}
1224	}
1225	set i [string compare $inc {}]
1226	if {!$i && [string compare $cmds {}] && ![string match *\n $cmd]} {
1227	set inc [lindex $cmds end]
1228	set cmds [lreplace $cmds end end]
1229	}
1230	return $i
1231	}
1232
1233	## ::tkcon::CmdSplit - splits multiple commands into a list
1234	# ARGS: cmd - (possible) multiple command to separate
1235	# Returns: constituent commands in a list
1236	##
1237	proc ::tkcon::CmdSplit {cmd} {
1238	set inc {}
1239	set cmds {}
1240	foreach cmd [split [string trimleft $cmd] \n] {
1241	if {[string compare {} $inc]} {
1242	append inc \n$cmd
1243	} else {
1244	append inc [string trimleft $cmd]
1245	}
1246	if {[info complete $inc] && ![regexp {[^\\]\\$} $inc]} {
1247	#set inc [string trimright $inc]
1248	if {[regexp "^\[^#\]" $inc]} {lappend cmds $inc}
1249	set inc {}
1250	}
1251	}
1252	if {[regexp "^\[^#\]" $inc]} {lappend cmds $inc}
1253	return $cmds
1254	}
1255
1256	## ::tkcon::UniqueTag - creates a uniquely named tag, reusing names
1257	## Called by ::tkcon::EvalCmd
1258	# ARGS: w - text widget
1259	# Outputs: tag name guaranteed unique in the widget
1260	##
1261	proc ::tkcon::UniqueTag {w} {
1262	set tags [$w tag names]
1263	set idx 0
1264	while {[lsearch -exact $tags _tag[incr idx]] != -1} {}
1265	return _tag$idx
1266	}
1267
1268	## ::tkcon::ConstrainBuffer - This limits the amount of data in the text widget
1269	## Called by ::tkcon::Prompt and in tkcon proc buffer/console switch cases
1270	# ARGS: w - console text widget
1271	# size - # of lines to constrain to
1272	# Outputs: may delete data in console widget
1273	##
1274	proc ::tkcon::ConstrainBuffer {w size} {
1275	if {$size && ([$w index end] > $size)} {
1276	$w delete 1.0 [expr {int([$w index end])-$size}].0
1277	}
1278	}
1279
1280	## ::tkcon::Prompt - displays the prompt in the console widget
1281	# ARGS: w - console text widget
1282	# Outputs: prompt (specified in ::tkcon::OPT(prompt1)) to console
1283	##
1284	proc ::tkcon::Prompt {{pre {}} {post {}} {prompt {}}} {
1285	variable OPT
1286	variable PRIV
1287
1288	set w $PRIV(console)
1289	if {![winfo exists $w]} { return }
1290	if {[string compare {} $pre]} { $w insert end $pre stdout }
1291	set i [$w index end-1c]
1292	if {!$OPT(showstatusbar)} {
1293	if {[string compare {} $PRIV(appname)]} {
1294	$w insert end ">$PRIV(appname)< " prompt
1295	}
1296	if {[string compare :: $PRIV(namesp)]} {
1297	$w insert end "<$PRIV(namesp)> " prompt
1298	}
1299	}
1300	if {[string compare {} $prompt]} {
1301	$w insert end $prompt prompt
1302	} else {
1303	$w insert end [EvalSlave subst $OPT(prompt1)] prompt
1304	}
1305	$w mark set output $i
1306	$w mark set insert end
1307	$w mark set limit insert
1308	$w mark gravity limit left
1309	if {[string compare {} $post]} { $w insert end $post stdin }
1310	ConstrainBuffer $w $OPT(buffer)
1311	set ::tkcon::PRIV(StatusCursor) [$w index insert]
1312	$w see end
1313	}
1314	proc ::tkcon::RePrompt {{pre {}} {post {}} {prompt {}}} {
1315	# same as prompt, but does nothing for those actions where we
1316	# only wanted to refresh the prompt on attach change when the
1317	# statusbar is showing (which carries that info instead)
1318	variable OPT
1319	if {!$OPT(showstatusbar)} {
1320	Prompt $pre $post $prompt
1321	}
1322	}
1323
1324	## ::tkcon::About - gives about info for tkcon
1325	##
1326	proc ::tkcon::About {} {
1327	variable OPT
1328	variable PRIV
1329	variable COLOR
1330
1331	set w $PRIV(base).about
1332	if {![winfo exists $w]} {
1333	global tk_patchLevel tcl_patchLevel tcl_version
1334	toplevel $w
1335	wm withdraw $w
1336	wm transient $w $PRIV(root)
1337	wm group $w $PRIV(root)
1338	wm title $w "About tkcon v$PRIV(version)"
1339	button $w.b -text Dismiss -command [list wm withdraw $w]
1340	text $w.text -height 9 -bd 1 -width 60 \
1341	-foreground $COLOR(stdin) \
1342	-background $COLOR(bg) \
1343	-font $OPT(font)
1344	pack $w.b -fill x -side bottom
1345	pack $w.text -fill both -side left -expand 1
1346	$w.text tag config center -justify center
1347	$w.text tag config title -justify center -font {Courier -18 bold}
1348	# strip down the RCS info displayed in the about box
1349	regexp {,v ([0-9\./: ]*)} $PRIV(RCS) -> RCS
1350	$w.text insert 1.0 "About tkcon v$PRIV(version)" title \
1351	"\n\nCopyright 1995-2002 Jeffrey Hobbs, $PRIV(email)\
1352	\nRelease Info: v$PRIV(version), CVS v$RCS\
1353	\nDocumentation available at:\n$PRIV(docs)\
1354	\nUsing: Tcl v$tcl_patchLevel / Tk v$tk_patchLevel" center
1355	$w.text config -state disabled
1356	bind $w <Escape> [list destroy $w]
1357	}
1358	wm deiconify $w
1359	}
1360
1361	## ::tkcon::InitMenus - inits the menubar and popup for the console
1362	# ARGS: w - console text widget
1363	##
1364	proc ::tkcon::InitMenus {w title} {
1365	variable OPT
1366	variable PRIV
1367	variable COLOR
1368	global tcl_platform
1369
1370	if {[catch {menu $w.pop}]} {
1371	label $w.label -text "Menus not available in plugin mode"
1372	grid $w.label -sticky ew
1373	return
1374	}
1375	menu $w.context -disabledforeground $COLOR(disabled)
1376	set PRIV(context) $w.context
1377	set PRIV(popup) $w.pop
1378
1379	proc MenuButton {w m l} {
1380	$w add cascade -label $m -underline 0 -menu $w.$l
1381	return $w.$l
1382	}
1383	proc MenuConfigure {m l args} {
1384	variable PRIV
1385	eval [list $PRIV(menubar).[string tolower $m] entryconfigure $l] $args
1386	eval [list $PRIV(popup).[string tolower $m] entryconfigure $l] $args
1387	}
1388
1389	foreach m [list File Console Edit Interp Prefs History Help] {
1390	set l [string tolower $m]
1391	MenuButton $w $m $l
1392	$w.pop add cascade -label $m -underline 0 -menu $w.pop.$l
1393	}
1394
1395	## File Menu
1396	##
1397	foreach m [list [menu $w.file -disabledforeground $COLOR(disabled)] \
1398	[menu $w.pop.file -disabledforeground $COLOR(disabled)]] {
1399	$m add command -label "Load File" -underline 0 -command ::tkcon::Load
1400	$m add cascade -label "Save ..." -underline 0 -menu $m.save
1401	$m add separator
1402	$m add command -label "Quit" -underline 0 -accel Ctrl-q -command exit
1403
1404	## Save Menu
1405	##
1406	set s $m.save
1407	menu $s -disabledforeground $COLOR(disabled)
1408	$s add command -label "All" -underline 0 \
1409	-command {::tkcon::Save {} all}
1410	$s add command -label "History" -underline 0 \
1411	-command {::tkcon::Save {} history}
1412	$s add command -label "Stdin" -underline 3 \
1413	-command {::tkcon::Save {} stdin}
1414	$s add command -label "Stdout" -underline 3 \
1415	-command {::tkcon::Save {} stdout}
1416	$s add command -label "Stderr" -underline 3 \
1417	-command {::tkcon::Save {} stderr}
1418	}
1419
1420	## Console Menu
1421	##
1422	foreach m [list [menu $w.console -disabledfore $COLOR(disabled)] \
1423	[menu $w.pop.console -disabledfore $COLOR(disabled)]] {
1424	$m add command -label "$title Console" -state disabled
1425	$m add command -label "New Console" -underline 0 -accel Ctrl-N \
1426	-command ::tkcon::New
1427	$m add command -label "New Tab" -underline 4 -accel Ctrl-T \
1428	-command ::tkcon::NewTab
1429	$m add command -label "Delete Tab" -underline 0 \
1430	-command ::tkcon::DeleteTab -state disabled
1431	$m add command -label "Close Console" -underline 0 -accel Ctrl-w \
1432	-command ::tkcon::Destroy
1433	$m add command -label "Clear Console" -underline 1 -accel Ctrl-l \
1434	-command { clear; ::tkcon::Prompt }
1435	if {[string match unix $tcl_platform(platform)]} {
1436	$m add separator
1437	$m add command -label "Make Xauth Secure" -und 5 \
1438	-command ::tkcon::XauthSecure
1439	}
1440	$m add separator
1441	$m add cascade -label "Attach To ..." -underline 0 -menu $m.attach
1442
1443	## Attach Console Menu
1444	##
1445	set sub [menu $m.attach -disabledforeground $COLOR(disabled)]
1446	$sub add cascade -label "Interpreter" -underline 0 -menu $sub.apps
1447	$sub add cascade -label "Namespace" -underline 0 -menu $sub.name
1448
1449	## Attach Console Menu
1450	##
1451	menu $sub.apps -disabledforeground $COLOR(disabled) \
1452	-postcommand [list ::tkcon::AttachMenu $sub.apps]
1453
1454	## Attach Namespace Menu
1455	##
1456	menu $sub.name -disabledforeground $COLOR(disabled) \
1457	-postcommand [list ::tkcon::NamespaceMenu $sub.name]
1458
1459	if {$::tcl_version >= 8.3} {
1460	## Attach Socket Menu
1461	##
1462	# This uses [file channels] to create the menu, so we only
1463	# want it for newer versions of Tcl.
1464	$sub add cascade -label "Socket" -underline 0 -menu $sub.sock
1465	menu $sub.sock -disabledforeground $COLOR(disabled) \
1466	-postcommand [list ::tkcon::SocketMenu $sub.sock]
1467	}
1468
1469	if {![string compare "unix" $tcl_platform(platform)]} {
1470	## Attach Display Menu
1471	##
1472	$sub add cascade -label "Display" -underline 0 -menu $sub.disp
1473	menu $sub.disp -disabledforeground $COLOR(disabled) \
1474	-postcommand [list ::tkcon::DisplayMenu $sub.disp]
1475	}
1476	}
1477
1478	## Edit Menu
1479	##
1480	set text $PRIV(console)
1481	foreach m [list [menu $w.edit] [menu $w.pop.edit]] {
1482	$m add command -label "Cut" -underline 2 -accel Ctrl-x \
1483	-command [list ::tkcon::Cut $text]
1484	$m add command -label "Copy" -underline 0 -accel Ctrl-c \
1485	-command [list ::tkcon::Copy $text]
1486	$m add command -label "Paste" -underline 0 -accel Ctrl-v \
1487	-command [list ::tkcon::Paste $text]
1488	$m add separator
1489	$m add command -label "Find" -underline 0 -accel Ctrl-F \
1490	-command [list ::tkcon::FindBox $text]
1491	}
1492
1493	## Interp Menu
1494	##
1495	foreach m [list $w.interp $w.pop.interp] {
1496	menu $m -disabledforeground $COLOR(disabled) \
1497	-postcommand [list ::tkcon::InterpMenu $m]
1498	}
1499
1500	## Prefs Menu
1501	##
1502	foreach m [list [menu $w.prefs] [menu $w.pop.prefs]] {
1503	$m add check -label "Brace Highlighting" \
1504	-underline 0 -variable ::tkcon::OPT(lightbrace)
1505	$m add check -label "Command Highlighting" \
1506	-underline 0 -variable ::tkcon::OPT(lightcmd)
1507	$m add check -label "History Substitution" \
1508	-underline 0 -variable ::tkcon::OPT(subhistory)
1509	$m add check -label "Hot Errors" \
1510	-underline 4 -variable ::tkcon::OPT(hoterrors)
1511	$m add check -label "Non-Tcl Attachments" \
1512	-underline 0 -variable ::tkcon::OPT(nontcl)
1513	$m add check -label "Calculator Mode" \
1514	-underline 1 -variable ::tkcon::OPT(calcmode)
1515	$m add check -label "Show Multiple Matches" \
1516	-underline 0 -variable ::tkcon::OPT(showmultiple)
1517	$m add check -label "Show Menubar" \
1518	-underline 5 -variable ::tkcon::OPT(showmenu) \
1519	-command {$::tkcon::PRIV(root) configure -menu [expr \
1520	{$::tkcon::OPT(showmenu) ? $::tkcon::PRIV(menubar) : {}}]}
1521	$m add check -label "Show Statusbar" \
1522	-underline 5 -variable ::tkcon::OPT(showstatusbar) \
1523	-command {
1524	if {$::tkcon::OPT(showstatusbar)} {
1525	grid $::tkcon::PRIV(statusbar)
1526	} else { grid remove $::tkcon::PRIV(statusbar) }
1527	}
1528	$m add cascade -label "Scrollbar" -underline 2 -menu $m.scroll
1529
1530	## Scrollbar Menu
1531	##
1532	set m [menu $m.scroll]
1533	$m add radio -label "Left" -value left \
1534	-variable ::tkcon::OPT(scrollypos) \
1535	-command { grid configure $::tkcon::PRIV(scrolly) -column 0 }
1536	$m add radio -label "Right" -value right \
1537	-variable ::tkcon::OPT(scrollypos) \
1538	-command { grid configure $::tkcon::PRIV(scrolly) -column 2 }
1539	}
1540
1541	## History Menu
1542	##
1543	foreach m [list $w.history $w.pop.history] {
1544	menu $m -disabledforeground $COLOR(disabled) \
1545	-postcommand [list ::tkcon::HistoryMenu $m]
1546	}
1547
1548	## Help Menu
1549	##
1550	foreach m [list [menu $w.help] [menu $w.pop.help]] {
1551	$m add command -label "About " -underline 0 -accel Ctrl-A \
1552	-command ::tkcon::About
1553	$m add command -label "Retrieve Latest Version" -underline 0 \
1554	-command ::tkcon::Retrieve
1555	if {![catch {package require ActiveTcl} ver]} {
1556	set cmd ""
1557	if {$tcl_platform(platform) == "windows"} {
1558	package require registry
1559	set ver [join [lrange [split $ver .] 0 3] .]
1560	set key {HKEY_LOCAL_MACHINE\SOFTWARE\ActiveState\ActiveTcl}
1561	if {![catch {registry get "$key\\$ver\\Help" ""} help]
1562	&& [file exists $help]} {
1563	set cmd [list exec $::env(COMSPEC) /c start $help]
1564	}
1565	} elseif {$tcl_platform(os) == "Darwin"} {
1566	set ver ActiveTcl-[join [lrange [split $ver .] 0 1] .]
1567	set rsc "/Library/Frameworks/Tcl.framework/Resources"
1568	set help "$rsc/English.lproj/$ver/index.html"
1569	if {[file exists $help]} {
1570	set cmd [list exec open $help]
1571	}
1572	} elseif {$tcl_platform(platform) == "unix"} {
1573	set help [file dirname [info nameofexe]]
1574	append help /../html/index.html
1575	if {[file exists $help]} {
1576	set cmd [list puts "Start $help"]
1577	}
1578	}
1579	if {$cmd != ""} {
1580	$m add separator
1581	$m add command -label "ActiveTcl Help" -underline 10 \
1582	-command $cmd
1583	}
1584	}
1585	}
1586	}
1587
1588	## ::tkcon::HistoryMenu - dynamically build the menu for attached interpreters
1589	##
1590	# ARGS: m - menu widget
1591	##
1592	proc ::tkcon::HistoryMenu m {
1593	variable PRIV
1594
1595	if {![winfo exists $m]} return
1596	set id [EvalSlave history nextid]
1597	if {$PRIV(histid)==$id} return
1598	set PRIV(histid) $id
1599	$m delete 0 end
1600	while {($id>1) && ($id>$PRIV(histid)-10) && \
1601	![catch {EvalSlave history event [incr id -1]} tmp]} {
1602	set lbl $tmp
1603	if {[string len $lbl]>32} { set lbl [string range $tmp 0 28]... }
1604	$m add command -label "$id: $lbl" -command "
1605	$::tkcon::PRIV(console) delete limit end
1606	$::tkcon::PRIV(console) insert limit [list $tmp]
1607	$::tkcon::PRIV(console) see end
1608	::tkcon::Eval $::tkcon::PRIV(console)"
1609	}
1610	}
1611
1612	## ::tkcon::InterpMenu - dynamically build the menu for attached interpreters
1613	##
1614	# ARGS: w - menu widget
1615	##
1616	proc ::tkcon::InterpMenu w {
1617	variable OPT
1618	variable PRIV
1619	variable COLOR
1620
1621	if {![winfo exists $w]} return
1622	$w delete 0 end
1623	foreach {app type} [Attach] break
1624	$w add command -label "[string toupper $type]: $app" -state disabled
1625	if {($OPT(nontcl) && [string match interp $type]) \|\| $PRIV(deadapp)} {
1626	$w add separator
1627	$w add command -state disabled -label "Communication disabled to"
1628	$w add command -state disabled -label "dead or non-Tcl interps"
1629	return
1630	}
1631
1632	## Show Last Error
1633	##
1634	$w add separator
1635	$w add command -label "Show Last Error" \
1636	-command [list tkcon error $app $type]
1637
1638	## Packages Cascaded Menu
1639	##
1640	$w add separator
1641	$w add command -label "Manage Packages" -underline 0 \
1642	-command [list ::tkcon::InterpPkgs $app $type]
1643
1644	## State Checkpoint/Revert
1645	##
1646	$w add separator
1647	$w add command -label "Checkpoint State" \
1648	-command [list ::tkcon::StateCheckpoint $app $type]
1649	$w add command -label "Revert State" \
1650	-command [list ::tkcon::StateRevert $app $type]
1651	$w add command -label "View State Change" \
1652	-command [list ::tkcon::StateCompare $app $type]
1653
1654	## Init Interp
1655	##
1656	$w add separator
1657	$w add command -label "Send tkcon Commands" \
1658	-command [list ::tkcon::InitInterp $app $type]
1659	}
1660
1661	## ::tkcon::PkgMenu - fill in in the applications sub-menu
1662	## with a list of all the applications that currently exist.
1663	##
1664	proc ::tkcon::InterpPkgs {app type} {
1665	variable PRIV
1666
1667	set t $PRIV(base).interppkgs
1668	if {![winfo exists $t]} {
1669	toplevel $t
1670	wm withdraw $t
1671	wm title $t "$app Packages"
1672	wm transient $t $PRIV(root)
1673	wm group $t $PRIV(root)
1674	bind $t <Escape> [list destroy $t]
1675
1676	label $t.ll -text "Loadable:" -anchor w
1677	label $t.lr -text "Loaded:" -anchor w
1678	listbox $t.loadable -bg white -bd 1 -font tkconfixed \
1679	-yscrollcommand [list $t.llsy set] -selectmode extended
1680	listbox $t.loaded -bg white -bd 1 -font tkconfixed \
1681	-yscrollcommand [list $t.lrsy set]
1682	scrollbar $t.llsy -bd 1 -command [list $t.loadable yview]
1683	scrollbar $t.lrsy -bd 1 -command [list $t.loaded yview]
1684	button $t.load -bd 1 -text ">>" \
1685	-command [list ::tkcon::InterpPkgLoad $app $type $t.loadable]
1686	if {$::tcl_version >= 8.4} {
1687	$t.load configure -relief flat -overrelief raised
1688	}
1689
1690	set f [frame $t.btns]
1691	button $f.refresh -width 8 -text "Refresh" -command [info level 0]
1692	button $f.dismiss -width 8 -text "Dismiss" -command [list destroy $t]
1693	grid $f.refresh $f.dismiss -padx 4 -pady 3 -sticky ew
1694
1695	grid $t.ll x x $t.lr x -sticky ew
1696	grid $t.loadable $t.llsy $t.load $t.loaded $t.lrsy -sticky news
1697	grid $t.btns -sticky e -columnspan 5
1698	grid columnconfigure $t {0 3} -weight 1
1699	grid rowconfigure $t 1 -weight 1
1700	grid configure $t.load -sticky ""
1701
1702	bind $t.loadable <Double-1> "[list $t.load invoke]; break"
1703	}
1704	$t.loaded delete 0 end
1705	$t.loadable delete 0 end
1706
1707	# just in case stuff has been added to the auto_path
1708	# we have to make sure that the errorInfo doesn't get screwed up
1709	EvalAttached {
1710	set __tkcon_error $errorInfo
1711	catch {package require bogus-package-name}
1712	set errorInfo ${__tkcon_error}
1713	unset __tkcon_error
1714	}
1715	# get all packages loaded into current interp
1716	foreach pkg [EvalAttached [list info loaded {}]] {
1717	set pkg [lindex $pkg 1]
1718	set loaded($pkg) [package provide $pkg]
1719	}
1720	# get all package names currently visible
1721	foreach pkg [lremove [EvalAttached {package names}] Tcl] {
1722	set version [EvalAttached [list package provide $pkg]]
1723	if {[string compare {} $version]} {
1724	set loaded($pkg) $version
1725	} elseif {![info exists loaded($pkg)]} {
1726	set loadable($pkg) package
1727	}
1728	}
1729	# get packages that are loaded in any interp
1730	foreach pkg [EvalAttached {info loaded}] {
1731	set pkg [lindex $pkg 1]
1732	if {![info exists loaded($pkg)] && ![info exists loadable($pkg)]} {
1733	set loadable($pkg) load
1734	}
1735	}
1736	foreach pkg [lsort -dictionary [array names loadable]] {
1737	foreach v [EvalAttached [list package version $pkg]] {
1738	$t.loadable insert end [list $pkg $v "($loadable($pkg))"]
1739	}
1740	}
1741	foreach pkg [lsort -dictionary [array names loaded]] {
1742	$t.loaded insert end [list $pkg $loaded($pkg)]
1743	}
1744
1745	wm deiconify $t
1746	raise $t
1747	}
1748
1749	proc ::tkcon::InterpPkgLoad {app type lb} {
1750	# load the lb entry items into the interp
1751	foreach sel [$lb curselection] {
1752	foreach {pkg ver method} [$lb get $sel] { break }
1753	if {$method == "(package)"} {
1754	set code [catch {::tkcon::EvalOther $app $type \
1755	package require $pkg $ver} msg]
1756	} elseif {$method == "(load)"} {
1757	set code [catch {::tkcon::EvalOther $app $type load {} $pkg} msg]
1758	} else {
1759	set code 1
1760	set msg "Incorrect entry in Loadable selection"
1761	}
1762	if {$code} {
1763	tk_messageBox -icon error -title "Error requiring $pkg" -type ok \
1764	-message "Error requiring $pkg $ver:\n$msg\n$::errorInfo"
1765	}
1766	}
1767	# refresh package list
1768	InterpPkgs $app $type
1769	}
1770
1771	## ::tkcon::AttachMenu - fill in in the applications sub-menu
1772	## with a list of all the applications that currently exist.
1773	##
1774	proc ::tkcon::AttachMenu m {
1775	variable OPT
1776	variable PRIV
1777
1778	array set interps [set tmp [Interps]]
1779	foreach {i j} $tmp { set tknames($j) {} }
1780
1781	$m delete 0 end
1782	set cmd {::tkcon::RePrompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]}
1783	$m add radio -label {None (use local slave) } -accel Ctrl-1 \
1784	-variable ::tkcon::PRIV(app) \
1785	-value [concat $::tkcon::PRIV(name) $::tkcon::OPT(exec)] \
1786	-command "::tkcon::Attach {}; $cmd"
1787	$m add separator
1788	$m add command -label "Foreign Tk Interpreters" -state disabled
1789	foreach i [lsort [lremove [::send::interps] [array names tknames]]] {
1790	$m add radio -label $i -variable ::tkcon::PRIV(app) -value $i \
1791	-command "::tkcon::Attach [list $i] interp; $cmd"
1792	}
1793	$m add separator
1794
1795	$m add command -label "tkcon Interpreters" -state disabled
1796	foreach i [lsort [array names interps]] {
1797	if {[string match {} $interps($i)]} { set interps($i) "no Tk" }
1798	if {[regexp {^Slave[0-9]+} $i]} {
1799	set opts [list -label "$i ($interps($i))" \
1800	-variable ::tkcon::PRIV(app) -value $i \
1801	-command "::tkcon::Attach [list $i] slave; $cmd"]
1802	if {[string match $PRIV(name) $i]} {
1803	append opts " -accel Ctrl-2"
1804	}
1805	eval $m add radio $opts
1806	} else {
1807	set name [concat Main $i]
1808	if {[string match Main $name]} {
1809	$m add radio -label "$name ($interps($i))" -accel Ctrl-3 \
1810	-variable ::tkcon::PRIV(app) -value Main \
1811	-command "::tkcon::Attach [list $name] slave; $cmd"
1812	} else {
1813	$m add radio -label "$name ($interps($i))" \
1814	-variable ::tkcon::PRIV(app) -value $i \
1815	-command "::tkcon::Attach [list $name] slave; $cmd"
1816	}
1817	}
1818	}
1819	}
1820
1821	## Displays Cascaded Menu
1822	##
1823	proc ::tkcon::DisplayMenu m {
1824	$m delete 0 end
1825	set cmd {::tkcon::RePrompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]}
1826
1827	$m add command -label "New Display" -command ::tkcon::NewDisplay
1828	foreach disp [Display] {
1829	$m add separator
1830	$m add command -label $disp -state disabled
1831	set res [Display $disp]
1832	set win [lindex $res 0]
1833	foreach i [lsort [lindex $res 1]] {
1834	$m add radio -label $i -variable ::tkcon::PRIV(app) -value $i \
1835	-command "::tkcon::Attach [list $i] [list dpy:$win]; $cmd"
1836	}
1837	}
1838	}
1839
1840	## Sockets Cascaded Menu
1841	##
1842	proc ::tkcon::SocketMenu m {
1843	$m delete 0 end
1844	set cmd {::tkcon::RePrompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]}
1845
1846	$m add command -label "Create Connection" \
1847	-command "::tkcon::NewSocket; $cmd"
1848	foreach sock [file channels sock*] {
1849	$m add radio -label $sock -variable ::tkcon::PRIV(app) -value $sock \
1850	-command "::tkcon::Attach $sock socket; $cmd"
1851	}
1852	}
1853
1854	## Namepaces Cascaded Menu
1855	##
1856	proc ::tkcon::NamespaceMenu m {
1857	variable PRIV
1858	variable OPT
1859
1860	$m delete 0 end
1861	if {($PRIV(deadapp) \|\| [string match socket $PRIV(apptype)] \|\| \
1862	($OPT(nontcl) && [string match interp $PRIV(apptype)]))} {
1863	$m add command -label "No Namespaces" -state disabled
1864	return
1865	}
1866
1867	## Same command as for ::tkcon::AttachMenu items
1868	set cmd {::tkcon::RePrompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]}
1869
1870	set names [lsort [Namespaces ::]]
1871	if {[llength $names] > $OPT(maxmenu)} {
1872	$m add command -label "Attached to $PRIV(namesp)" -state disabled
1873	$m add command -label "List Namespaces" \
1874	-command [list ::tkcon::NamespacesList $names]
1875	} else {
1876	foreach i $names {
1877	if {[string match :: $i]} {
1878	$m add radio -label "Main" -value $i \
1879	-variable ::tkcon::PRIV(namesp) \
1880	-command "::tkcon::AttachNamespace [list $i]; $cmd"
1881	} else {
1882	$m add radio -label $i -value $i \
1883	-variable ::tkcon::PRIV(namesp) \
1884	-command "::tkcon::AttachNamespace [list $i]; $cmd"
1885	}
1886	}
1887	}
1888	}
1889
1890	## Namepaces List
1891	##
1892	proc ::tkcon::NamespacesList {names} {
1893	variable PRIV
1894
1895	set f $PRIV(base).namespaces
1896	catch {destroy $f}
1897	toplevel $f
1898	listbox $f.names -width 30 -height 15 -selectmode single \
1899	-yscrollcommand [list $f.scrollv set] \
1900	-xscrollcommand [list $f.scrollh set]
1901	scrollbar $f.scrollv -command [list $f.names yview]
1902	scrollbar $f.scrollh -command [list $f.names xview] -orient horizontal
1903	frame $f.buttons
1904	button $f.cancel -text "Cancel" -command [list destroy $f]
1905
1906	grid $f.names $f.scrollv -sticky nesw
1907	grid $f.scrollh -sticky ew
1908	grid $f.buttons -sticky nesw
1909	grid $f.cancel -in $f.buttons -pady 6
1910
1911	grid columnconfigure $f 0 -weight 1
1912	grid rowconfigure $f 0 -weight 1
1913	#fill the listbox
1914	foreach i $names {
1915	if {[string match :: $i]} {
1916	$f.names insert 0 Main
1917	} else {
1918	$f.names insert end $i
1919	}
1920	}
1921	#Bindings
1922	bind $f.names <Double-1> {
1923	## Catch in case the namespace disappeared on us
1924	catch { ::tkcon::AttachNamespace [%W get [%W nearest %y]] }
1925	::tkcon::RePrompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)]
1926	destroy [winfo toplevel %W]
1927	}
1928	}
1929
1930	# ::tkcon::XauthSecure --
1931	#
1932	# This removes all the names in the xhost list, and secures
1933	# the display for Tk send commands. Of course, this prevents
1934	# what might have been otherwise allowable X connections
1935	#
1936	# Arguments:
1937	# none
1938	# Results:
1939	# Returns nothing
1940	#
1941	proc ::tkcon::XauthSecure {} {
1942	global tcl_platform
1943
1944	if {[string compare unix $tcl_platform(platform)]} {
1945	# This makes no sense outside of Unix
1946	return
1947	}
1948	set hosts [exec xhost]
1949	# the first line is info only
1950	foreach host [lrange [split $hosts \n] 1 end] {
1951	exec xhost -$host
1952	}
1953	exec xhost -
1954	tk_messageBox -title "Xhost secured" -message "Xhost secured" -icon info
1955	}
1956
1957	## ::tkcon::FindBox - creates minimal dialog interface to ::tkcon::Find
1958	# ARGS: w - text widget
1959	# str - optional seed string for ::tkcon::PRIV(find)
1960	##
1961	proc ::tkcon::FindBox {w {str {}}} {
1962	variable PRIV
1963
1964	set base $PRIV(base).find
1965	if {![winfo exists $base]} {
1966	toplevel $base
1967	wm withdraw $base
1968	wm title $base "tkcon Find"
1969
1970	pack [frame $base.f] -fill x -expand 1
1971	label $base.f.l -text "Find:"
1972	entry $base.f.e -textvariable ::tkcon::PRIV(find)
1973	pack [frame $base.opt] -fill x
1974	checkbutton $base.opt.c -text "Case Sensitive" \
1975	-variable ::tkcon::PRIV(find,case)
1976	checkbutton $base.opt.r -text "Use Regexp" -variable ::tkcon::PRIV(find,reg)
1977	pack $base.f.l -side left
1978	pack $base.f.e $base.opt.c $base.opt.r -side left -fill both -expand 1
1979	pack [frame $base.sep -bd 2 -relief sunken -height 4] -fill x
1980	pack [frame $base.btn] -fill both
1981	button $base.btn.fnd -text "Find" -width 6
1982	button $base.btn.clr -text "Clear" -width 6
1983	button $base.btn.dis -text "Dismiss" -width 6
1984	eval pack [winfo children $base.btn] -padx 4 -pady 2 \
1985	-side left -fill both
1986
1987	focus $base.f.e
1988
1989	bind $base.f.e <Return> [list $base.btn.fnd invoke]
1990	bind $base.f.e <Escape> [list $base.btn.dis invoke]
1991	}
1992	$base.btn.fnd config -command "::tkcon::Find [list $w] \$::tkcon::PRIV(find) \
1993	-case \$::tkcon::PRIV(find,case) -reg \$::tkcon::PRIV(find,reg)"
1994	$base.btn.clr config -command "
1995	[list $w] tag remove find 1.0 end
1996	set ::tkcon::PRIV(find) {}
1997	"
1998	$base.btn.dis config -command "
1999	[list $w] tag remove find 1.0 end
2000	wm withdraw [list $base]
2001	"
2002	if {[string compare {} $str]} {
2003	set PRIV(find) $str
2004	$base.btn.fnd invoke
2005	}
2006
2007	if {[string compare normal [wm state $base]]} {
2008	wm deiconify $base
2009	} else { raise $base }
2010	$base.f.e select range 0 end
2011	}
2012
2013	## ::tkcon::Find - searches in text widget $w for $str and highlights it
2014	## If $str is empty, it just deletes any highlighting
2015	# ARGS: w - text widget
2016	# str - string to search for
2017	# -case TCL_BOOLEAN whether to be case sensitive DEFAULT: 0
2018	# -regexp TCL_BOOLEAN whether to use $str as pattern DEFAULT: 0
2019	##
2020	proc ::tkcon::Find {w str args} {
2021	$w tag remove find 1.0 end
2022	set truth {^(1\|yes\|true\|on)$}
2023	set opts {}
2024	foreach {key val} $args {
2025	switch -glob -- $key {
2026	-c* { if {[regexp -nocase $truth $val]} { set case 1 } }
2027	-r* { if {[regexp -nocase $truth $val]} { lappend opts -regexp } }
2028	default { return -code error "Unknown option $key" }
2029	}
2030	}
2031	if {![info exists case]} { lappend opts -nocase }
2032	if {[string match {} $str]} return
2033	$w mark set findmark 1.0
2034	while {[string compare {} [set ix [eval $w search $opts -count numc -- \
2035	[list $str] findmark end]]]} {
2036	$w tag add find $ix ${ix}+${numc}c
2037	$w mark set findmark ${ix}+1c
2038	}
2039	$w tag configure find -background $::tkcon::COLOR(blink)
2040	catch {$w see find.first}
2041	return [expr {[llength [$w tag ranges find]]/2}]
2042	}
2043
2044	## ::tkcon::Attach - called to attach tkcon to an interpreter
2045	# ARGS: name - application name to which tkcon sends commands
2046	# This is either a slave interperter name or tk appname.
2047	# type - (slave\|interp) type of interpreter we're attaching to
2048	# slave means it's a tkcon interpreter
2049	# interp means we'll need to 'send' to it.
2050	# Results: ::tkcon::EvalAttached is recreated to evaluate in the
2051	# appropriate interpreter
2052	##
2053	proc ::tkcon::Attach {{name <NONE>} {type slave} {ns {}}} {
2054	variable PRIV
2055	variable OPT
2056	variable ATTACH
2057
2058	if {[llength [info level 0]] == 1} {
2059	# no args were specified, return the attach info instead
2060	return [AttachId]
2061	}
2062	set path [concat $PRIV(name) $OPT(exec)]
2063
2064	set PRIV(displayWin) .
2065	if {[string match namespace $type]} {
2066	return [uplevel 1 ::tkcon::AttachNamespace $name]
2067	} elseif {[string match dpy:* $type]} {
2068	set PRIV(displayWin) [string range $type 4 end]
2069	} elseif {[string match sock* $type]} {
2070	global tcl_version
2071	if {[catch {eof $name} res]} {
2072	return -code error "No known channel \"$name\""
2073	} elseif {$res} {
2074	catch {close $name}
2075	return -code error "Channel \"$name\" returned EOF"
2076	}
2077	set app $name
2078	set type socket
2079	} elseif {[string compare {} $name]} {
2080	array set interps [Interps]
2081	if {[string match {[Mm]ain} [lindex $name 0]]} {
2082	set name [lrange $name 1 end]
2083	}
2084	if {[string match $path $name]} {
2085	set name {}
2086	set app $path
2087	set type slave
2088	} elseif {[info exists interps($name)]} {
2089	if {[string match {} $name]} { set name Main; set app Main }
2090	set type slave
2091	} elseif {[interp exists $name]} {
2092	set name [concat $PRIV(name) $name]
2093	set type slave
2094	} elseif {[interp exists [concat $OPT(exec) $name]]} {
2095	set name [concat $path $name]
2096	set type slave
2097	} elseif {[lsearch -exact [::send::interps] $name] > -1} {
2098	if {[EvalSlave info exists tk_library] \
2099	&& [string match $name [EvalSlave tk appname]]} {
2100	set name {}
2101	set app $path
2102	set type slave
2103	} elseif {[set i [lsearch -exact \
2104	[Main set ::tkcon::PRIV(interps)] $name]] != -1} {
2105	set name [lindex [Main set ::tkcon::PRIV(slaves)] $i]
2106	if {[string match {[Mm]ain} $name]} { set app Main }
2107	set type slave
2108	} else {
2109	set type interp
2110	}
2111	} else {
2112	return -code error "No known interpreter \"$name\""
2113	}
2114	} else {
2115	set app $path
2116	}
2117	if {![info exists app]} { set app $name }
2118	array set PRIV [list app $app appname $name apptype $type deadapp 0]
2119
2120	## ::tkcon::EvalAttached - evaluates the args in the attached interp
2121	## args should be passed to this procedure as if they were being
2122	## passed to the 'eval' procedure. This procedure is dynamic to
2123	## ensure evaluation occurs in the right interp.
2124	# ARGS: args - the command and args to evaluate
2125	##
2126	set PRIV(namesp) ::
2127	set namespOK 0
2128	switch -glob -- $type {
2129	slave {
2130	if {[string match {} $name]} {
2131	interp alias {} ::tkcon::EvalAttached {} \
2132	::tkcon::EvalSlave uplevel \#0
2133	} elseif {[string match Main $PRIV(app)]} {
2134	interp alias {} ::tkcon::EvalAttached {} ::tkcon::Main
2135	} elseif {[string match $PRIV(name) $PRIV(app)]} {
2136	interp alias {} ::tkcon::EvalAttached {} uplevel \#0
2137	} else {
2138	interp alias {} ::tkcon::EvalAttached {} \
2139	::tkcon::Slave $::tkcon::PRIV(app)
2140	}
2141	set namespOK 1
2142	}
2143	sock* {
2144	interp alias {} ::tkcon::EvalAttached {} \
2145	::tkcon::EvalSlave uplevel \#0
2146	# The file event will just puts whatever data is found
2147	# into the interpreter
2148	fconfigure $name -buffering line -blocking 0
2149	fileevent $name readable [list ::tkcon::EvalSocketEvent $name]
2150	}
2151	dpy:* -
2152	interp {
2153	if {$OPT(nontcl)} {
2154	interp alias {} ::tkcon::EvalAttached {} ::tkcon::EvalSlave
2155	} else {
2156	interp alias {} ::tkcon::EvalAttached {} ::tkcon::EvalSend
2157	set namespOK 1
2158	}
2159	}
2160	default {
2161	return -code error "[lindex [info level 0] 0] did not specify\
2162	a valid type: must be slave or interp"
2163	}
2164	}
2165	if {![string match {} $ns] && $namespOK} {
2166	AttachNamespace $ns
2167	}
2168	return [AttachId]
2169	}
2170
2171	proc ::tkcon::AttachId {} {
2172	# return Attach info in a form that Attach accepts again
2173	variable PRIV
2174
2175	if {[string match {} $PRIV(appname)]} {
2176	variable OPT
2177	set appname [concat $PRIV(name) $OPT(exec)]
2178	} else {
2179	set appname $PRIV(appname)
2180	}
2181	set id [list $appname $PRIV(apptype)]
2182	# only display ns info if it isn't "::" as that is what is also
2183	# used to indicate no eval in namespace
2184	if {![string match :: $PRIV(namesp)]} { lappend id $PRIV(namesp) }
2185	if {[info exists PRIV(console)]} {
2186	variable ATTACH
2187	set ATTACH($PRIV(console)) $id
2188	}
2189	return $id
2190	}
2191
2192	## ::tkcon::AttachNamespace - called to attach tkcon to a namespace
2193	# ARGS: name - namespace name in which tkcon should eval commands
2194	# Results: ::tkcon::EvalAttached will be modified
2195	##
2196	proc ::tkcon::AttachNamespace { name } {
2197	variable PRIV
2198	variable OPT
2199
2200	if {($OPT(nontcl) && [string match interp $PRIV(apptype)]) \
2201	\|\| [string match socket $PRIV(apptype)] \
2202	\|\| $PRIV(deadapp)} {
2203	return -code error "can't attach to namespace in attached environment"
2204	}
2205	if {[string match Main $name]} {set name ::}
2206	if {[string compare {} $name] && \
2207	[lsearch [Namespaces ::] $name] == -1} {
2208	return -code error "No known namespace \"$name\""
2209	}
2210	if {[regexp {^(\|::)$} $name]} {
2211	## If name=={} \|\| ::, we want the primary namespace
2212	set alias [interp alias {} ::tkcon::EvalAttached]
2213	if {[string match ::tkcon::EvalNamespace* $alias]} {
2214	eval [list interp alias {} ::tkcon::EvalAttached {}] \
2215	[lindex $alias 1]
2216	}
2217	set name ::
2218	} else {
2219	interp alias {} ::tkcon::EvalAttached {} ::tkcon::EvalNamespace \
2220	[interp alias {} ::tkcon::EvalAttached] [list $name]
2221	}
2222	set PRIV(namesp) $name
2223	return [AttachId]
2224	}
2225
2226	## ::tkcon::NewSocket - called to create a socket to connect to
2227	# ARGS: none
2228	# Results: It will create a socket, and attach if requested
2229	##
2230	proc ::tkcon::NewSocket {} {
2231	variable PRIV
2232
2233	set t $PRIV(base).newsock
2234	if {![winfo exists $t]} {
2235	toplevel $t
2236	wm withdraw $t
2237	wm title $t "tkcon Create Socket"
2238	label $t.lhost -text "Host: "
2239	entry $t.host -width 16 -takefocus 1
2240	label $t.lport -text "Port: "
2241	entry $t.port -width 4 -takefocus 1
2242	button $t.ok -text "OK" -command {set ::tkcon::PRIV(grab) 1} -width 4 \
2243	-takefocus 1
2244	bind $t.host <Return> [list focus $t.port]
2245	bind $t.port <Return> [list focus $t.ok]
2246	bind $t.ok <Return> [list $t.ok invoke]
2247	grid $t.lhost $t.host $t.lport $t.port $t.ok -sticky ew
2248	grid configure $t.ok -padx 4 -pady 2
2249	grid columnconfig $t 1 -weight 1
2250	grid rowconfigure $t 1 -weight 1
2251	wm transient $t $PRIV(root)
2252	wm group $t $PRIV(root)
2253	wm geometry $t +[expr {([winfo screenwidth $t]-[winfo \
2254	reqwidth $t]) / 2}]+[expr {([winfo \
2255	screenheight $t]-[winfo reqheight $t]) / 2}]
2256	bind $t <Escape> [list destroy $t]
2257	}
2258	#$t.host delete 0 end
2259	#$t.port delete 0 end
2260	wm deiconify $t
2261	raise $t
2262	grab $t
2263	focus $t.host
2264	vwait ::tkcon::PRIV(grab)
2265	grab release $t
2266	wm withdraw $t
2267	set host [$t.host get]
2268	set port [$t.port get]
2269	if {$host == ""} { return }
2270	if {[catch {
2271	set sock [socket $host $port]
2272	} err]} {
2273	tk_messageBox -title "Socket Connection Error" \
2274	-message "Unable to connect to \"$host:$port\":\n$err" \
2275	-icon error -type ok
2276	} else {
2277	Attach $sock socket
2278	}
2279	}
2280
2281	## ::tkcon::Load - sources a file into the console
2282	## The file is actually sourced in the currently attached's interp
2283	# ARGS: fn - (optional) filename to source in
2284	# Returns: selected filename ({} if nothing was selected)
2285	##
2286	proc ::tkcon::Load { {fn ""} } {
2287	set types {
2288	{{Tcl Files} {.tcl .tk}}
2289	{{Text Files} {.txt}}
2290	{{All Files} *}
2291	}
2292	if {
2293	[string match {} $fn] &&
2294	([catch {tk_getOpenFile -filetypes $types \
2295	-title "Source File"} fn] \|\| [string match {} $fn])
2296	} { return }
2297	EvalAttached [list source $fn]
2298	}
2299
2300	## ::tkcon::Save - saves the console or other widget buffer to a file
2301	## This does not eval in a slave because it's not necessary
2302	# ARGS: w - console text widget
2303	# fn - (optional) filename to save to
2304	##
2305	proc ::tkcon::Save { {fn ""} {type ""} {opt ""} {mode w} } {
2306	variable PRIV
2307
2308	if {![regexp -nocase {^(all\|history\|stdin\|stdout\|stderr\|widget)$} $type]} {
2309	array set s { 0 All 1 History 2 Stdin 3 Stdout 4 Stderr 5 Cancel }
2310	## Allow user to specify what kind of stuff to save
2311	set type [tk_dialog $PRIV(base).savetype "Save Type" \
2312	"What part of the text do you want to save?" \
2313	questhead 0 $s(0) $s(1) $s(2) $s(3) $s(4) $s(5)]
2314	if {$type == 5 \|\| $type == -1} return
2315	set type $s($type)
2316	}
2317	if {[string match {} $fn]} {
2318	set types {
2319	{{Tcl Files} {.tcl .tk}}
2320	{{Text Files} {.txt}}
2321	{{All Files} *}
2322	}
2323	if {[catch {tk_getSaveFile -defaultextension .tcl -filetypes $types \
2324	-title "Save $type"} fn] \|\| [string match {} $fn]} return
2325	}
2326	set type [string tolower $type]
2327	switch $type {
2328	stdin - stdout - stderr {
2329	set data {}
2330	foreach {first last} [$PRIV(console) tag ranges $type] {
2331	lappend data [$PRIV(console) get $first $last]
2332	}
2333	set data [join $data \n]
2334	}
2335	history { set data [tkcon history] }
2336	all - default { set data [$PRIV(console) get 1.0 end-1c] }
2337	widget {
2338	set data [$opt get 1.0 end-1c]
2339	}
2340	}
2341	if {[catch {open $fn $mode} fid]} {
2342	return -code error "Save Error: Unable to open '$fn' for writing\n$fid"
2343	}
2344	puts -nonewline $fid $data
2345	close $fid
2346	}
2347
2348	## ::tkcon::MainInit
2349	## This is only called for the main interpreter to include certain procs
2350	## that we don't want to include (or rather, just alias) in slave interps.
2351	##
2352	proc ::tkcon::MainInit {} {
2353	variable PRIV
2354	variable OPT
2355
2356	if {![info exists PRIV(slaves)]} {
2357	array set PRIV [list slave 0 slaves Main name {} \
2358	interps [list [tk appname]]]
2359	}
2360	interp alias {} ::tkcon::Main {} ::tkcon::InterpEval Main
2361	interp alias {} ::tkcon::Slave {} ::tkcon::InterpEval
2362
2363	proc ::tkcon::GetSlaveNum {} {
2364	set i -1
2365	while {[interp exists Slave[incr i]]} {
2366	# oh my god, an empty loop!
2367	}
2368	return $i
2369	}
2370
2371	## ::tkcon::New - create new console window
2372	## Creates a slave interpreter and sources in this script.
2373	## All other interpreters also get a command to eval function in the
2374	## new interpreter.
2375	##
2376	proc ::tkcon::New {} {
2377	variable PRIV
2378	global argv0 argc argv
2379
2380	set tmp [interp create Slave[GetSlaveNum]]
2381	lappend PRIV(slaves) $tmp
2382	load {} Tk $tmp
2383	# If we have tbcload, then that should be autoloaded into slaves.
2384	set idx [lsearch [info loaded] "* Tbcload"]
2385	if {$idx != -1} { catch {load {} Tbcload $tmp} }
2386	lappend PRIV(interps) [$tmp eval [list tk appname \
2387	"[tk appname] $tmp"]]
2388	if {[info exists argv0]} {$tmp eval [list set argv0 $argv0]}
2389	if {[info exists argc]} {$tmp eval [list set argc $argc]}
2390	if {[info exists argv]} {$tmp eval [list set argv $argv]}
2391	$tmp eval [list namespace eval ::tkcon {}]
2392	$tmp eval [list set ::tkcon::PRIV(name) $tmp]
2393	$tmp eval [list set ::tkcon::PRIV(SCRIPT) $::tkcon::PRIV(SCRIPT)]
2394	$tmp alias exit ::tkcon::Exit $tmp
2395	$tmp alias ::tkcon::Destroy ::tkcon::Destroy $tmp
2396	$tmp alias ::tkcon::New ::tkcon::New
2397	$tmp alias ::tkcon::GetSlaveNum ::tkcon::GetSlaveNum
2398	$tmp alias ::tkcon::Main ::tkcon::InterpEval Main
2399	$tmp alias ::tkcon::Slave ::tkcon::InterpEval
2400	$tmp alias ::tkcon::Interps ::tkcon::Interps
2401	$tmp alias ::tkcon::NewDisplay ::tkcon::NewDisplay
2402	$tmp alias ::tkcon::Display ::tkcon::Display
2403	$tmp alias ::tkcon::StateCheckpoint ::tkcon::StateCheckpoint
2404	$tmp alias ::tkcon::StateCleanup ::tkcon::StateCleanup
2405	$tmp alias ::tkcon::StateCompare ::tkcon::StateCompare
2406	$tmp alias ::tkcon::StateRevert ::tkcon::StateRevert
2407	$tmp eval {
2408	if [catch {source -rsrc tkcon}] { source $::tkcon::PRIV(SCRIPT) }
2409	}
2410	return $tmp
2411	}
2412
2413	## ::tkcon::Exit - full exit OR destroy slave console
2414	## This proc should only be called in the main interpreter from a slave.
2415	## The master determines whether we do a full exit or just kill the slave.
2416	##
2417	proc ::tkcon::Exit {slave args} {
2418	variable PRIV
2419	variable OPT
2420
2421	## Slave interpreter exit request
2422	if {[string match exit $OPT(slaveexit)]
2423	\|\| [llength $PRIV(interps)] == 1} {
2424	## Only exit if it specifically is stated to do so, or this
2425	## is the last interp
2426	uplevel 1 exit $args
2427	} else {
2428	## Otherwise we will delete the slave interp and associated data
2429	Destroy $slave
2430	}
2431	}
2432
2433	## ::tkcon::Destroy - destroy console window
2434	## This proc should only be called by the main interpreter. If it is
2435	## called from there, it will ask before exiting tkcon. All others
2436	## (slaves) will just have their slave interpreter deleted, closing them.
2437	##
2438	proc ::tkcon::Destroy {{slave {}}} {
2439	variable PRIV
2440
2441	# Just close on the last one
2442	if {[llength $PRIV(interps)] == 1} { exit }
2443	if {"" == $slave} {
2444	## Main interpreter close request
2445	if {[tk_messageBox -parent $PRIV(root) -title "Quit tkcon?" \
2446	-message "Close all windows and exit tkcon?" \
2447	-icon question -type yesno] == "yes"} { exit }
2448	return
2449	} elseif {$slave == $::tkcon::OPT(exec)} {
2450	set name [tk appname]
2451	set slave "Main"
2452	} else {
2453	## Slave interpreter close request
2454	set name [InterpEval $slave]
2455	interp delete $slave
2456	}
2457	set PRIV(interps) [lremove $PRIV(interps) [list $name]]
2458	set PRIV(slaves) [lremove $PRIV(slaves) [list $slave]]
2459	StateCleanup $slave
2460	}
2461
2462	if {$OPT(overrideexit)} {
2463	## We want to do a couple things before exiting...
2464	if {[catch {rename ::exit ::tkcon::FinalExit} err]} {
2465	puts stderr "tkcon might panic:\n$err"
2466	}
2467	proc ::exit args {
2468	if {$::tkcon::OPT(usehistory)} {
2469	if {[catch {open $::tkcon::PRIV(histfile) w} fid]} {
2470	puts stderr "unable to save history file:\n$fid"
2471	# pause a moment, because we are about to die finally...
2472	after 1000
2473	} else {
2474	set max [::tkcon::EvalSlave history nextid]
2475	set id [expr {$max - $::tkcon::OPT(history)}]
2476	if {$id < 1} { set id 1 }
2477	## FIX: This puts history in backwards!!
2478	while {($id < $max) && ![catch \
2479	{::tkcon::EvalSlave history event $id} cmd]} {
2480	if {[string compare {} $cmd]} {
2481	puts $fid "::tkcon::EvalSlave\
2482	history add [list $cmd]"
2483	}
2484	incr id
2485	}
2486	close $fid
2487	}
2488	}
2489	uplevel 1 ::tkcon::FinalExit $args
2490	}
2491	}
2492
2493	## ::tkcon::InterpEval - passes evaluation to another named interpreter
2494	## If the interpreter is named, but no args are given, it returns the
2495	## [tk appname] of that interps master (not the associated eval slave).
2496	##
2497	proc ::tkcon::InterpEval {{slave {}} args} {
2498	variable PRIV
2499
2500	if {[llength [info level 0]] == 1} {
2501	# no args given
2502	return $PRIV(slaves)
2503	} elseif {[string match {[Mm]ain} $slave]} {
2504	set slave {}
2505	}
2506	if {[llength $args]} {
2507	return [interp eval $slave uplevel \#0 $args]
2508	} else {
2509	# beware safe interps with Tk
2510	if {[interp eval $slave {llength [info commands tk]}]} {
2511	if {[catch {interp eval $slave tk appname} name]} {
2512	return "safetk"
2513	}
2514	return $name
2515	}
2516	}
2517	}
2518
2519	proc ::tkcon::Interps {{ls {}} {interp {}}} {
2520	if {[string match {} $interp]} {
2521	lappend ls {} [tk appname]
2522	}
2523	foreach i [interp slaves $interp] {
2524	if {[string compare {} $interp]} { set i "$interp $i" }
2525	if {[string compare {} [interp eval $i package provide Tk]]} {
2526	# beware safe interps with Tk
2527	if {[catch {interp eval $i tk appname} name]} {
2528	set name {}
2529	}
2530	lappend ls $i $name
2531	} else {
2532	lappend ls $i {}
2533	}
2534	set ls [Interps $ls $i]
2535	}
2536	return $ls
2537	}
2538
2539	proc ::tkcon::Display {{disp {}}} {
2540	variable DISP
2541
2542	set res {}
2543	if {$disp != ""} {
2544	if {![info exists DISP($disp)]} { return }
2545	return [list $DISP($disp) [winfo interps -displayof $DISP($disp)]]
2546	}
2547	return [lsort -dictionary [array names DISP]]
2548	}
2549
2550	proc ::tkcon::NewDisplay {} {
2551	variable PRIV
2552	variable DISP
2553
2554	set t $PRIV(base).newdisp
2555	if {![winfo exists $t]} {
2556	toplevel $t
2557	wm withdraw $t
2558	wm title $t "tkcon Attach to Display"
2559	label $t.gets -text "New Display: "
2560	entry $t.data -width 32
2561	button $t.ok -text "OK" -command {set ::tkcon::PRIV(grab) 1}
2562	bind $t.data <Return> [list $t.ok invoke]
2563	bind $t.ok <Return> [list $t.ok invoke]
2564	grid $t.gets $t.data -sticky ew
2565	grid $t.ok - -sticky ew
2566	grid columnconfig $t 1 -weight 1
2567	grid rowconfigure $t 1 -weight 1
2568	wm transient $t $PRIV(root)
2569	wm geometry $t +[expr {([winfo screenwidth $t]-[winfo \
2570	reqwidth $t]) / 2}]+[expr {([winfo \
2571	screenheight $t]-[winfo reqheight $t]) / 2}]
2572	}
2573	$t.data delete 0 end
2574	wm deiconify $t
2575	raise $t
2576	grab $t
2577	focus $t.data
2578	vwait ::tkcon::PRIV(grab)
2579	grab release $t
2580	wm withdraw $t
2581	set disp [$t.data get]
2582	if {$disp == ""} { return }
2583	regsub -all {\.} [string tolower $disp] ! dt
2584	set dt $PRIV(base).$dt
2585	destroy $dt
2586	if {[catch {
2587	toplevel $dt -screen $disp
2588	set interps [winfo interps -displayof $dt]
2589	if {![llength $interps]} {
2590	error "No other Tk interpreters on $disp"
2591	}
2592	::send::send -displayof $dt [lindex $interps 0] [list info tclversion]
2593	} err]} {
2594	global env
2595	if {[info exists env(DISPLAY)]} {
2596	set myd $env(DISPLAY)
2597	} else {
2598	set myd "myDisplay:0"
2599	}
2600	tk_messageBox -title "Display Connection Error" \
2601	-message "Unable to connect to \"$disp\":\n$err\
2602	\nMake sure you have xauth-based permissions\
2603	(xauth add $myd . `mcookie`), and xhost is disabled\
2604	(xhost -) on \"$disp\"" \
2605	-icon error -type ok
2606	destroy $dt
2607	return
2608	}
2609	set DISP($disp) $dt
2610	wm withdraw $dt
2611	bind $dt <Destroy> [subst {catch {unset ::tkcon::DISP($disp)}}]
2612	tk_messageBox -title "$disp Connection" \
2613	-message "Connected to \"$disp\", found:\n[join $interps \n]" \
2614	-type ok
2615	}
2616
2617	##
2618	## The following state checkpoint/revert procedures are very sketchy
2619	## and prone to problems. They do not track modifications to currently
2620	## existing procedures/variables, and they can really screw things up
2621	## if you load in libraries (especially Tk) between checkpoint and
2622	## revert. Only with this knowledge in mind should you use these.
2623	##
2624
2625	## ::tkcon::StateCheckpoint - checkpoints the current state of the system
2626	## This allows you to return to this state with ::tkcon::StateRevert
2627	# ARGS:
2628	##
2629	proc ::tkcon::StateCheckpoint {app type} {
2630	variable CPS
2631	variable PRIV
2632
2633	if {[info exists CPS($type,$app,cmd)] && \
2634	[tk_dialog $PRIV(base).warning "Overwrite Previous State?" \
2635	"Are you sure you want to lose previously checkpointed\
2636	state of $type \"$app\"?" questhead 1 "Do It" "Cancel"]} return
2637	set CPS($type,$app,cmd) [EvalOther $app $type info commands *]
2638	set CPS($type,$app,var) [EvalOther $app $type info vars *]
2639	return
2640	}
2641
2642	## ::tkcon::StateCompare - compare two states and output difference
2643	# ARGS:
2644	##
2645	proc ::tkcon::StateCompare {app type {verbose 0}} {
2646	variable CPS
2647	variable PRIV
2648	variable OPT
2649	variable COLOR
2650
2651	if {![info exists CPS($type,$app,cmd)]} {
2652	return -code error \
2653	"No previously checkpointed state for $type \"$app\""
2654	}
2655	set w $PRIV(base).compare
2656	if {[winfo exists $w]} {
2657	$w.text config -state normal
2658	$w.text delete 1.0 end
2659	} else {
2660	toplevel $w
2661	frame $w.btn
2662	scrollbar $w.sy -takefocus 0 -bd 1 -command [list $w.text yview]
2663	text $w.text -yscrollcommand [list $w.sy set] -height 12 \
2664	-foreground $COLOR(stdin) \
2665	-background $COLOR(bg) \
2666	-insertbackground $COLOR(cursor) \
2667	-font $OPT(font)
2668	pack $w.btn -side bottom -fill x
2669	pack $w.sy -side right -fill y
2670	pack $w.text -fill both -expand 1
2671	button $w.btn.close -text "Dismiss" -width 11 \
2672	-command [list destroy $w]
2673	button $w.btn.check -text "Recheckpoint" -width 11
2674	button $w.btn.revert -text "Revert" -width 11
2675	button $w.btn.expand -text "Verbose" -width 11
2676	button $w.btn.update -text "Update" -width 11
2677	pack $w.btn.check $w.btn.revert $w.btn.expand $w.btn.update \
2678	$w.btn.close -side left -fill x -padx 4 -pady 2 -expand 1
2679	$w.text tag config red -foreground red
2680	}
2681	wm title $w "Compare State: $type [list $app]"
2682
2683	$w.btn.check config \
2684	-command "::tkcon::StateCheckpoint [list $app] $type; \
2685	::tkcon::StateCompare [list $app] $type $verbose"
2686	$w.btn.revert config \
2687	-command "::tkcon::StateRevert [list $app] $type; \
2688	::tkcon::StateCompare [list $app] $type $verbose"
2689	$w.btn.update config -command [info level 0]
2690	if {$verbose} {
2691	$w.btn.expand config -text Brief \
2692	-command [list ::tkcon::StateCompare $app $type 0]
2693	} else {
2694	$w.btn.expand config -text Verbose \
2695	-command [list ::tkcon::StateCompare $app $type 1]
2696	}
2697	## Don't allow verbose mode unless 'dump' exists in $app
2698	## We're assuming this is tkcon's dump command
2699	set hasdump [llength [EvalOther $app $type info commands dump]]
2700	if {$hasdump} {
2701	$w.btn.expand config -state normal
2702	} else {
2703	$w.btn.expand config -state disabled
2704	}
2705
2706	set cmds [lremove [EvalOther $app $type info commands *] \
2707	$CPS($type,$app,cmd)]
2708	set vars [lremove [EvalOther $app $type info vars *] \
2709	$CPS($type,$app,var)]
2710
2711	if {$hasdump && $verbose} {
2712	set cmds [EvalOther $app $type eval dump c -nocomplain $cmds]
2713	set vars [EvalOther $app $type eval dump v -nocomplain $vars]
2714	}
2715	$w.text insert 1.0 "NEW COMMANDS IN \"$app\":\n" red \
2716	$cmds {} "\n\nNEW VARIABLES IN \"$app\":\n" red $vars {}
2717
2718	raise $w
2719	$w.text config -state disabled
2720	}
2721
2722	## ::tkcon::StateRevert - reverts interpreter to previous state
2723	# ARGS:
2724	##
2725	proc ::tkcon::StateRevert {app type} {
2726	variable CPS
2727	variable PRIV
2728
2729	if {![info exists CPS($type,$app,cmd)]} {
2730	return -code error \
2731	"No previously checkpointed state for $type \"$app\""
2732	}
2733	if {![tk_dialog $PRIV(base).warning "Revert State?" \
2734	"Are you sure you want to revert the state in $type \"$app\"?"\
2735	questhead 1 "Do It" "Cancel"]} {
2736	foreach i [lremove [EvalOther $app $type info commands *] \
2737	$CPS($type,$app,cmd)] {
2738	catch {EvalOther $app $type rename $i {}}
2739	}
2740	foreach i [lremove [EvalOther $app $type info vars *] \
2741	$CPS($type,$app,var)] {
2742	catch {EvalOther $app $type unset $i}
2743	}
2744	}
2745	}
2746
2747	## ::tkcon::StateCleanup - cleans up state information in master array
2748	#
2749	##
2750	proc ::tkcon::StateCleanup {args} {
2751	variable CPS
2752
2753	if {![llength $args]} {
2754	foreach state [array names CPS slave,*] {
2755	if {![interp exists [string range $state 6 end]]} {
2756	unset CPS($state)
2757	}
2758	}
2759	} else {
2760	set app [lindex $args 0]
2761	set type [lindex $args 1]
2762	if {[regexp {^(\|slave)$} $type]} {
2763	foreach state [array names CPS "slave,$app\[, \]*"] {
2764	if {![interp exists [string range $state 6 end]]} {
2765	unset CPS($state)
2766	}
2767	}
2768	} else {
2769	catch {unset CPS($type,$app)}
2770	}
2771	}
2772	}
2773	}
2774
2775	## ::tkcon::Event - get history event, search if string != {}
2776	## look forward (next) if $int>0, otherwise look back (prev)
2777	# ARGS: W - console widget
2778	##
2779	proc ::tkcon::Event {int {str {}}} {
2780	if {!$int} return
2781
2782	variable PRIV
2783	set w $PRIV(console)
2784
2785	set nextid [EvalSlave history nextid]
2786	if {[string compare {} $str]} {
2787	## String is not empty, do an event search
2788	set event $PRIV(event)
2789	if {$int < 0 && $event == $nextid} { set PRIV(cmdbuf) $str }
2790	set len [string len $PRIV(cmdbuf)]
2791	incr len -1
2792	if {$int > 0} {
2793	## Search history forward
2794	while {$event < $nextid} {
2795	if {[incr event] == $nextid} {
2796	$w delete limit end
2797	$w insert limit $PRIV(cmdbuf)
2798	break
2799	} elseif {
2800	![catch {EvalSlave history event $event} res] &&
2801	[set p [string first $PRIV(cmdbuf) $res]] > -1
2802	} {
2803	set p2 [expr {$p + [string length $PRIV(cmdbuf)]}]
2804	$w delete limit end
2805	$w insert limit $res
2806	Blink $w "limit + $p c" "limit + $p2 c"
2807	break
2808	}
2809	}
2810	set PRIV(event) $event
2811	} else {
2812	## Search history reverse
2813	while {![catch {EvalSlave history event [incr event -1]} res]} {
2814	if {[set p [string first $PRIV(cmdbuf) $res]] > -1} {
2815	set p2 [expr {$p + [string length $PRIV(cmdbuf)]}]
2816	$w delete limit end
2817	$w insert limit $res
2818	set PRIV(event) $event
2819	Blink $w "limit + $p c" "limit + $p2 c"
2820	break
2821	}
2822	}
2823	}
2824	} else {
2825	## String is empty, just get next/prev event
2826	if {$int > 0} {
2827	## Goto next command in history
2828	if {$PRIV(event) < $nextid} {
2829	$w delete limit end
2830	if {[incr PRIV(event)] == $nextid} {
2831	$w insert limit $PRIV(cmdbuf)
2832	} else {
2833	$w insert limit [EvalSlave history event $PRIV(event)]
2834	}
2835	}
2836	} else {
2837	## Goto previous command in history
2838	if {$PRIV(event) == $nextid} {
2839	set PRIV(cmdbuf) [CmdGet $w]
2840	}
2841	if {[catch {EvalSlave history event [incr PRIV(event) -1]} res]} {
2842	incr PRIV(event)
2843	} else {
2844	$w delete limit end
2845	$w insert limit $res
2846	}
2847	}
2848	}
2849	$w mark set insert end
2850	$w see end
2851	}
2852
2853	## ::tkcon::Highlight - magic highlighting
2854	## beware: voodoo included
2855	# ARGS:
2856	##
2857	proc ::tkcon::Highlight {w type} {
2858	variable COLOR
2859	variable OPT
2860
2861	switch -exact $type {
2862	"error" { HighlightError $w }
2863	"tcl" - "test" {
2864	if {[winfo class $w] != "Ctext"} { return }
2865
2866	foreach {app type} [tkcon attach] {break}
2867	set cmds [::tkcon::EvalOther $app $type info commands]
2868
2869	set classes [list \
2870	[list comment ClassForRegexp "^\\s#\[^\n\]" $COLOR(stderr)] \
2871	[list var ClassWithOnlyCharStart "\$" $COLOR(stdout)] \
2872	[list syntax ClassForSpecialChars "\[\]{}\"" $COLOR(prompt)] \
2873	[list command Class $cmds $COLOR(proc)] \
2874	]
2875
2876	# Remove all highlight classes from a widget
2877	ctext::clearHighlightClasses $w
2878	foreach class $classes {
2879	foreach {cname ctype cptn ccol} $class break
2880	ctext::addHighlight$ctype $w $cname $ccol $cptn
2881	}
2882	$w highlight 1.0 end
2883	}
2884	}
2885	}
2886
2887	## ::tkcon::HighlightError - magic error highlighting
2888	## beware: voodoo included
2889	# ARGS:
2890	##
2891	proc ::tkcon::HighlightError w {
2892	variable COLOR
2893	variable OPT
2894
2895	## do voodoo here
2896	set app [Attach]
2897	# we have to pull the text out, because text regexps are screwed on \n's.
2898	set info [$w get 1.0 end-1c]
2899	# Check for specific line error in a proc
2900	set exp(proc) "\"(\[^\"\]+)\"\n\[\t \]+\\\(procedure \"(\[^\"\]+)\""
2901	# Check for too few args to a proc
2902	set exp(param) "parameter \"(\[^\"\]+)\" to \"(\[^\"\]+)\""
2903	set start 1.0
2904	while {
2905	[regexp -indices -- $exp(proc) $info junk what cmd] \|\|
2906	[regexp -indices -- $exp(param) $info junk what cmd]
2907	} {
2908	foreach {w0 w1} $what {c0 c1} $cmd {break}
2909	set what [string range $info $w0 $w1]
2910	set cmd [string range $info $c0 $c1]
2911	if {[string match :: $cmd]} {
2912	set res [uplevel 1 ::tkcon::EvalOther $app namespace eval \
2913	[list [namespace qualifiers $cmd] \
2914	[list info procs [namespace tail $cmd]]]]
2915	} else {
2916	set res [uplevel 1 ::tkcon::EvalOther $app info procs [list $cmd]]
2917	}
2918	if {[llength $res]==1} {
2919	set tag [UniqueTag $w]
2920	$w tag add $tag $start+${c0}c $start+1c+${c1}c
2921	$w tag configure $tag -foreground $COLOR(stdout)
2922	$w tag bind $tag <Enter> [list $w tag configure $tag -under 1]
2923	$w tag bind $tag <Leave> [list $w tag configure $tag -under 0]
2924	$w tag bind $tag <ButtonRelease-1> "if {!\$tkPriv(mouseMoved)} \
2925	{[list $OPT(edit) -attach $app -type proc -find $what -- $cmd]}"
2926	}
2927	set info [string range $info $c1 end]
2928	set start [$w index $start+${c1}c]
2929	}
2930	## Next stage, check for procs that start a line
2931	set start 1.0
2932	set exp(cmd) "^\"\[^\" \t\n\]+"
2933	while {
2934	[string compare {} [set ix \
2935	[$w search -regexp -count numc -- $exp(cmd) $start end]]]
2936	} {
2937	set start [$w index $ix+${numc}c]
2938	# +1c to avoid the first quote
2939	set cmd [$w get $ix+1c $start]
2940	if {[string match :: $cmd]} {
2941	set res [uplevel 1 ::tkcon::EvalOther $app namespace eval \
2942	[list [namespace qualifiers $cmd] \
2943	[list info procs [namespace tail $cmd]]]]
2944	} else {
2945	set res [uplevel 1 ::tkcon::EvalOther $app info procs [list $cmd]]
2946	}
2947	if {[llength $res]==1} {
2948	set tag [UniqueTag $w]
2949	$w tag add $tag $ix+1c $start
2950	$w tag configure $tag -foreground $COLOR(proc)
2951	$w tag bind $tag <Enter> [list $w tag configure $tag -under 1]
2952	$w tag bind $tag <Leave> [list $w tag configure $tag -under 0]
2953	$w tag bind $tag <ButtonRelease-1> "if {!\$tkPriv(mouseMoved)} \
2954	{[list $OPT(edit) -attach $app -type proc -- $cmd]}"
2955	}
2956	}
2957	}
2958
2959	proc ::tkcon::ExpectInit {{termcap 1} {terminfo 1}} {
2960	global env
2961
2962	if {$termcap} {
2963	set env(TERM) "tt"
2964	set env(TERMCAP) {tt:
2965	:ks=\E[KS:
2966	:ke=\E[KE:
2967	:cm=\E[%d;%dH:
2968	:up=\E[A:
2969	:nd=\E[C:
2970	:cl=\E[H\E[J:
2971	:do=^J:
2972	:so=\E[7m:
2973	:se=\E[m:
2974	:k1=\EOP:
2975	:k2=\EOQ:
2976	:k3=\EOR:
2977	:k4=\EOS:
2978	:k5=\EOT:
2979	:k6=\EOU:
2980	:k7=\EOV:
2981	:k8=\EOW:
2982	:k9=\EOX:
2983	}
2984	}
2985
2986	if {$terminfo} {
2987	set env(TERM) "tkterm"
2988	if {![info exists env(TEMP)]} { set env(TEMP) /tmp }
2989	set env(TERMINFO) $env(TEMP)
2990
2991	set ttsrc [file join $env(TEMP) tt.src]
2992	set file [open $ttsrc w]
2993	puts $file {tkterm\|Don Libes' tk text widget terminal emulator,
2994	smkx=\E[KS,
2995	rmkx=\E[KE,
2996	cup=\E[%p1%d;%p2%dH,
2997	cuu1=\E[A,
2998	cuf1=\E[C,
2999	clear=\E[H\E[J,
3000	ind=\n,
3001	cr=\r,
3002	smso=\E[7m,
3003	rmso=\E[m,
3004	kf1=\EOP,
3005	kf2=\EOQ,
3006	kf3=\EOR,
3007	kf4=\EOS,
3008	kf5=\EOT,
3009	kf6=\EOU,
3010	kf7=\EOV,
3011	kf8=\EOW,
3012	kf9=\EOX,
3013	}
3014	close $file
3015
3016	if {[catch {exec tic $ttsrc} msg]} {
3017	return -code error \
3018	"tic failed, you may not have terminfo support:\n$msg"
3019	}
3020
3021	file delete $ttsrc
3022	}
3023	}
3024
3025	# term_exit is called if the spawned process exits
3026	proc ::tkcon::term_exit {w} {
3027	variable EXP
3028	catch {exp_close -i $EXP(spawn_id)}
3029	set EXP(forever) 1
3030	unset EXP
3031	}
3032
3033	# term_chars_changed is called after every change to the displayed chars
3034	# You can use if you want matches to occur in the background (a la bind)
3035	# If you want to test synchronously, then just do so - you don't need to
3036	# redefine this procedure.
3037	proc ::tkcon::term_chars_changed {w args} {
3038	}
3039
3040	# term_cursor_changed is called after the cursor is moved
3041	proc ::tkcon::term_cursor_changed {w args} {
3042	}
3043
3044	proc ::tkcon::term_update_cursor {w args} {
3045	variable OPT
3046	variable EXP
3047
3048	$w mark set insert $EXP(row).$EXP(col)
3049	$w see insert
3050	term_cursor_changed $w
3051	}
3052
3053	proc ::tkcon::term_clear {w args} {
3054	$w delete 1.0 end
3055	term_init $w
3056	}
3057
3058	proc ::tkcon::term_init {w args} {
3059	variable OPT
3060	variable EXP
3061
3062	# initialize it with blanks to make insertions later more easily
3063	set blankline [string repeat " " $OPT(cols)]\n
3064	for {set i 1} {$i <= $OPT(rows)} {incr i} {
3065	$w insert $i.0 $blankline
3066	}
3067
3068	set EXP(row) 1
3069	set EXP(col) 0
3070
3071	$w mark set insert $EXP(row).$EXP(col)
3072	}
3073
3074	proc ::tkcon::term_down {w args} {
3075	variable OPT
3076	variable EXP
3077
3078	if {$EXP(row) < $OPT(rows)} {
3079	incr EXP(row)
3080	} else {
3081	# already at last line of term, so scroll screen up
3082	$w delete 1.0 2.0
3083
3084	# recreate line at end
3085	$w insert end [string repeat " " $OPT(cols)]\n
3086	}
3087	}
3088
3089	proc ::tkcon::term_insert {w s} {
3090	variable OPT
3091	variable EXP
3092
3093	set chars_rem_to_write [string length $s]
3094	set space_rem_on_line [expr {$OPT(cols) - $EXP(col)}]
3095
3096	set tag_action [expr {$EXP(standout) ? "add" : "remove"}]
3097
3098	##################
3099	# write first line
3100	##################
3101
3102	if {$chars_rem_to_write > $space_rem_on_line} {
3103	set chars_to_write $space_rem_on_line
3104	set newline 1
3105	} else {
3106	set chars_to_write $chars_rem_to_write
3107	set newline 0
3108	}
3109
3110	$w delete $EXP(row).$EXP(col) \
3111	$EXP(row).[expr {$EXP(col) + $chars_to_write}]
3112	$w insert $EXP(row).$EXP(col) \
3113	[string range $s 0 [expr {$space_rem_on_line-1}]]
3114
3115	$w tag $tag_action standout $EXP(row).$EXP(col) \
3116	$EXP(row).[expr {$EXP(col) + $chars_to_write}]
3117
3118	# discard first line already written
3119	incr chars_rem_to_write -$chars_to_write
3120	set s [string range $s $chars_to_write end]
3121
3122	# update EXP(col)
3123	incr EXP(col) $chars_to_write
3124	# update EXP(row)
3125	if {$newline} { term_down $w }
3126
3127	##################
3128	# write full lines
3129	##################
3130	while {$chars_rem_to_write >= $OPT(cols)} {
3131	$w delete $EXP(row).0 $EXP(row).end
3132	$w insert $EXP(row).0 [string range $s 0 [expr {$OPT(cols)-1}]]
3133	$w tag $tag_action standout $EXP(row).0 $EXP(row).end
3134
3135	# discard line from buffer
3136	set s [string range $s $OPT(cols) end]
3137	incr chars_rem_to_write -$OPT(cols)
3138
3139	set EXP(col) 0
3140	term_down $w
3141	}
3142
3143	#################
3144	# write last line
3145	#################
3146
3147	if {$chars_rem_to_write} {
3148	$w delete $EXP(row).0 $EXP(row).$chars_rem_to_write
3149	$w insert $EXP(row).0 $s
3150	$w tag $tag_action standout $EXP(row).0 $EXP(row).$chars_rem_to_write
3151	set EXP(col) $chars_rem_to_write
3152	}
3153
3154	term_chars_changed $w
3155	}
3156
3157	proc ::tkcon::Expect {cmd} {
3158	variable OPT
3159	variable PRIV
3160	variable EXP
3161
3162	set EXP(standout) 0
3163	set EXP(row) 0
3164	set EXP(col) 0
3165
3166	set env(LINES) $OPT(rows)
3167	set env(COLUMNS) $OPT(cols)
3168
3169	ExpectInit
3170	log_user 0
3171	set ::stty_init "-tabs"
3172	uplevel \#0 [linsert $cmd 0 spawn]
3173	set EXP(spawn_id) $::spawn_id
3174	if {[info exists ::spawn_out(slave,name)]} {
3175	set EXP(slave,name) $::spawn_out(slave,name)
3176	catch {stty rows $OPT(rows) columns $OPT(cols) < $::spawn_out(slave,name)}
3177	}
3178	if {[string index $cmd end] == "&"} {
3179	set cmd expect_background
3180	} else {
3181	set cmd expect
3182	}
3183	bind $PRIV(console) <Meta-KeyPress> {
3184	if {"%A" != ""} {
3185	exp_send -i $::tkcon::EXP(spawn_id) "\033%A"
3186	break
3187	}
3188	}
3189	bind $PRIV(console) <KeyPress> {
3190	exp_send -i $::tkcon::EXP(spawn_id) -- %A
3191	break
3192	}
3193	bind $PRIV(console) <Control-space> {exp_send -null}
3194	set code [catch {
3195	term_init $PRIV(console)
3196	while {[info exists EXP(spawn_id)]} {
3197	$cmd {
3198	-i $::tkcon::EXP(spawn_id)
3199	-re "^\[^\x01-\x1f\]+" {
3200	# Text
3201	::tkcon::term_insert $::tkcon::PRIV(console) \
3202	$expect_out(0,string)
3203	::tkcon::term_update_cursor $::tkcon::PRIV(console)
3204	} "^\r" {
3205	# (cr,) Go to beginning of line
3206	update idle
3207	set ::tkcon::EXP(col) 0
3208	::tkcon::term_update_cursor $::tkcon::PRIV(console)
3209	} "^\n" {
3210	# (ind,do) Move cursor down one line
3211	if {$::tcl_platform(platform) eq "windows"} {
3212	# Windows seems to get the LF without the CR
3213	update idle
3214	set ::tkcon::EXP(col) 0
3215	}
3216	::tkcon::term_down $::tkcon::PRIV(console)
3217	::tkcon::term_update_cursor $::tkcon::PRIV(console)
3218	} "^\b" {
3219	# Backspace nondestructively
3220	incr ::tkcon::EXP(col) -1
3221	::tkcon::term_update_cursor $::tkcon::PRIV(console)
3222	} "^\a" {
3223	bell
3224	} "^\t" {
3225	# Tab, shouldn't happen
3226	send_error "got a tab!?"
3227	} eof {
3228	::tkcon::term_exit $::tkcon::PRIV(console)
3229	} "^\x1b\\\[A" {
3230	# Cursor Up (cuu1,up)
3231	incr ::tkcon::EXP(row) -1
3232	::tkcon::term_update_cursor $::tkcon::PRIV(console)
3233	} "^\x1b\\\[B" {
3234	# Cursor Down
3235	incr ::tkcon::EXP(row)
3236	::tkcon::term_update_cursor $::tkcon::PRIV(console)
3237	} "^\x1b\\\[C" {
3238	# Cursor Right (cuf1,nd)
3239	incr ::tkcon::EXP(col)
3240	::tkcon::term_update_cursor $::tkcon::PRIV(console)
3241	} "^\x1b\\\[D" {
3242	# Cursor Left
3243	incr ::tkcon::EXP(col)
3244	::tkcon::term_update_cursor $::tkcon::PRIV(console)
3245	} "^\x1b\\\[H" {
3246	# Cursor Home
3247	} -re "^\x1b\\\[(\[0-9\]);(\[0-9\])H" {
3248	# (cup,cm) Move to row y col x
3249	set ::tkcon::EXP(row) [expr {$expect_out(1,string)+1}]
3250	set ::tkcon::EXP(col) $expect_out(2,string)
3251	::tkcon::term_update_cursor $::tkcon::PRIV(console)
3252	} "^\x1b\\\[H\x1b\\\[J" {
3253	# (clear,cl) Clear screen
3254	::tkcon::term_clear $::tkcon::PRIV(console)
3255	::tkcon::term_update_cursor $::tkcon::PRIV(console)
3256	} "^\x1b\\\[7m" {
3257	# (smso,so) Begin standout mode
3258	set ::tkcon::EXP(standout) 1
3259	} "^\x1b\\\[m" {
3260	# (rmso,se) End standout mode
3261	set ::tkcon::EXP(standout) 0
3262	} "^\x1b\\\[KS" {
3263	# (smkx,ks) start keyboard-transmit mode
3264	# terminfo invokes these when going in/out of graphics mode
3265	# In graphics mode, we should have no scrollbars
3266	#graphicsSet 1
3267	} "^\x1b\\\[KE" {
3268	# (rmkx,ke) end keyboard-transmit mode
3269	# Out of graphics mode, we should have scrollbars
3270	#graphicsSet 0
3271	}
3272	}
3273	}
3274	#vwait ::tkcon::EXP(forever)
3275	} err]
3276	bind $PRIV(console) <Meta-KeyPress> {}
3277	bind $PRIV(console) <KeyPress> {}
3278	bind $PRIV(console) <Control-space> {}
3279	catch {unset EXP}
3280	if {$code} {
3281	return -code $code -errorinfo $::errorInfo $err
3282	}
3283	}
3284
3285	## tkcon - command that allows control over the console
3286	## This always exists in the main interpreter, and is aliased into
3287	## other connected interpreters
3288	# ARGS: totally variable, see internal comments
3289	##
3290	proc tkcon {cmd args} {
3291	variable ::tkcon::PRIV
3292	variable ::tkcon::OPT
3293	global errorInfo
3294
3295	switch -glob -- $cmd {
3296	buf* {
3297	## 'buffer' Sets/Query the buffer size
3298	if {[llength $args]} {
3299	if {[regexp {^[1-9][0-9]*$} $args]} {
3300	set OPT(buffer) $args
3301	# catch in case the console doesn't exist yet
3302	catch {::tkcon::ConstrainBuffer $PRIV(console) \
3303	$OPT(buffer)}
3304	} else {
3305	return -code error "buffer must be a valid integer"
3306	}
3307	}
3308	return $OPT(buffer)
3309	}
3310	linelen* {
3311	## 'linelength' Sets/Query the maximum line length
3312	if {[llength $args]} {
3313	if {[regexp {^-?[0-9]+$} $args]} {
3314	set OPT(maxlinelen) $args
3315	} else {
3316	return -code error "buffer must be a valid integer"
3317	}
3318	}
3319	return $OPT(maxlinelen)
3320	}
3321	bg* {
3322	## 'bgerror' Brings up an error dialog
3323	set errorInfo [lindex $args 1]
3324	bgerror [lindex $args 0]
3325	}
3326	cl* {
3327	## 'close' Closes the console
3328	::tkcon::Destroy
3329	}
3330	cons* {
3331	## 'console' - passes the args to the text widget of the console.
3332	set result [uplevel 1 $PRIV(console) $args]
3333	::tkcon::ConstrainBuffer $PRIV(console) \
3334	$OPT(buffer)
3335	return $result
3336	}
3337	congets {
3338	## 'congets' a replacement for [gets stdin]
3339	# Use the 'gets' alias of 'tkcon_gets' command instead of
3340	# calling the get methods directly for best compatability
3341	if {[llength $args]} {
3342	return -code error "wrong # args: must be \"tkcon congets\""
3343	}
3344	tkcon show
3345	set old [bind TkConsole <<TkCon_Eval>>]
3346	bind TkConsole <<TkCon_Eval>> { set ::tkcon::PRIV(wait) 0 }
3347	set w $PRIV(console)
3348	# Make sure to move the limit to get the right data
3349	$w mark set insert end
3350	$w mark set limit insert
3351	$w see end
3352	vwait ::tkcon::PRIV(wait)
3353	set line [::tkcon::CmdGet $w]
3354	$w insert end \n
3355	bind TkConsole <<TkCon_Eval>> $old
3356	return $line
3357	}
3358	exp* {
3359	::tkcon::Expect [lindex $args 0]
3360	}
3361	getc* {
3362	## 'getcommand' a replacement for [gets stdin]
3363	## This forces a complete command to be input though
3364	if {[llength $args]} {
3365	return -code error "wrong # args: must be \"tkcon getcommand\""
3366	}
3367	tkcon show
3368	set old [bind TkConsole <<TkCon_Eval>>]
3369	bind TkConsole <<TkCon_Eval>> { set ::tkcon::PRIV(wait) 0 }
3370	set w $PRIV(console)
3371	# Make sure to move the limit to get the right data
3372	$w mark set insert end
3373	$w mark set limit insert
3374	$w see end
3375	vwait ::tkcon::PRIV(wait)
3376	set line [::tkcon::CmdGet $w]
3377	$w insert end \n
3378	while {![info complete $line] \|\| [regexp {[^\\]\\$} $line]} {
3379	vwait ::tkcon::PRIV(wait)
3380	set line [::tkcon::CmdGet $w]
3381	$w insert end \n
3382	$w see end
3383	}
3384	bind TkConsole <<TkCon_Eval>> $old
3385	return $line
3386	}
3387	get - gets {
3388	## 'gets' - a replacement for [gets stdin]
3389	## This pops up a text widget to be used for stdin (local grabbed)
3390	if {[llength $args]} {
3391	return -code error "wrong # args: should be \"tkcon gets\""
3392	}
3393	set t $PRIV(base).gets
3394	if {![winfo exists $t]} {
3395	toplevel $t
3396	wm withdraw $t
3397	wm title $t "tkcon gets stdin request"
3398	label $t.gets -text "\"gets stdin\" request:"
3399	text $t.data -width 32 -height 5 -wrap none \
3400	-xscrollcommand [list $t.sx set] \
3401	-yscrollcommand [list $t.sy set]
3402	scrollbar $t.sx -orient h -takefocus 0 -highlightthick 0 \
3403	-command [list $t.data xview]
3404	scrollbar $t.sy -orient v -takefocus 0 -highlightthick 0 \
3405	-command [list $t.data yview]
3406	button $t.ok -text "OK" -command {set ::tkcon::PRIV(grab) 1}
3407	bind $t.ok <Return> { %W invoke }
3408	grid $t.gets - -sticky ew
3409	grid $t.data $t.sy -sticky news
3410	grid $t.sx -sticky ew
3411	grid $t.ok - -sticky ew
3412	grid columnconfig $t 0 -weight 1
3413	grid rowconfig $t 1 -weight 1
3414	wm transient $t $PRIV(root)
3415	wm geometry $t +[expr {([winfo screenwidth $t]-[winfo \
3416	reqwidth $t]) / 2}]+[expr {([winfo \
3417	screenheight $t]-[winfo reqheight $t]) / 2}]
3418	}
3419	$t.data delete 1.0 end
3420	wm deiconify $t
3421	raise $t
3422	grab $t
3423	focus $t.data
3424	vwait ::tkcon::PRIV(grab)
3425	grab release $t
3426	wm withdraw $t
3427	return [$t.data get 1.0 end-1c]
3428	}
3429	err* {
3430	## Outputs stack caused by last error.
3431	## error handling with pizazz (but with pizza would be nice too)
3432	if {[llength $args]==2} {
3433	set app [lindex $args 0]
3434	set type [lindex $args 1]
3435	if {[catch {::tkcon::EvalOther $app $type set errorInfo} info]} {
3436	set info "error getting info from $type $app:\n$info"
3437	}
3438	} else {
3439	set info $PRIV(errorInfo)
3440	}
3441	if {[string match {} $info]} { set info "errorInfo empty" }
3442	## If args is empty, the -attach switch just ignores it
3443	$OPT(edit) -attach $args -type error -- $info
3444	}
3445	fi* {
3446	## 'find' string
3447	::tkcon::Find $PRIV(console) $args
3448	}
3449	fo* {
3450	## 'font' ?fontname? - gets/sets the font of the console
3451	if {[llength $args]} {
3452	if {[info exists PRIV(console)] && \
3453	[winfo exists $PRIV(console)]} {
3454	$PRIV(console) config -font $args
3455	set OPT(font) [$PRIV(console) cget -font]
3456	} else {
3457	set OPT(font) $args
3458	}
3459	}
3460	return $OPT(font)
3461	}
3462	hid* - with* {
3463	## 'hide' 'withdraw' - hides the console.
3464	if {[info exists PRIV(root)] && [winfo exists $PRIV(root)]} {
3465	wm withdraw $PRIV(root)
3466	}
3467	}
3468	his* {
3469	## 'history'
3470	set sub {\2}
3471	if {[string match -new* $args]} { append sub "\n"}
3472	set h [::tkcon::EvalSlave history]
3473	regsub -all "( \[0-9\]+ \|\t)(\[^\n\]\n?)" $h $sub h
3474	return $h
3475	}
3476	ico* {
3477	## 'iconify' - iconifies the console with 'iconify'.
3478	if {[info exists PRIV(root)] && [winfo exists $PRIV(root)]} {
3479	wm iconify $PRIV(root)
3480	}
3481	}
3482	mas* - eval {
3483	## 'master' - evals contents in master interpreter
3484	uplevel \#0 $args
3485	}
3486	set {
3487	## 'set' - set (or get, or unset) simple vars (not whole arrays)
3488	## from the master console interpreter
3489	## possible formats:
3490	## tkcon set <var>
3491	## tkcon set <var> <value>
3492	## tkcon set <var> <interp> <var1> <var2> w
3493	## tkcon set <var> <interp> <var1> <var2> u
3494	## tkcon set <var> <interp> <var1> <var2> r
3495	if {[llength $args]==5} {
3496	## This is for use w/ 'tkcon upvar' and only works with slaves
3497	foreach {var i var1 var2 op} $args break
3498	if {[string compare {} $var2]} { append var1 "($var2)" }
3499	switch $op {
3500	u { uplevel \#0 [list unset $var] }
3501	w {
3502	return [uplevel \#0 [list set $var \
3503	[interp eval $i [list set $var1]]]]
3504	}
3505	r {
3506	return [interp eval $i [list set $var1 \
3507	[uplevel \#0 [list set $var]]]]
3508	}
3509	}
3510	} elseif {[llength $args] == 1} {
3511	upvar \#0 [lindex $args 0] var
3512	if {[array exists var]} {
3513	return [array get var]
3514	} else {
3515	return $var
3516	}
3517	}
3518	return [uplevel \#0 set $args]
3519	}
3520	append {
3521	## Modify a var in the master environment using append
3522	return [uplevel \#0 append $args]
3523	}
3524	lappend {
3525	## Modify a var in the master environment using lappend
3526	return [uplevel \#0 lappend $args]
3527	}
3528	sh* - dei* {
3529	## 'show\|deiconify' - deiconifies the console.
3530	if {![info exists PRIV(root)]} {
3531	set PRIV(showOnStartup) 0
3532	set PRIV(root) .tkcon
3533	set OPT(exec) ""
3534	}
3535	if {![winfo exists $PRIV(root)]} {
3536	::tkcon::Init
3537	}
3538	wm deiconify $PRIV(root)
3539	raise $PRIV(root)
3540	focus -force $PRIV(console)
3541	}
3542	ti* {
3543	## 'title' ?title? - gets/sets the console's title
3544	if {[llength $args]} {
3545	return [wm title $PRIV(root) [join $args]]
3546	} else {
3547	return [wm title $PRIV(root)]
3548	}
3549	}
3550	upv* {
3551	## 'upvar' masterVar slaveVar
3552	## link slave variable slaveVar to the master variable masterVar
3553	## only works masters<->slave
3554	set masterVar [lindex $args 0]
3555	set slaveVar [lindex $args 1]
3556	if {[info exists $masterVar]} {
3557	interp eval $OPT(exec) \
3558	[list set $slaveVar [set $masterVar]]
3559	} else {
3560	catch {interp eval $OPT(exec) [list unset $slaveVar]}
3561	}
3562	interp eval $OPT(exec) \
3563	[list trace variable $slaveVar rwu \
3564	[list tkcon set $masterVar $OPT(exec)]]
3565	return
3566	}
3567	v* {
3568	return $PRIV(version)
3569	}
3570	default {
3571	## tries to determine if the command exists, otherwise throws error
3572	set new ::tkcon::[string toupper \
3573	[string index $cmd 0]][string range $cmd 1 end]
3574	if {[llength [info command $new]]} {
3575	uplevel \#0 $new $args
3576	} else {
3577	return -code error "bad option \"$cmd\": must be\
3578	[join [lsort [list attach close console destroy \
3579	font hide iconify load main master new save show \
3580	slave deiconify version title bgerror]] {, }]"
3581	}
3582	}
3583	}
3584	}
3585
3586	##
3587	## Some procedures to make up for lack of built-in shell commands
3588	##
3589
3590	## tkcon_puts -
3591	## This allows me to capture all stdout/stderr to the console window
3592	## This will be renamed to 'puts' at the appropriate time during init
3593	##
3594	# ARGS: same as usual
3595	# Outputs: the string with a color-coded text tag
3596	##
3597	proc tkcon_puts args {
3598	set len [llength $args]
3599	foreach {arg1 arg2 arg3} $args { break }
3600
3601	if {$len == 1} {
3602	tkcon console insert output "$arg1\n" stdout
3603	} elseif {$len == 2} {
3604	if {![string compare $arg1 -nonewline]} {
3605	tkcon console insert output $arg2 stdout
3606	} elseif {![string compare $arg1 stdout] \
3607	\|\| ![string compare $arg1 stderr]} {
3608	tkcon console insert output "$arg2\n" $arg1
3609	} else {
3610	set len 0
3611	}
3612	} elseif {$len == 3} {
3613	if {![string compare $arg1 -nonewline] \
3614	&& (![string compare $arg2 stdout] \
3615	\|\| ![string compare $arg2 stderr])} {
3616	tkcon console insert output $arg3 $arg2
3617	} elseif {(![string compare $arg1 stdout] \
3618	\|\| ![string compare $arg1 stderr]) \
3619	&& ![string compare $arg3 nonewline]} {
3620	tkcon console insert output $arg2 $arg1
3621	} else {
3622	set len 0
3623	}
3624	} else {
3625	set len 0
3626	}
3627
3628	## $len == 0 means it wasn't handled by tkcon above.
3629	##
3630	if {$len == 0} {
3631	global errorCode errorInfo
3632	if {[catch "tkcon_tcl_puts $args" msg]} {
3633	regsub tkcon_tcl_puts $msg puts msg
3634	regsub -all tkcon_tcl_puts $errorInfo puts errorInfo
3635	return -code error $msg
3636	}
3637	return $msg
3638	}
3639
3640	## WARNING: This update should behave well because it uses idletasks,
3641	## however, if there are weird looping problems with events, or
3642	## hanging in waits, try commenting this out.
3643	if {$len} {
3644	tkcon console see output
3645	update idletasks
3646	}
3647	}
3648
3649	## tkcon_gets -
3650	## This allows me to capture all stdin input without needing to stdin
3651	## This will be renamed to 'gets' at the appropriate time during init
3652	##
3653	# ARGS: same as gets
3654	# Outputs: same as gets
3655	##
3656	proc tkcon_gets args {
3657	set len [llength $args]
3658	if {$len != 1 && $len != 2} {
3659	return -code error \
3660	"wrong # args: should be \"gets channelId ?varName?\""
3661	}
3662	if {[string compare stdin [lindex $args 0]]} {
3663	return [uplevel 1 tkcon_tcl_gets $args]
3664	}
3665	set gtype [tkcon set ::tkcon::OPT(gets)]
3666	if {$gtype == ""} { set gtype congets }
3667	set data [tkcon $gtype]
3668	if {$len == 2} {
3669	upvar 1 [lindex $args 1] var
3670	set var $data
3671	return [string length $data]
3672	}
3673	return $data
3674	}
3675
3676	## edit - opens a file/proc/var for reading/editing
3677	##
3678	# Arguments:
3679	# type proc/file/var
3680	# what the actual name of the item
3681	# Returns: nothing
3682	##
3683	proc edit {args} {
3684	array set opts {-find {} -type {} -attach {}}
3685	while {[string match -* [lindex $args 0]]} {
3686	switch -glob -- [lindex $args 0] {
3687	-f* { set opts(-find) [lindex $args 1] }
3688	-a* { set opts(-attach) [lindex $args 1] }
3689	-t* { set opts(-type) [lindex $args 1] }
3690	-- { set args [lreplace $args 0 0]; break }
3691	default {return -code error "unknown option \"[lindex $args 0]\""}
3692	}
3693	set args [lreplace $args 0 1]
3694	}
3695	# determine who we are dealing with
3696	if {[llength $opts(-attach)]} {
3697	foreach {app type} $opts(-attach) {break}
3698	} else {
3699	foreach {app type} [tkcon attach] {break}
3700	}
3701
3702	set word [lindex $args 0]
3703	if {[string match {} $opts(-type)]} {
3704	if {[llength [::tkcon::EvalOther $app $type info commands [list $word]]]} {
3705	set opts(-type) "proc"
3706	} elseif {[llength [::tkcon::EvalOther $app $type info vars [list $word]]]} {
3707	set opts(-type) "var"
3708	} elseif {[::tkcon::EvalOther $app $type file isfile [list $word]]} {
3709	set opts(-type) "file"
3710	}
3711	}
3712	if {[string compare $opts(-type) {}]} {
3713	# Create unique edit window toplevel
3714	set w $::tkcon::PRIV(base).__edit
3715	set i 0
3716	while {[winfo exists $w[incr i]]} {}
3717	append w $i
3718	toplevel $w
3719	wm withdraw $w
3720	if {[string length $word] > 20} {
3721	wm title $w "[string range $word 0 16]... - tkcon Edit"
3722	} else {
3723	wm title $w "$word - tkcon Edit"
3724	}
3725
3726	if {[package provide ctext] != ""} {
3727	set txt [ctext $w.text]
3728	} else {
3729	set txt [text $w.text]
3730	}
3731	$w.text configure -wrap none \
3732	-xscrollcommand [list $w.sx set] \
3733	-yscrollcommand [list $w.sy set] \
3734	-foreground $::tkcon::COLOR(stdin) \
3735	-background $::tkcon::COLOR(bg) \
3736	-insertbackground $::tkcon::COLOR(cursor) \
3737	-font $::tkcon::OPT(font)
3738	catch {$w.text configure -undo 1}
3739	scrollbar $w.sx -orient h -takefocus 0 -bd 1 \
3740	-command [list $w.text xview]
3741	scrollbar $w.sy -orient v -takefocus 0 -bd 1 \
3742	-command [list $w.text yview]
3743
3744	set menu [menu $w.mbar]
3745	$w configure -menu $menu
3746
3747	## File Menu
3748	##
3749	set m [menu [::tkcon::MenuButton $menu File file]]
3750	$m add command -label "Save As..." -underline 0 \
3751	-command [list ::tkcon::Save {} widget $w.text]
3752	$m add command -label "Append To..." -underline 0 \
3753	-command [list ::tkcon::Save {} widget $w.text a+]
3754	$m add separator
3755	$m add command -label "Dismiss" -underline 0 -accel "Ctrl-w" \
3756	-command [list destroy $w]
3757	bind $w <Control-w> [list destroy $w]
3758	bind $w <$::tkcon::PRIV(meta)-w> [list destroy $w]
3759
3760	## Edit Menu
3761	##
3762	set text $w.text
3763	set m [menu [::tkcon::MenuButton $menu Edit edit]]
3764	$m add command -label "Cut" -under 2 \
3765	-command [list tk_textCut $text]
3766	$m add command -label "Copy" -under 0 \
3767	-command [list tk_textCopy $text]
3768	$m add command -label "Paste" -under 0 \
3769	-command [list tk_textPaste $text]
3770	$m add separator
3771	$m add command -label "Find" -under 0 \
3772	-command [list ::tkcon::FindBox $text]
3773
3774	## Send To Menu
3775	##
3776	set m [menu [::tkcon::MenuButton $menu "Send To..." send]]
3777	$m add command -label "Send To $app" -underline 0 \
3778	-command "::tkcon::EvalOther [list $app] $type \
3779	eval \[$w.text get 1.0 end-1c\]"
3780	set other [tkcon attach]
3781	if {[string compare $other [list $app $type]]} {
3782	$m add command -label "Send To [lindex $other 0]" \
3783	-command "::tkcon::EvalOther $other \
3784	eval \[$w.text get 1.0 end-1c\]"
3785	}
3786
3787	grid $w.text - $w.sy -sticky news
3788	grid $w.sx - -sticky ew
3789	grid columnconfigure $w 0 -weight 1
3790	grid columnconfigure $w 1 -weight 1
3791	grid rowconfigure $w 0 -weight 1
3792	} else {
3793	return -code error "unrecognized type '$word'"
3794	}
3795	switch -glob -- $opts(-type) {
3796	proc* {
3797	$w.text insert 1.0 \
3798	[::tkcon::EvalOther $app $type dump proc [list $word]]
3799	after idle [::tkcon::Highlight $w.text tcl]
3800	}
3801	var* {
3802	$w.text insert 1.0 \
3803	[::tkcon::EvalOther $app $type dump var [list $word]]
3804	after idle [::tkcon::Highlight $w.text tcl]
3805	}
3806	file {
3807	$w.text insert 1.0 [::tkcon::EvalOther $app $type eval \
3808	[subst -nocommands {
3809	set __tkcon(fid) [open $word r]
3810	set __tkcon(data) [read \$__tkcon(fid)]
3811	close \$__tkcon(fid)
3812	after 1000 unset __tkcon
3813	return \$__tkcon(data)
3814	}
3815	]]
3816	after idle [::tkcon::Highlight $w.text \
3817	[string trimleft [file extension $word] .]]
3818	}
3819	error* {
3820	$w.text insert 1.0 [join $args \n]
3821	after idle [::tkcon::Highlight $w.text error]
3822	}
3823	default {
3824	$w.text insert 1.0 [join $args \n]
3825	}
3826	}
3827	wm deiconify $w
3828	focus $w.text
3829	if {[string compare $opts(-find) {}]} {
3830	::tkcon::Find $w.text $opts(-find) -case 1
3831	}
3832	}
3833	interp alias {} ::more {} ::edit
3834	interp alias {} ::less {} ::edit
3835
3836	## echo
3837	## Relaxes the one string restriction of 'puts'
3838	# ARGS: any number of strings to output to stdout
3839	##
3840	proc echo args { puts stdout [concat $args] }
3841
3842	## clear - clears the buffer of the console (not the history though)
3843	## This is executed in the parent interpreter
3844	##
3845	proc clear {{pcnt 100}} {
3846	if {![regexp {^[0-9]*$} $pcnt] \|\| $pcnt < 1 \|\| $pcnt > 100} {
3847	return -code error \
3848	"invalid percentage to clear: must be 1-100 (100 default)"
3849	} elseif {$pcnt == 100} {
3850	tkcon console delete 1.0 end
3851	} else {
3852	set tmp [expr {$pcnt/100.0*[tkcon console index end]}]
3853	tkcon console delete 1.0 "$tmp linestart"
3854	}
3855	}
3856
3857	## alias - akin to the csh alias command
3858	## If called with no args, then it dumps out all current aliases
3859	## If called with one arg, returns the alias of that arg (or {} if none)
3860	# ARGS: newcmd - (optional) command to bind alias to
3861	# args - command and args being aliased
3862	##
3863	proc alias {{newcmd {}} args} {
3864	if {[string match {} $newcmd]} {
3865	set res {}
3866	foreach a [interp aliases] {
3867	lappend res [list $a -> [interp alias {} $a]]
3868	}
3869	return [join $res \n]
3870	} elseif {![llength $args]} {
3871	interp alias {} $newcmd
3872	} else {
3873	eval interp alias [list {} $newcmd {}] $args
3874	}
3875	}
3876
3877	## unalias - unaliases an alias'ed command
3878	# ARGS: cmd - command to unbind as an alias
3879	##
3880	proc unalias {cmd} {
3881	interp alias {} $cmd {}
3882	}
3883
3884	## dump - outputs variables/procedure/widget info in source'able form.
3885	## Accepts glob style pattern matching for the names
3886	#
3887	# ARGS: type - type of thing to dump: must be variable, procedure, widget
3888	#
3889	# OPTS: -nocomplain
3890	# don't complain if no items of the specified type are found
3891	# -filter pattern
3892	# specifies a glob filter pattern to be used by the variable
3893	# method as an array filter pattern (it filters down for
3894	# nested elements) and in the widget method as a config
3895	# option filter pattern
3896	# -- forcibly ends options recognition
3897	#
3898	# Returns: the values of the requested items in a 'source'able form
3899	##
3900	proc dump {type args} {
3901	set whine 1
3902	set code ok
3903	if {![llength $args]} {
3904	## If no args, assume they gave us something to dump and
3905	## we'll try anything
3906	set args $type
3907	set type any
3908	}
3909	while {[string match -* [lindex $args 0]]} {
3910	switch -glob -- [lindex $args 0] {
3911	-n* { set whine 0; set args [lreplace $args 0 0] }
3912	-f* { set fltr [lindex $args 1]; set args [lreplace $args 0 1] }
3913	-- { set args [lreplace $args 0 0]; break }
3914	default {return -code error "unknown option \"[lindex $args 0]\""}
3915	}
3916	}
3917	if {$whine && ![llength $args]} {
3918	return -code error "wrong \# args: [lindex [info level 0] 0] type\
3919	?-nocomplain? ?-filter pattern? ?--? pattern ?pattern ...?"
3920	}
3921	set res {}
3922	switch -glob -- $type {
3923	c* {
3924	# command
3925	# outputs commands by figuring out, as well as possible, what it is
3926	# this does not attempt to auto-load anything
3927	foreach arg $args {
3928	if {[llength [set cmds [info commands $arg]]]} {
3929	foreach cmd [lsort $cmds] {
3930	if {[lsearch -exact [interp aliases] $cmd] > -1} {
3931	append res "\#\# ALIAS: $cmd =>\
3932	[interp alias {} $cmd]\n"
3933	} elseif {
3934	[llength [info procs $cmd]] \|\|
3935	([string match :: $cmd] &&
3936	[llength [namespace eval [namespace qual $cmd] \
3937	info procs [namespace tail $cmd]]])
3938	} {
3939	if {[catch {dump p -- $cmd} msg] && $whine} {
3940	set code error
3941	}
3942	append res $msg\n
3943	} else {
3944	append res "\#\# COMMAND: $cmd\n"
3945	}
3946	}
3947	} elseif {$whine} {
3948	append res "\#\# No known command $arg\n"
3949	set code error
3950	}
3951	}
3952	}
3953	v* {
3954	# variable
3955	# outputs variables value(s), whether array or simple.
3956	if {![info exists fltr]} { set fltr * }
3957	foreach arg $args {
3958	if {![llength [set vars [uplevel 1 info vars [list $arg]]]]} {
3959	if {[uplevel 1 info exists $arg]} {
3960	set vars $arg
3961	} elseif {$whine} {
3962	append res "\#\# No known variable $arg\n"
3963	set code error
3964	continue
3965	} else { continue }
3966	}
3967	foreach var [lsort $vars] {
3968	if {[uplevel 1 [list info locals $var]] == ""} {
3969	# use the proper scope of the var, but namespace which
3970	# won't id locals or some upvar'ed vars correctly
3971	set new [uplevel 1 \
3972	[list namespace which -variable $var]]
3973	if {$new != ""} {
3974	set var $new
3975	}
3976	}
3977	upvar 1 $var v
3978	if {[array exists v] \|\| [catch {string length $v}]} {
3979	set nst {}
3980	append res "array set [list $var] \{\n"
3981	if {[array size v]} {
3982	foreach i \
3983	[lsort -dictionary [array names v $fltr]] {
3984	upvar 0 v$$i$ __a
3985	if {[array exists __a]} {
3986	append nst "\#\# NESTED ARRAY ELEM: $i\n"
3987	append nst "upvar 0 [list $var$$i$] __a;\
3988	[dump v -filter $fltr __a]\n"
3989	} else {
3990	append res " [list $i]\t[list $v($i)]\n"
3991	}
3992	}
3993	} else {
3994	## empty array
3995	append res " empty array\n"
3996	if {$var == ""} {
3997	append nst "unset (empty)\n"
3998	} else {
3999	append nst "unset [list $var](empty)\n"
4000	}
4001	}
4002	append res "\}\n$nst"
4003	} else {
4004	append res [list set $var $v]\n
4005	}
4006	}
4007	}
4008	}
4009	p* {
4010	# procedure
4011	foreach arg $args {
4012	if {
4013	![llength [set procs [info proc $arg]]] &&
4014	([string match :: $arg] &&
4015	[llength [set ps [namespace eval \
4016	[namespace qualifier $arg] \
4017	info procs [namespace tail $arg]]]])
4018	} {
4019	set procs {}
4020	set namesp [namespace qualifier $arg]
4021	foreach p $ps {
4022	lappend procs ${namesp}::$p
4023	}
4024	}
4025	if {[llength $procs]} {
4026	foreach p [lsort $procs] {
4027	set as {}
4028	foreach a [info args $p] {
4029	if {[info default $p $a tmp]} {
4030	lappend as [list $a $tmp]
4031	} else {
4032	lappend as $a
4033	}
4034	}
4035	append res [list proc $p $as [info body $p]]\n
4036	}
4037	} elseif {$whine} {
4038	append res "\#\# No known proc $arg\n"
4039	set code error
4040	}
4041	}
4042	}
4043	w* {
4044	# widget
4045	## The user should have Tk loaded
4046	if {![llength [info command winfo]]} {
4047	return -code error "winfo not present, cannot dump widgets"
4048	}
4049	if {![info exists fltr]} { set fltr .* }
4050	foreach arg $args {
4051	if {[llength [set ws [info command $arg]]]} {
4052	foreach w [lsort $ws] {
4053	if {[winfo exists $w]} {
4054	if {[catch {$w configure} cfg]} {
4055	append res "\#\# Widget $w\
4056	does not support configure method"
4057	set code error
4058	} else {
4059	append res "\#\# [winfo class $w]\
4060	$w\n$w configure"
4061	foreach c $cfg {
4062	if {[llength $c] != 5} continue
4063	## Check to see that the option does
4064	## not match the default, then check
4065	## the item against the user filter
4066	if {[string compare [lindex $c 3] \
4067	[lindex $c 4]] && \
4068	[regexp -nocase -- $fltr $c]} {
4069	append res " \\\n\t[list [lindex $c 0]\
4070	[lindex $c 4]]"
4071	}
4072	}
4073	append res \n
4074	}
4075	}
4076	}
4077	} elseif {$whine} {
4078	append res "\#\# No known widget $arg\n"
4079	set code error
4080	}
4081	}
4082	}
4083	a* {
4084	## see if we recognize it, other complain
4085	if {[regexp {(var\|com\|proc\|widget)} \
4086	[set types [uplevel 1 what $args]]]} {
4087	foreach type $types {
4088	if {[regexp {(var\|com\|proc\|widget)} $type]} {
4089	append res "[uplevel 1 dump $type $args]\n"
4090	}
4091	}
4092	} else {
4093	set res "dump was unable to resolve type for \"$args\""
4094	set code error
4095	}
4096	}
4097	default {
4098	return -code error "bad [lindex [info level 0] 0] option\
4099	\"$type\": must be variable, command, procedure,\
4100	or widget"
4101	}
4102	}
4103	return -code $code [string trimright $res \n]
4104	}
4105
4106	## idebug - interactive debugger
4107	#
4108	# idebug body ?level?
4109	#
4110	# Prints out the body of the command (if it is a procedure) at the
4111	# specified level. <i>level</i> defaults to the current level.
4112	#
4113	# idebug break
4114	#
4115	# Creates a breakpoint within a procedure. This will only trigger
4116	# if idebug is on and the id matches the pattern. If so, TkCon will
4117	# pop to the front with the prompt changed to an idebug prompt. You
4118	# are given the basic ability to observe the call stack an query/set
4119	# variables or execute Tcl commands at any level. A separate history
4120	# is maintained in debugging mode.
4121	#
4122	# idebug echo\|{echo ?id?} ?args?
4123	#
4124	# Behaves just like "echo", but only triggers when idebug is on.
4125	# You can specify an optional id to further restrict triggering.
4126	# If no id is specified, it defaults to the name of the command
4127	# in which the call was made.
4128	#
4129	# idebug id ?id?
4130	#
4131	# Query or set the idebug id. This id is used by other idebug
4132	# methods to determine if they should trigger or not. The idebug
4133	# id can be a glob pattern and defaults to *.
4134	#
4135	# idebug off
4136	#
4137	# Turns idebug off.
4138	#
4139	# idebug on ?id?
4140	#
4141	# Turns idebug on. If 'id' is specified, it sets the id to it.
4142	#
4143	# idebug puts\|{puts ?id?} args
4144	#
4145	# Behaves just like "puts", but only triggers when idebug is on.
4146	# You can specify an optional id to further restrict triggering.
4147	# If no id is specified, it defaults to the name of the command
4148	# in which the call was made.
4149	#
4150	# idebug show type ?level? ?VERBOSE?
4151	#
4152	# 'type' must be one of vars, locals or globals. This method
4153	# will output the variables/locals/globals present in a particular
4154	# level. If VERBOSE is added, then it actually 'dump's out the
4155	# values as well. 'level' defaults to the level in which this
4156	# method was called.
4157	#
4158	# idebug trace ?level?
4159	#
4160	# Prints out the stack trace from the specified level up to the top
4161	# level. 'level' defaults to the current level.
4162	#
4163	##
4164	proc idebug {opt args} {
4165	global IDEBUG
4166
4167	if {![info exists IDEBUG(on)]} {
4168	array set IDEBUG { on 0 id * debugging 0 }
4169	}
4170	set level [expr {[info level]-1}]
4171	switch -glob -- $opt {
4172	on {
4173	if {[llength $args]} { set IDEBUG(id) $args }
4174	return [set IDEBUG(on) 1]
4175	}
4176	off { return [set IDEBUG(on) 0] }
4177	id {
4178	if {![llength $args]} {
4179	return $IDEBUG(id)
4180	} else { return [set IDEBUG(id) $args] }
4181	}
4182	break {
4183	if {!$IDEBUG(on) \|\| $IDEBUG(debugging) \|\| \
4184	([llength $args] && \
4185	![string match $IDEBUG(id) $args]) \|\| [info level]<1} {
4186	return
4187	}
4188	set IDEBUG(debugging) 1
4189	puts stderr "idebug at level \#$level: [lindex [info level -1] 0]"
4190	set tkcon [llength [info command tkcon]]
4191	if {$tkcon} {
4192	tkcon master eval set ::tkcon::OPT(prompt2) \$::tkcon::OPT(prompt1)
4193	tkcon master eval set ::tkcon::OPT(prompt1) \$::tkcon::OPT(debugPrompt)
4194	set slave [tkcon set ::tkcon::OPT(exec)]
4195	set event [tkcon set ::tkcon::PRIV(event)]
4196	tkcon set ::tkcon::OPT(exec) [tkcon master interp create debugger]
4197	tkcon set ::tkcon::PRIV(event) 1
4198	}
4199	set max $level
4200	while 1 {
4201	set err {}
4202	if {$tkcon} {
4203	# tkcon's overload of gets is advanced enough to not need
4204	# this, but we get a little better control this way.
4205	tkcon evalSlave set level $level
4206	tkcon prompt
4207	set line [tkcon getcommand]
4208	tkcon console mark set output end
4209	} else {
4210	puts -nonewline stderr "(level \#$level) debug > "
4211	gets stdin line
4212	while {![info complete $line]} {
4213	puts -nonewline "> "
4214	append line "\n[gets stdin]"
4215	}
4216	}
4217	if {[string match {} $line]} continue
4218	set key [lindex $line 0]
4219	if {![regexp {^([#-]?[0-9]+)} [lreplace $line 0 0] lvl]} {
4220	set lvl \#$level
4221	}
4222	set res {}; set c 0
4223	switch -- $key {
4224	+ {
4225	## Allow for jumping multiple levels
4226	if {$level < $max} {
4227	idebug trace [incr level] $level 0 VERBOSE
4228	}
4229	}
4230	- {
4231	## Allow for jumping multiple levels
4232	if {$level > 1} {
4233	idebug trace [incr level -1] $level 0 VERBOSE
4234	}
4235	}
4236	. { set c [catch {idebug trace $level $level 0 VERBOSE} res] }
4237	v { set c [catch {idebug show vars $lvl } res] }
4238	V { set c [catch {idebug show vars $lvl VERBOSE} res] }
4239	l { set c [catch {idebug show locals $lvl } res] }
4240	L { set c [catch {idebug show locals $lvl VERBOSE} res] }
4241	g { set c [catch {idebug show globals $lvl } res] }
4242	G { set c [catch {idebug show globals $lvl VERBOSE} res] }
4243	t { set c [catch {idebug trace 1 $max $level } res] }
4244	T { set c [catch {idebug trace 1 $max $level VERBOSE} res]}
4245	b { set c [catch {idebug body $lvl} res] }
4246	o { set res [set IDEBUG(on) [expr {!$IDEBUG(on)}]] }
4247	h - ? {
4248	puts stderr " + Move down in call stack
4249	- Move up in call stack
4250	. Show current proc name and params
4251
4252	v Show names of variables currently in scope
4253	V Show names of variables currently in scope with values
4254	l Show names of local (transient) variables
4255	L Show names of local (transient) variables with values
4256	g Show names of declared global variables
4257	G Show names of declared global variables with values
4258	t Show a stack trace
4259	T Show a verbose stack trace
4260
4261	b Show body of current proc
4262	o Toggle on/off any further debugging
4263	c,q Continue regular execution (Quit debugger)
4264	h,? Print this help
4265	default Evaluate line at current level (\#$level)"
4266	}
4267	c - q break
4268	default { set c [catch {uplevel \#$level $line} res] }
4269	}
4270	if {$tkcon} {
4271	tkcon set ::tkcon::PRIV(event) \
4272	[tkcon evalSlave eval history add [list $line]\
4273	\; history nextid]
4274	}
4275	if {$c} {
4276	puts stderr $res
4277	} elseif {[string compare {} $res]} {
4278	puts $res
4279	}
4280	}
4281	set IDEBUG(debugging) 0
4282	if {$tkcon} {
4283	tkcon master interp delete debugger
4284	tkcon master eval set ::tkcon::OPT(prompt1) \$::tkcon::OPT(prompt2)
4285	tkcon set ::tkcon::OPT(exec) $slave
4286	tkcon set ::tkcon::PRIV(event) $event
4287	tkcon prompt
4288	}
4289	}
4290	bo* {
4291	if {[regexp {^([#-]?[0-9]+)} $args level]} {
4292	return [uplevel $level {dump c -no [lindex [info level 0] 0]}]
4293	}
4294	}
4295	t* {
4296	if {[llength $args]<2} return
4297	set min [set max [set lvl $level]]
4298	set exp {^#?([0-9]+)? ?#?([0-9]+) ?#?([0-9]+)? ?(VERBOSE)?}
4299	if {![regexp $exp $args junk min max lvl verbose]} return
4300	for {set i $max} {
4301	$i>=$min && ![catch {uplevel \#$i info level 0} info]
4302	} {incr i -1} {
4303	if {$i==$lvl} {
4304	puts -nonewline stderr "* \#$i:\t"
4305	} else {
4306	puts -nonewline stderr " \#$i:\t"
4307	}
4308	set name [lindex $info 0]
4309	if {[string compare VERBOSE $verbose] \|\| \
4310	![llength [info procs $name]]} {
4311	puts $info
4312	} else {
4313	puts "proc $name {[info args $name]} { ... }"
4314	set idx 0
4315	foreach arg [info args $name] {
4316	if {[string match args $arg]} {
4317	puts "\t$arg = [lrange $info [incr idx] end]"
4318	break
4319	} else {
4320	puts "\t$arg = [lindex $info [incr idx]]"
4321	}
4322	}
4323	}
4324	}
4325	}
4326	s* {
4327	#var, local, global
4328	set level \#$level
4329	if {![regexp {^([vgl][^ ]*) ?([#-]?[0-9]+)? ?(VERBOSE)?} \
4330	$args junk type level verbose]} return
4331	switch -glob -- $type {
4332	v* { set vars [uplevel $level {lsort [info vars]}] }
4333	l* { set vars [uplevel $level {lsort [info locals]}] }
4334	g* { set vars [lremove [uplevel $level {info vars}] \
4335	[uplevel $level {info locals}]] }
4336	}
4337	if {[string match VERBOSE $verbose]} {
4338	return [uplevel $level dump var -nocomplain $vars]
4339	} else {
4340	return $vars
4341	}
4342	}
4343	e* - pu* {
4344	if {[llength $opt]==1 && [catch {lindex [info level -1] 0} id]} {
4345	set id [lindex [info level 0] 0]
4346	} else {
4347	set id [lindex $opt 1]
4348	}
4349	if {$IDEBUG(on) && [string match $IDEBUG(id) $id]} {
4350	if {[string match e* $opt]} {
4351	puts [concat $args]
4352	} else { eval puts $args }
4353	}
4354	}
4355	default {
4356	return -code error "bad [lindex [info level 0] 0] option \"$opt\",\
4357	must be: [join [lsort [list on off id break print body\
4358	trace show puts echo]] {, }]"
4359	}
4360	}
4361	}
4362
4363	## observe - like trace, but not
4364	# ARGS: opt - option
4365	# name - name of variable or command
4366	##
4367	proc observe {opt name args} {
4368	global tcl_observe
4369	switch -glob -- $opt {
4370	co* {
4371	if {[regexp {^(catch\|lreplace\|set\|puts\|for\|incr\|info\|uplevel)$} \
4372	$name]} {
4373	return -code error "cannot observe \"$name\":\
4374	infinite eval loop will occur"
4375	}
4376	set old ${name}@
4377	while {[llength [info command $old]]} { append old @ }
4378	rename $name $old
4379	set max 4
4380	regexp {^[0-9]+} $args max
4381	# handle the observe'ing of 'proc'
4382	set proccmd "proc"
4383	if {[string match "proc" $name]} { set proccmd $old }
4384	## idebug trace could be used here
4385	$proccmd $name args "
4386	for {set i \[info level\]; set max \[expr \[info level\]-$max\]} {
4387	\$i>=\$max && !\[catch {uplevel \#\$i info level 0} info\]
4388	} {incr i -1} {
4389	puts -nonewline stderr \" \#\$i:\t\"
4390	puts \$info
4391	}
4392	uplevel \[lreplace \[info level 0\] 0 0 $old\]
4393	"
4394	set tcl_observe($name) $old
4395	}
4396	cd* {
4397	if {[info exists tcl_observe($name)] && [catch {
4398	rename $name {}
4399	rename $tcl_observe($name) $name
4400	unset tcl_observe($name)
4401	} err]} { return -code error $err }
4402	}
4403	ci* {
4404	## What a useless method...
4405	if {[info exists tcl_observe($name)]} {
4406	set i $tcl_observe($name)
4407	set res "\"$name\" observes true command \"$i\""
4408	while {[info exists tcl_observe($i)]} {
4409	append res "\n\"$name\" observes true command \"$i\""
4410	set i $tcl_observe($name)
4411	}
4412	return $res
4413	}
4414	}
4415	va* - vd* {
4416	set type [lindex $args 0]
4417	set args [lrange $args 1 end]
4418	if {![regexp {^[rwu]} $type type]} {
4419	return -code error "bad [lindex [info level 0] 0] $opt type\
4420	\"$type\", must be: read, write or unset"
4421	}
4422	if {![llength $args]} { set args observe_var }
4423	foreach c [uplevel 1 [list trace vinfo $name]] {
4424	# don't double up on the traces
4425	if {[list $type $args] == $c} { return }
4426	}
4427	uplevel 1 [list trace $opt $name $type $args]
4428	}
4429	vi* {
4430	uplevel 1 [list trace vinfo $name]
4431	}
4432	default {
4433	return -code error "bad [lindex [info level 0] 0] option\
4434	\"[lindex $args 0]\", must be: [join [lsort \
4435	[list command cdelete cinfo variable vdelete vinfo]] {, }]"
4436	}
4437	}
4438	}
4439
4440	## observe_var - auxilary function for observing vars, called by trace
4441	## via observe
4442	# ARGS: name - variable name
4443	# el - array element name, if any
4444	# op - operation type (rwu)
4445	##
4446	proc observe_var {name el op} {
4447	if {[string match u $op]} {
4448	if {[string compare {} $el]} {
4449	puts "unset \"${name}($el)\""
4450	} else {
4451	puts "unset \"$name\""
4452	}
4453	} else {
4454	upvar 1 $name $name
4455	if {[info exists ${name}($el)]} {
4456	puts [dump v ${name}($el)]
4457	} else {
4458	puts [dump v $name]
4459	}
4460	}
4461	}
4462
4463	## which - tells you where a command is found
4464	# ARGS: cmd - command name
4465	# Returns: where command is found (internal / external / unknown)
4466	##
4467	proc which cmd {
4468	## This tries to auto-load a command if not recognized
4469	set types [uplevel 1 [list what $cmd 1]]
4470	if {[llength $types]} {
4471	set out {}
4472
4473	foreach type $types {
4474	switch -- $type {
4475	alias { set res "$cmd: aliased to [alias $cmd]" }
4476	procedure { set res "$cmd: procedure" }
4477	command { set res "$cmd: internal command" }
4478	executable { lappend out [auto_execok $cmd] }
4479	variable { lappend out "$cmd: $type" }
4480	}
4481	if {[info exists res]} {
4482	global auto_index
4483	if {[info exists auto_index($cmd)]} {
4484	## This tells you where the command MIGHT have come from -
4485	## not true if the command was redefined interactively or
4486	## existed before it had to be auto_loaded. This is just
4487	## provided as a hint at where it MAY have come from
4488	append res " ($auto_index($cmd))"
4489	}
4490	lappend out $res
4491	unset res
4492	}
4493	}
4494	return [join $out \n]
4495	} else {
4496	return -code error "$cmd: command not found"
4497	}
4498	}
4499
4500	## what - tells you what a string is recognized as
4501	# ARGS: str - string to id
4502	# Returns: id types of command as list
4503	##
4504	proc what {str {autoload 0}} {
4505	set types {}
4506	if {[llength [info commands $str]] \|\| ($autoload && \
4507	[auto_load $str] && [llength [info commands $str]])} {
4508	if {[lsearch -exact [interp aliases] $str] > -1} {
4509	lappend types "alias"
4510	} elseif {
4511	[llength [info procs $str]] \|\|
4512	([string match :: $str] &&
4513	[llength [namespace eval [namespace qualifier $str] \
4514	info procs [namespace tail $str]]])
4515	} {
4516	lappend types "procedure"
4517	} else {
4518	lappend types "command"
4519	}
4520	}
4521	if {[llength [uplevel 1 info vars $str]]} {
4522	upvar 1 $str var
4523	if {[array exists var]} {
4524	lappend types array variable
4525	} else {
4526	lappend types scalar variable
4527	}
4528	}
4529	if {[file isdirectory $str]} {
4530	lappend types "directory"
4531	}
4532	if {[file isfile $str]} {
4533	lappend types "file"
4534	}
4535	if {[llength [info commands winfo]] && [winfo exists $str]} {
4536	lappend types "widget"
4537	}
4538	if {[string compare {} [auto_execok $str]]} {
4539	lappend types "executable"
4540	}
4541	return $types
4542	}
4543
4544	## dir - directory list
4545	# ARGS: args - names/glob patterns of directories to list
4546	# OPTS: -all - list hidden files as well (Unix dot files)
4547	# -long - list in full format "permissions size date filename"
4548	# -full - displays / after directories and link paths for links
4549	# Returns: a directory listing
4550	##
4551	proc dir {args} {
4552	array set s {
4553	all 0 full 0 long 0
4554	0 --- 1 --x 2 -w- 3 -wx 4 r-- 5 r-x 6 rw- 7 rwx
4555	}
4556	while {[string match \-* [lindex $args 0]]} {
4557	set str [lindex $args 0]
4558	set args [lreplace $args 0 0]
4559	switch -glob -- $str {
4560	-a* {set s(all) 1} -f* {set s(full) 1}
4561	-l* {set s(long) 1} -- break
4562	default {
4563	return -code error "unknown option \"$str\",\
4564	should be one of: -all, -full, -long"
4565	}
4566	}
4567	}
4568	set sep [string trim [file join . .] .]
4569	if {![llength $args]} { set args [list [pwd]] }
4570	if {$::tcl_version >= 8.3} {
4571	# Newer glob args allow safer dir processing. The user may still
4572	# want glob chars, but really only for file matching.
4573	foreach arg $args {
4574	if {[file isdirectory $arg]} {
4575	if {$s(all)} {
4576	lappend out [list $arg [lsort \
4577	[glob -nocomplain -directory $arg .* *]]]
4578	} else {
4579	lappend out [list $arg [lsort \
4580	[glob -nocomplain -directory $arg *]]]
4581	}
4582	} else {
4583	set dir [file dirname $arg]
4584	lappend out [list $dir$sep [lsort \
4585	[glob -nocomplain -directory $dir [file tail $arg]]]]
4586	}
4587	}
4588	} else {
4589	foreach arg $args {
4590	if {[file isdirectory $arg]} {
4591	set arg [string trimright $arg $sep]$sep
4592	if {$s(all)} {
4593	lappend out [list $arg [lsort [glob -nocomplain -- $arg.* $arg*]]]
4594	} else {
4595	lappend out [list $arg [lsort [glob -nocomplain -- $arg*]]]
4596	}
4597	} else {
4598	lappend out [list [file dirname $arg]$sep \
4599	[lsort [glob -nocomplain -- $arg]]]
4600	}
4601	}
4602	}
4603	if {$s(long)} {
4604	set old [clock scan {1 year ago}]
4605	set fmt "%s%9ld %s %s\n"
4606	foreach o $out {
4607	set d [lindex $o 0]
4608	append res $d:\n
4609	foreach f [lindex $o 1] {
4610	file lstat $f st
4611	set f [file tail $f]
4612	if {$s(full)} {
4613	switch -glob $st(type) {
4614	d* { append f $sep }
4615	l* { append f "@ -> [file readlink $d$sep$f]" }
4616	default { if {[file exec $d$sep$f]} { append f * } }
4617	}
4618	}
4619	if {[string match file $st(type)]} {
4620	set mode -
4621	} else {
4622	set mode [string index $st(type) 0]
4623	}
4624	foreach j [split [format %03o [expr {$st(mode)&0777}]] {}] {
4625	append mode $s($j)
4626	}
4627	if {$st(mtime)>$old} {
4628	set cfmt {%b %d %H:%M}
4629	} else {
4630	set cfmt {%b %d %Y}
4631	}
4632	append res [format $fmt $mode $st(size) \
4633	[clock format $st(mtime) -format $cfmt] $f]
4634	}
4635	append res \n
4636	}
4637	} else {
4638	foreach o $out {
4639	set d [lindex $o 0]
4640	append res "$d:\n"
4641	set i 0
4642	foreach f [lindex $o 1] {
4643	if {[string len [file tail $f]] > $i} {
4644	set i [string len [file tail $f]]
4645	}
4646	}
4647	set i [expr {$i+2+$s(full)}]
4648	set j 80
4649	## This gets the number of cols in the tkcon console widget
4650	if {[llength [info commands tkcon]]} {
4651	set j [expr {[tkcon master set ::tkcon::OPT(cols)]/$i}]
4652	}
4653	set k 0
4654	foreach f [lindex $o 1] {
4655	set f [file tail $f]
4656	if {$s(full)} {
4657	switch -glob [file type $d$sep$f] {
4658	d* { append f $sep }
4659	l* { append f @ }
4660	default { if {[file exec $d$sep$f]} { append f * } }
4661	}
4662	}
4663	append res [format "%-${i}s" $f]
4664	if {$j == 0 \|\| [incr k]%$j == 0} {
4665	set res [string trimright $res]\n
4666	}
4667	}
4668	append res \n\n
4669	}
4670	}
4671	return [string trimright $res]
4672	}
4673	interp alias {} ::ls {} ::dir -full
4674
4675	## lremove - remove items from a list
4676	# OPTS:
4677	# -all remove all instances of each item
4678	# -glob remove all instances matching glob pattern
4679	# -regexp remove all instances matching regexp pattern
4680	# ARGS: l a list to remove items from
4681	# args items to remove (these are 'join'ed together)
4682	##
4683	proc lremove {args} {
4684	array set opts {-all 0 pattern -exact}
4685	while {[string match -* [lindex $args 0]]} {
4686	switch -glob -- [lindex $args 0] {
4687	-a* { set opts(-all) 1 }
4688	-g* { set opts(pattern) -glob }
4689	-r* { set opts(pattern) -regexp }
4690	-- { set args [lreplace $args 0 0]; break }
4691	default {return -code error "unknown option \"[lindex $args 0]\""}
4692	}
4693	set args [lreplace $args 0 0]
4694	}
4695	set l [lindex $args 0]
4696	foreach i [join [lreplace $args 0 0]] {
4697	if {[set ix [lsearch $opts(pattern) $l $i]] == -1} continue
4698	set l [lreplace $l $ix $ix]
4699	if {$opts(-all)} {
4700	while {[set ix [lsearch $opts(pattern) $l $i]] != -1} {
4701	set l [lreplace $l $ix $ix]
4702	}
4703	}
4704	}
4705	return $l
4706	}
4707
4708	if {!$::tkcon::PRIV(WWW)} {;
4709
4710	## Unknown changed to get output into tkcon window
4711	# unknown:
4712	# Invoked automatically whenever an unknown command is encountered.
4713	# Works through a list of "unknown handlers" that have been registered
4714	# to deal with unknown commands. Extensions can integrate their own
4715	# handlers into the 'unknown' facility via 'unknown_handler'.
4716	#
4717	# If a handler exists that recognizes the command, then it will
4718	# take care of the command action and return a valid result or a
4719	# Tcl error. Otherwise, it should return "-code continue" (=2)
4720	# and responsibility for the command is passed to the next handler.
4721	#
4722	# Arguments:
4723	# args - A list whose elements are the words of the original
4724	# command, including the command name.
4725
4726	proc unknown args {
4727	global unknown_handler_order unknown_handlers errorInfo errorCode
4728
4729	#
4730	# Be careful to save error info now, and restore it later
4731	# for each handler. Some handlers generate their own errors
4732	# and disrupt handling.
4733	#
4734	set savedErrorCode $errorCode
4735	set savedErrorInfo $errorInfo
4736
4737	if {![info exists unknown_handler_order] \|\| \
4738	![info exists unknown_handlers]} {
4739	set unknown_handlers(tcl) tcl_unknown
4740	set unknown_handler_order tcl
4741	}
4742
4743	foreach handler $unknown_handler_order {
4744	set status [catch {uplevel 1 $unknown_handlers($handler) $args} result]
4745
4746	if {$status == 1} {
4747	#
4748	# Strip the last five lines off the error stack (they're
4749	# from the "uplevel" command).
4750	#
4751	set new [split $errorInfo \n]
4752	set new [join [lrange $new 0 [expr {[llength $new]-6}]] \n]
4753	return -code $status -errorcode $errorCode \
4754	-errorinfo $new $result
4755
4756	} elseif {$status != 4} {
4757	return -code $status $result
4758	}
4759
4760	set errorCode $savedErrorCode
4761	set errorInfo $savedErrorInfo
4762	}
4763
4764	set name [lindex $args 0]
4765	return -code error "invalid command name \"$name\""
4766	}
4767
4768	# tcl_unknown:
4769	# Invoked when a Tcl command is invoked that doesn't exist in the
4770	# interpreter:
4771	#
4772	# 1. See if the autoload facility can locate the command in a
4773	# Tcl script file. If so, load it and execute it.
4774	# 2. If the command was invoked interactively at top-level:
4775	# (a) see if the command exists as an executable UNIX program.
4776	# If so, "exec" the command.
4777	# (b) see if the command requests csh-like history substitution
4778	# in one of the common forms !!, !<number>, or ^old^new. If
4779	# so, emulate csh's history substitution.
4780	# (c) see if the command is a unique abbreviation for another
4781	# command. If so, invoke the command.
4782	#
4783	# Arguments:
4784	# args - A list whose elements are the words of the original
4785	# command, including the command name.
4786
4787	proc tcl_unknown args {
4788	global auto_noexec auto_noload env unknown_pending tcl_interactive
4789	global errorCode errorInfo
4790
4791	# If the command word has the form "namespace inscope ns cmd"
4792	# then concatenate its arguments onto the end and evaluate it.
4793
4794	set cmd [lindex $args 0]
4795	if {[regexp "^:*namespace\[ \t\n\]+inscope" $cmd] \
4796	&& [llength $cmd] == 4} {
4797	set arglist [lrange $args 1 end]
4798	set ret [catch {uplevel 1 $cmd $arglist} result]
4799	if {$ret == 0} {
4800	return $result
4801	} else {
4802	return -code $ret -errorcode $errorCode $result
4803	}
4804	}
4805
4806	# Save the values of errorCode and errorInfo variables, since they
4807	# may get modified if caught errors occur below. The variables will
4808	# be restored just before re-executing the missing command.
4809
4810	set savedErrorCode $errorCode
4811	set savedErrorInfo $errorInfo
4812	set name [lindex $args 0]
4813	if {![info exists auto_noload]} {
4814	#
4815	# Make sure we're not trying to load the same proc twice.
4816	#
4817	if {[info exists unknown_pending($name)]} {
4818	return -code error "self-referential recursion in \"unknown\" for command \"$name\""
4819	}
4820	set unknown_pending($name) pending
4821	if {[llength [info args auto_load]]==1} {
4822	set ret [catch {auto_load $name} msg]
4823	} else {
4824	set ret [catch {auto_load $name [uplevel 1 {namespace current}]} msg]
4825	}
4826	unset unknown_pending($name)
4827	if {$ret} {
4828	return -code $ret -errorcode $errorCode \
4829	"error while autoloading \"$name\": $msg"
4830	}
4831	if {![array size unknown_pending]} { unset unknown_pending }
4832	if {$msg} {
4833	set errorCode $savedErrorCode
4834	set errorInfo $savedErrorInfo
4835	set code [catch {uplevel 1 $args} msg]
4836	if {$code == 1} {
4837	#
4838	# Strip the last five lines off the error stack (they're
4839	# from the "uplevel" command).
4840	#
4841
4842	set new [split $errorInfo \n]
4843	set new [join [lrange $new 0 [expr {[llength $new]-6}]] \n]
4844	return -code error -errorcode $errorCode \
4845	-errorinfo $new $msg
4846	} else {
4847	return -code $code $msg
4848	}
4849	}
4850	}
4851	if {[info level] == 1 && [string match {} [info script]] \
4852	&& [info exists tcl_interactive] && $tcl_interactive} {
4853	if {![info exists auto_noexec]} {
4854	set new [auto_execok $name]
4855	if {[string compare {} $new]} {
4856	set errorCode $savedErrorCode
4857	set errorInfo $savedErrorInfo
4858	if {[info exists ::tkcon::EXPECT] && $::tkcon::EXPECT && [package provide Expect] != ""} {
4859	return [tkcon expect [concat $new [lrange $args 1 end]]]
4860	} else {
4861	return [uplevel 1 exec $new [lrange $args 1 end]]
4862	}
4863	#return [uplevel exec >&@stdout <@stdin $new [lrange $args 1 end]]
4864	}
4865	}
4866	set errorCode $savedErrorCode
4867	set errorInfo $savedErrorInfo
4868	##
4869	## History substitution moved into ::tkcon::EvalCmd
4870	##
4871	if {[string compare $name "::"] == 0} {
4872	set name ""
4873	}
4874	if {$ret != 0} {
4875	return -code $ret -errorcode $errorCode \
4876	"error in unknown while checking if \"$name\" is a unique command abbreviation: $msg"
4877	}
4878	set cmds [info commands $name*]
4879	if {[llength $cmds] == 1} {
4880	return [uplevel 1 [lreplace $args 0 0 $cmds]]
4881	}
4882	if {[llength $cmds]} {
4883	if {$name == ""} {
4884	return -code error "empty command name \"\""
4885	} else {
4886	return -code error \
4887	"ambiguous command name \"$name\": [lsort $cmds]"
4888	}
4889	}
4890	## We've got nothing so far
4891	## Check and see if Tk wasn't loaded, but it appears to be a Tk cmd
4892	if {![uplevel \#0 info exists tk_version]} {
4893	lappend tkcmds bell bind bindtags button \
4894	canvas checkbutton clipboard destroy \
4895	entry event focus font frame grab grid image \
4896	label labelframe listbox lower menu menubutton message \
4897	option pack panedwindow place radiobutton raise \
4898	scale scrollbar selection send spinbox \
4899	text tk tkwait toplevel winfo wm
4900	if {[lsearch -exact $tkcmds $name] >= 0 && \
4901	[tkcon master tk_messageBox -icon question -parent . \
4902	-title "Load Tk?" -type retrycancel -default retry \
4903	-message "This appears to be a Tk command, but Tk\
4904	has not yet been loaded. Shall I retry the command\
4905	with loading Tk first?"] == "retry"} {
4906	return [uplevel 1 "load {} Tk; $args"]
4907	}
4908	}
4909	}
4910	return -code continue
4911	}
4912
4913	} ; # end exclusionary code for WWW
4914
4915	proc ::tkcon::Bindings {} {
4916	variable PRIV
4917	global tcl_platform tk_version
4918
4919	#-----------------------------------------------------------------------
4920	# Elements of tkPriv that are used in this file:
4921	#
4922	# char - Character position on the line; kept in order
4923	# to allow moving up or down past short lines while
4924	# still remembering the desired position.
4925	# mouseMoved - Non-zero means the mouse has moved a significant
4926	# amount since the button went down (so, for example,
4927	# start dragging out a selection).
4928	# prevPos - Used when moving up or down lines via the keyboard.
4929	# Keeps track of the previous insert position, so
4930	# we can distinguish a series of ups and downs, all
4931	# in a row, from a new up or down.
4932	# selectMode - The style of selection currently underway:
4933	# char, word, or line.
4934	# x, y - Last known mouse coordinates for scanning
4935	# and auto-scanning.
4936	#-----------------------------------------------------------------------
4937
4938	switch -glob $tcl_platform(platform) {
4939	win* { set PRIV(meta) Alt }
4940	mac* { set PRIV(meta) Command }
4941	default { set PRIV(meta) Meta }
4942	}
4943
4944	## Get all Text bindings into TkConsole
4945	foreach ev [bind Text] { bind TkConsole $ev [bind Text $ev] }
4946	## We really didn't want the newline insertion
4947	bind TkConsole <Control-Key-o> {}
4948
4949	## Now make all our virtual event bindings
4950	foreach {ev key} [subst -nocommand -noback {
4951	<<TkCon_Exit>> <Control-q>
4952	<<TkCon_New>> <Control-N>
4953	<<TkCon_NewTab>> <Control-T>
4954	<<TkCon_NextTab>> <Control-Key-Tab>
4955	<<TkCon_PrevTab>> <Control-Shift-Key-Tab>
4956	<<TkCon_Close>> <Control-w>
4957	<<TkCon_About>> <Control-A>
4958	<<TkCon_Help>> <Control-H>
4959	<<TkCon_Find>> <Control-F>
4960	<<TkCon_Slave>> <Control-Key-1>
4961	<<TkCon_Master>> <Control-Key-2>
4962	<<TkCon_Main>> <Control-Key-3>
4963	<<TkCon_Expand>> <Key-Tab>
4964	<<TkCon_ExpandFile>> <Key-Escape>
4965	<<TkCon_ExpandProc>> <Control-P>
4966	<<TkCon_ExpandVar>> <Control-V>
4967	<<TkCon_Tab>> <Control-i>
4968	<<TkCon_Tab>> <$PRIV(meta)-i>
4969	<<TkCon_Newline>> <Control-o>
4970	<<TkCon_Newline>> <$PRIV(meta)-o>
4971	<<TkCon_Newline>> <Control-Key-Return>
4972	<<TkCon_Newline>> <Control-Key-KP_Enter>
4973	<<TkCon_Eval>> <Return>
4974	<<TkCon_Eval>> <KP_Enter>
4975	<<TkCon_Clear>> <Control-l>
4976	<<TkCon_Previous>> <Up>
4977	<<TkCon_PreviousImmediate>> <Control-p>
4978	<<TkCon_PreviousSearch>> <Control-r>
4979	<<TkCon_Next>> <Down>
4980	<<TkCon_NextImmediate>> <Control-n>
4981	<<TkCon_NextSearch>> <Control-s>
4982	<<TkCon_Transpose>> <Control-t>
4983	<<TkCon_ClearLine>> <Control-u>
4984	<<TkCon_SaveCommand>> <Control-z>
4985	<<TkCon_Popup>> <Button-3>
4986	}] {
4987	event add $ev $key
4988	## Make sure the specific key won't be defined
4989	bind TkConsole $key {}
4990	}
4991
4992	## Make the ROOT bindings
4993	bind $PRIV(root) <<TkCon_Exit>> exit
4994	bind $PRIV(root) <<TkCon_New>> { ::tkcon::New }
4995	bind $PRIV(root) <<TkCon_NewTab>> { ::tkcon::NewTab }
4996	bind $PRIV(root) <<TkCon_NextTab>> { ::tkcon::GotoTab 1 ; break }
4997	bind $PRIV(root) <<TkCon_PrevTab>> { ::tkcon::GotoTab -1 ; break }
4998	bind $PRIV(root) <<TkCon_Close>> { ::tkcon::Destroy }
4999	bind $PRIV(root) <<TkCon_About>> { ::tkcon::About }
5000	bind $PRIV(root) <<TkCon_Help>> { ::tkcon::Help }
5001	bind $PRIV(root) <<TkCon_Find>> { ::tkcon::FindBox $::tkcon::PRIV(console) }
5002	bind $PRIV(root) <<TkCon_Slave>> {
5003	::tkcon::Attach {}
5004	::tkcon::RePrompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)]
5005	}
5006	bind $PRIV(root) <<TkCon_Master>> {
5007	if {[string compare {} $::tkcon::PRIV(name)]} {
5008	::tkcon::Attach $::tkcon::PRIV(name)
5009	} else {
5010	::tkcon::Attach Main
5011	}
5012	::tkcon::RePrompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)]
5013	}
5014	bind $PRIV(root) <<TkCon_Main>> {
5015	::tkcon::Attach Main
5016	::tkcon::RePrompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)]
5017	}
5018	bind $PRIV(root) <<TkCon_Popup>> {
5019	::tkcon::PopupMenu %X %Y
5020	}
5021
5022	## Menu items need null TkConsolePost bindings to avoid the TagProc
5023	##
5024	foreach ev [bind $PRIV(root)] {
5025	bind TkConsolePost $ev {
5026	# empty
5027	}
5028	}
5029
5030
5031	# ::tkcon::ClipboardKeysyms --
5032	# This procedure is invoked to identify the keys that correspond to
5033	# the copy, cut, and paste functions for the clipboard.
5034	#
5035	# Arguments:
5036	# copy - Name of the key (keysym name plus modifiers, if any,
5037	# such as "Meta-y") used for the copy operation.
5038	# cut - Name of the key used for the cut operation.
5039	# paste - Name of the key used for the paste operation.
5040
5041	proc ::tkcon::ClipboardKeysyms {copy cut paste} {
5042	bind TkConsole <$copy> {::tkcon::Copy %W}
5043	bind TkConsole <$cut> {::tkcon::Cut %W}
5044	bind TkConsole <$paste> {::tkcon::Paste %W}
5045	}
5046
5047	proc ::tkcon::GetSelection {w} {
5048	if {
5049	![catch {selection get -displayof $w -type UTF8_STRING} txt] \|\|
5050	![catch {selection get -displayof $w} txt] \|\|
5051	![catch {selection get -displayof $w -selection CLIPBOARD} txt]
5052	} {
5053	return $txt
5054	}
5055	return -code error "could not find default selection"
5056	}
5057
5058	proc ::tkcon::Cut w {
5059	if {[string match $w [selection own -displayof $w]]} {
5060	clipboard clear -displayof $w
5061	catch {
5062	set txt [selection get -displayof $w]
5063	clipboard append -displayof $w $txt
5064	if {[$w compare sel.first >= limit]} {
5065	$w delete sel.first sel.last
5066	}
5067	}
5068	}
5069	}
5070	proc ::tkcon::Copy w {
5071	if {[string match $w [selection own -displayof $w]]} {
5072	clipboard clear -displayof $w
5073	catch {
5074	set txt [selection get -displayof $w]
5075	clipboard append -displayof $w $txt
5076	}
5077	}
5078	}
5079	proc ::tkcon::Paste w {
5080	if {![catch {GetSelection $w} txt]} {
5081	if {[$w compare insert < limit]} { $w mark set insert end }
5082	$w insert insert $txt
5083	$w see insert
5084	if {[string match \n $txt]} { ::tkcon::Eval $w }
5085	}
5086	}
5087
5088	## Redefine for TkConsole what we need
5089	##
5090	event delete <<Paste>> <Control-V>
5091	::tkcon::ClipboardKeysyms <Copy> <Cut> <Paste>
5092
5093	bind TkConsole <Insert> {
5094	catch { ::tkcon::Insert %W [::tkcon::GetSelection %W] }
5095	}
5096
5097	bind TkConsole <Triple-1> {+
5098	catch {
5099	eval %W tag remove sel [%W tag nextrange prompt sel.first sel.last]
5100	eval %W tag remove sel sel.last-1c
5101	%W mark set insert sel.first
5102	}
5103	}
5104
5105	## binding editor needed
5106	## binding <events> for .tkconrc
5107
5108	bind TkConsole <<TkCon_ExpandFile>> {
5109	if {[%W compare insert > limit]} {::tkcon::Expand %W path}
5110	break
5111	}
5112	bind TkConsole <<TkCon_ExpandProc>> {
5113	if {[%W compare insert > limit]} {::tkcon::Expand %W proc}
5114	}
5115	bind TkConsole <<TkCon_ExpandVar>> {
5116	if {[%W compare insert > limit]} {::tkcon::Expand %W var}
5117	}
5118	bind TkConsole <<TkCon_Expand>> {
5119	if {[%W compare insert > limit]} {::tkcon::Expand %W}
5120	}
5121	bind TkConsole <<TkCon_Tab>> {
5122	if {[%W compare insert >= limit]} {
5123	::tkcon::Insert %W \t
5124	}
5125	}
5126	bind TkConsole <<TkCon_Newline>> {
5127	if {[%W compare insert >= limit]} {
5128	::tkcon::Insert %W \n
5129	}
5130	}
5131	bind TkConsole <<TkCon_Eval>> {
5132	::tkcon::Eval %W
5133	}
5134	bind TkConsole <Delete> {
5135	if {[llength [%W tag nextrange sel 1.0 end]] \
5136	&& [%W compare sel.first >= limit]} {
5137	%W delete sel.first sel.last
5138	} elseif {[%W compare insert >= limit]} {
5139	%W delete insert
5140	%W see insert
5141	}
5142	}
5143	bind TkConsole <BackSpace> {
5144	if {[llength [%W tag nextrange sel 1.0 end]] \
5145	&& [%W compare sel.first >= limit]} {
5146	%W delete sel.first sel.last
5147	} elseif {[%W compare insert != 1.0] && [%W compare insert > limit]} {
5148	%W delete insert-1c
5149	%W see insert
5150	}
5151	}
5152	bind TkConsole <Control-h> [bind TkConsole <BackSpace>]
5153
5154	bind TkConsole <KeyPress> {
5155	::tkcon::Insert %W %A
5156	}
5157
5158	bind TkConsole <Control-a> {
5159	if {[%W compare {limit linestart} == {insert linestart}]} {
5160	tkTextSetCursor %W limit
5161	} else {
5162	tkTextSetCursor %W {insert linestart}
5163	}
5164	}
5165	bind TkConsole <Key-Home> [bind TkConsole <Control-a>]
5166	bind TkConsole <Control-d> {
5167	if {[%W compare insert < limit]} break
5168	%W delete insert
5169	}
5170	bind TkConsole <Control-k> {
5171	if {[%W compare insert < limit]} break
5172	if {[%W compare insert == {insert lineend}]} {
5173	%W delete insert
5174	} else {
5175	%W delete insert {insert lineend}
5176	}
5177	}
5178	bind TkConsole <<TkCon_Clear>> {
5179	## Clear console buffer, without losing current command line input
5180	set ::tkcon::PRIV(tmp) [::tkcon::CmdGet %W]
5181	clear
5182	::tkcon::Prompt {} $::tkcon::PRIV(tmp)
5183	}
5184	bind TkConsole <<TkCon_Previous>> {
5185	if {[%W compare {insert linestart} != {limit linestart}]} {
5186	tkTextSetCursor %W [tkTextUpDownLine %W -1]
5187	} else {
5188	::tkcon::Event -1
5189	}
5190	}
5191	bind TkConsole <<TkCon_Next>> {
5192	if {[%W compare {insert linestart} != {end-1c linestart}]} {
5193	tkTextSetCursor %W [tkTextUpDownLine %W 1]
5194	} else {
5195	::tkcon::Event 1
5196	}
5197	}
5198	bind TkConsole <<TkCon_NextImmediate>> { ::tkcon::Event 1 }
5199	bind TkConsole <<TkCon_PreviousImmediate>> { ::tkcon::Event -1 }
5200	bind TkConsole <<TkCon_PreviousSearch>> {
5201	::tkcon::Event -1 [::tkcon::CmdGet %W]
5202	}
5203	bind TkConsole <<TkCon_NextSearch>> {
5204	::tkcon::Event 1 [::tkcon::CmdGet %W]
5205	}
5206	bind TkConsole <<TkCon_Transpose>> {
5207	## Transpose current and previous chars
5208	if {[%W compare insert > "limit+1c"]} { tkTextTranspose %W }
5209	}
5210	bind TkConsole <<TkCon_ClearLine>> {
5211	## Clear command line (Unix shell staple)
5212	%W delete limit end
5213	}
5214	bind TkConsole <<TkCon_SaveCommand>> {
5215	## Save command buffer (swaps with current command)
5216	set ::tkcon::PRIV(tmp) $::tkcon::PRIV(cmdsave)
5217	set ::tkcon::PRIV(cmdsave) [::tkcon::CmdGet %W]
5218	if {[string match {} $::tkcon::PRIV(cmdsave)]} {
5219	set ::tkcon::PRIV(cmdsave) $::tkcon::PRIV(tmp)
5220	} else {
5221	%W delete limit end-1c
5222	}
5223	::tkcon::Insert %W $::tkcon::PRIV(tmp)
5224	%W see end
5225	}
5226	catch {bind TkConsole <Key-Page_Up> { tkTextScrollPages %W -1 }}
5227	catch {bind TkConsole <Key-Prior> { tkTextScrollPages %W -1 }}
5228	catch {bind TkConsole <Key-Page_Down> { tkTextScrollPages %W 1 }}
5229	catch {bind TkConsole <Key-Next> { tkTextScrollPages %W 1 }}
5230	bind TkConsole <$PRIV(meta)-d> {
5231	if {[%W compare insert >= limit]} {
5232	%W delete insert {insert wordend}
5233	}
5234	}
5235	bind TkConsole <$PRIV(meta)-BackSpace> {
5236	if {[%W compare {insert -1c wordstart} >= limit]} {
5237	%W delete {insert -1c wordstart} insert
5238	}
5239	}
5240	bind TkConsole <$PRIV(meta)-Delete> {
5241	if {[%W compare insert >= limit]} {
5242	%W delete insert {insert wordend}
5243	}
5244	}
5245	bind TkConsole <ButtonRelease-2> {
5246	if {
5247	(!$tkPriv(mouseMoved) \|\| $tk_strictMotif) &&
5248	![catch {::tkcon::GetSelection %W} ::tkcon::PRIV(tmp)]
5249	} {
5250	if {[%W compare @%x,%y < limit]} {
5251	%W insert end $::tkcon::PRIV(tmp)
5252	} else {
5253	%W insert @%x,%y $::tkcon::PRIV(tmp)
5254	}
5255	if {[string match \n $::tkcon::PRIV(tmp)]} {::tkcon::Eval %W}
5256	}
5257	}
5258
5259	##
5260	## End TkConsole bindings
5261	##
5262
5263	##
5264	## Bindings for doing special things based on certain keys
5265	##
5266	bind TkConsolePost <Key-parenright> {
5267	if {$::tkcon::OPT(lightbrace) && $::tkcon::OPT(blinktime)>99 && \
5268	[string compare \\ [%W get insert-2c]]} {
5269	::tkcon::MatchPair %W