1#!/bin/sh
2# \
3exec wish4.1 "$0" ${1+"$@"}
4
5#
6## stripped.tcl
7## Stripped down version of Tk Console Widget, part of the VerTcl system
8## Stripped to work with Netscape Tk Plugin.
9##
10## Copyright (c) 1995,1996 by Jeffrey Hobbs
11## jhobbs@cs.uoregon.edu, http://www.cs.uoregon.edu/~jhobbs/
12## source standard_disclaimer.tcl
13
14if {[info tclversion] < 7.5} {
15  error "TkCon requires at least the stable version of tcl7.5/tk4.1"
16}
17
18## tkConInit - inits tkCon
19# ARGS:	root	- widget pathname of the tkCon console root
20#	title	- title for the console root and main (.) windows
21# Calls:	tkConInitUI
22# Outputs:	errors found in tkCon resource file
23##
24proc tkConInit {{title Main}} {
25  global tkCon tcl_platform env auto_path tcl_interactive
26
27  set tcl_interactive 1
28
29  array set tkCon {
30    color,blink		yellow
31    color,proc		darkgreen
32    color,prompt	brown
33    color,stdin		black
34    color,stdout	blue
35    color,stderr	red
36
37    blinktime		500
38    font		fixed
39    lightbrace		1
40    lightcmd		1
41    prompt1		{[history nextid] % }
42    prompt2		{[history nextid] cont > }
43    showmultiple	1
44    slavescript		{}
45
46    cmd {} cmdbuf {} cmdsave {} event 1 svnt 1 cols 80 rows 24
47
48    version	{0.5x Stripped}
49    base	.console
50  }
51
52  if [string comp $tcl_platform(platform) unix] {
53    array set tkCon {
54      font	{Courier 12 {}}
55    }
56  }
57
58  tkConInitUI $title
59
60  interp alias {} clean {} tkConStateRevert tkCon
61  tkConStateCheckpoint tkCon
62}
63
64## tkConInitUI - inits UI portion (console) of tkCon
65## Creates all elements of the console window and sets up the text tags
66# ARGS:	title	- title for the console root and main (.) windows
67# Calls:	tkConInitMenus, tkConPrompt
68##
69proc tkConInitUI {title} {
70  global tkCon
71
72  set root $tkCon(base)
73  if [string match $root .] { set w {} } else { set w [frame $root] }
74
75  set tkCon(console) [text $w.text -font $tkCon(font) -wrap char \
76      -yscrollcommand "$w.sy set" -setgrid 1 -foreground $tkCon(color,stdin)]
77  bindtags $w.text "$w.text PreCon Console PostCon $root all"
78  set tkCon(scrolly) [scrollbar $w.sy \
79      -command "$w.text yview" -takefocus 0 -bd 1]
80
81  pack $w.sy -side left -fill y
82  set tkCon(scrollypos) left
83  pack $w.text -fill both -expand 1
84
85  $w.text insert insert "$title console display active\n" stdout
86  tkConPrompt $w.text
87
88  foreach col {prompt stdout stderr stdin proc} {
89    $w.text tag configure $col -foreground $tkCon(color,$col)
90  }
91  $w.text tag configure blink -background $tkCon(color,blink)
92
93  pack $root -fill both -expand 1
94  focus $w.text
95}
96
97## tkConEval - evaluates commands input into console window
98## This is the first stage of the evaluating commands in the console.
99## They need to be broken up into consituent commands (by tkConCmdSep) in
100## case a multiple commands were pasted in, then each is eval'ed (by
101## tkConEvalCmd) in turn.  Any uncompleted command will not be eval'ed.
102# ARGS:	w	- console text widget
103# Calls:	tkConCmdGet, tkConCmdSep, tkConEvalCmd
104##
105proc tkConEval {w} {
106  global tkCon
107  tkConCmdSep [tkConCmdGet $w] cmds tkCon(cmd)
108  $w mark set insert end-1c
109  $w insert end \n
110  if [llength $cmds] {
111    foreach cmd $cmds {tkConEvalCmd $w $cmd}
112    $w insert insert $tkCon(cmd) {}
113  } elseif {[info complete $tkCon(cmd)] && ![regexp {[^\\]\\$} $tkCon(cmd)]} {
114    tkConEvalCmd $w $tkCon(cmd)
115  }
116  $w see insert
117}
118
119## tkConEvalCmd - evaluates a single command, adding it to history
120# ARGS:	w	- console text widget
121# 	cmd	- the command to evaluate
122# Calls:	tkConPrompt
123# Outputs:	result of command to stdout (or stderr if error occured)
124# Returns:	next event number
125##
126proc tkConEvalCmd {w cmd} {
127  global tkCon
128  $w mark set output end
129  if [catch {uplevel \#0 history add [list $cmd] exec} result] {
130    $w insert output $result\n stderr
131  } elseif [string comp {} $result] {
132    $w insert output $result\n stdout
133  }
134  tkConPrompt $w
135  set tkCon(svnt) [set tkCon(event) [history nextid]]
136}
137
138## tkConCmdGet - gets the current command from the console widget
139# ARGS:	w	- console text widget
140# Returns:	text which compromises current command line
141##
142proc tkConCmdGet w {
143  if [string match {} [set ix [$w tag nextrange prompt limit end]]] {
144    $w tag add stdin limit end-1c
145    return [$w get limit end-1c]
146  }
147}
148
149## tkConCmdSep - separates multiple commands into a list and remainder
150# ARGS:	cmd	- (possible) multiple command to separate
151# 	list	- varname for the list of commands that were separated.
152#	rmd	- varname of any remainder (like an incomplete final command).
153#		If there is only one command, it's placed in this var.
154# Returns:	constituent command info in varnames specified by list & rmd.
155##
156proc tkConCmdSep {cmd ls rmd} {
157  upvar $ls cmds $rmd tmp
158  set tmp {}
159  set cmds {}
160  foreach cmd [split [set cmd] \n] {
161    if [string comp {} $tmp] {
162      append tmp \n$cmd
163    } else {
164      append tmp $cmd
165    }
166    if {[info complete $tmp] && ![regexp {[^\\]\\$} $tmp]} {
167      lappend cmds $tmp
168      set tmp {}
169    }
170  }
171  if {[string comp {} [lindex $cmds end]] && [string match {} $tmp]} {
172    set tmp [lindex $cmds end]
173    set cmds [lreplace $cmds end end]
174  }
175}
176
177## tkConPrompt - displays the prompt in the console widget
178# ARGS:	w	- console text widget
179# Outputs:	prompt (specified in tkCon(prompt1)) to console
180##
181proc tkConPrompt w {
182  global tkCon env
183  set i [$w index end-1c]
184  $w insert end [subst $tkCon(prompt1)] prompt
185  $w mark set output $i
186  $w mark set limit insert
187  $w mark gravity limit left
188}
189
190## tkConStateCheckpoint - checkpoints the current state of the system
191## This allows you to return to this state with tkConStateRevert
192# ARGS:	ary	an array into which several elements are stored:
193#			commands  - the currently defined commands
194#			variables - the current global vars
195#		This is the array you would pass to tkConRevertState
196##
197proc tkConStateCheckpoint {ary} {
198  global tkCon
199  upvar $ary a
200  set a(commands)  [uplevel \#0 info commands *]
201  set a(variables) [uplevel \#0 info vars *]
202  return
203}
204
205## tkConStateCompare - compare two states and output difference
206# ARGS:	ary1	an array with checkpointed state
207#	ary2	a second array with checkpointed state
208# Outputs:
209##
210proc tkConStateCompare {ary1 ary2} {
211  upvar $ary1 a1 $ary2 a2
212  puts "Commands unique to $ary1:\n[lremove $a1(commands) $a2(commands)]"
213  puts "Commands unique to $ary2:\n[lremove $a2(commands) $a1(commands)]"
214  puts "Variables unique to $ary1:\n[lremove $a1(variables) $a2(variables)]"
215  puts "Variables unique to $ary2:\n[lremove $a2(variables) $a1(variables)]"
216}
217
218## tkConStateRevert - reverts interpreter to a previous state
219# ARGS:	ary	an array with checkpointed state
220##
221proc tkConStateRevert {ary} {
222  upvar $ary a
223  tkConStateCheckpoint tmp
224  foreach i [lremove $tmp(commands) $a(commands)] { catch "rename $i {}" }
225  foreach i [lremove $tmp(variables) $a(variables)] { uplevel \#0 unset $i }
226}
227
228##
229## Some procedures to make up for lack of built-in shell commands
230##
231
232## puts
233## This allows me to capture all stdout/stderr to the console window
234# ARGS:	same as usual
235# Outputs:	the string with a color-coded text tag
236##
237catch {rename puts tcl_puts}
238proc puts args {
239  set len [llength $args]
240  if {$len==1} {
241    eval tkcon console insert output $args stdout {\n} stdout
242    tkcon console see output
243  } elseif {$len==2 &&
244    [regexp {(stdout|stderr|-nonewline)} [lindex $args 0] junk tmp]} {
245    if [string comp $tmp -nonewline] {
246      eval tkcon console insert output [lreplace $args 0 0] $tmp {\n} $tmp
247    } else {
248      eval tkcon console insert output [lreplace $args 0 0] stdout
249    }
250    tkcon console see output
251  } elseif {$len==3 &&
252    [regexp {(stdout|stderr)} [lreplace $args 2 2] junk tmp]} {
253    if [string comp [lreplace $args 1 2] -nonewline] {
254      eval tkcon console insert output [lrange $args 1 1] $tmp
255    } else {
256      eval tkcon console insert output [lreplace $args 0 1] $tmp
257    }
258    tkcon console see output
259  } else {
260    eval tcl_puts $args
261  }
262}
263
264## alias - akin to the csh alias command
265## If called with no args, then it prints out all current aliases
266## If called with one arg, returns the alias of that arg (or {} if none)
267# ARGS:	newcmd	- (optional) command to bind alias to
268# 	args	- command and args being aliased
269##
270proc alias {{newcmd {}} args} {
271  if [string match $newcmd {}] {
272    set res {}
273    foreach a [interp aliases] {
274      lappend res [list $a: [interp alias {} $a]]
275    }
276    return [join $res \n]
277  } elseif {[string match {} $args]} {
278    interp alias {} $newcmd
279  } else {
280    eval interp alias {{}} $newcmd {{}} $args
281  }
282}
283
284## unalias - unaliases an alias'ed command
285# ARGS:	cmd	- command to unbind as an alias
286##
287proc unalias {cmd} {
288  interp alias {} $cmd {}
289}
290
291## tkcon - command that allows control over the console
292# ARGS:	totally variable, see internal comments
293##
294proc tkcon {args} {
295  global tkCon
296  switch -- [lindex $args 0] {
297    clean {
298      ## 'cleans' the interpreter - reverting to original tkCon state
299      tkConStateRevert tkCon
300    }
301    console {
302      ## Passes the args to the text widget of the console.
303      eval $tkCon(console) [lreplace $args 0 0]
304    }
305    font {
306      ## "tkcon font ?fontname?".  Sets the font of the console
307      if [string comp {} [lindex $args 1]] {
308	return [$tkCon(console) config -font [lindex $args 1]]
309      } else {
310	return [$tkCon(console) config -font]
311      }
312    }
313    version {
314      return $tkCon(version)
315    }
316    default {
317      ## tries to determine if the command exists, otherwise throws error
318      set cmd [lindex $args 0]
319      set cmd tkCon[string toup [string index $cmd 0]][string range $cmd 1 end]
320      if [string match $cmd [info command $cmd]] {
321	eval $cmd [lreplace $args 0 0]
322      } else {
323	error "bad option \"[lindex $args 0]\": must be attach,\
324		clean, console, font"
325      }
326    }
327  }
328}
329
330## clear - clears the buffer of the console (not the history though)
331## This is executed in the parent interpreter
332##
333proc clear {{pcnt 100}} {
334  if {![regexp {^[0-9]*$} $pcnt] || $pcnt < 1 || $pcnt > 100} {
335    error "invalid percentage to clear: must be 1-100 (100 default)"
336  } elseif {$pcnt == 100} {
337    tkcon console delete 1.0 end
338  } else {
339    set tmp [expr $pcnt/100.0*[tkcon console index end]]
340    tkcon console delete 1.0 "$tmp linestart"
341  }
342}
343
344## dump - outputs variables/procedure/widget info in source'able form.
345## Accepts glob style pattern matching for the names
346# ARGS:	type	- type of thing to dump: must be variable, procedure, widget
347# OPTS: -nocomplain	don't complain if no vars match something
348# Returns:	the values of the variables in a 'source'able form
349##
350proc dump {type args} {
351  set whine 1
352  set code ok
353  if [string match \-n* [lindex $args 0]] {
354    set whine 0
355    set args [lreplace $args 0 0]
356  }
357  if {$whine && [string match {} $args]} {
358    error "wrong \# args: [lindex [info level 0] 0] ?-nocomplain? pattern ?pattern ...?"
359  }
360  set res {}
361  switch -glob -- $type {
362    v* {
363      # variable
364      # outputs variables value(s), whether array or simple.
365      foreach arg $args {
366	if {[string match {} [set vars [uplevel info vars [list $arg]]]]} {
367	  if {[uplevel info exists $arg]} {
368	    set vars $arg
369	  } elseif $whine {
370	    append res "\#\# No known variable $arg\n"
371	    set code error
372	    continue
373	  } else continue
374	}
375	foreach var [lsort $vars] {
376	  upvar $var v
377	  if {[array exists v]} {
378	    append res "array set $var \{\n"
379	    foreach i [lsort [array names v]] {
380	      upvar 0 v\($i\) w
381	      if {[array exists w]} {
382		append res "    [list $i {NESTED VAR ERROR}]\n"
383		if $whine { set code error }
384	      } else {
385		append res "    [list $i $v($i)]\n"
386	      }
387	    }
388	    append res "\}\n"
389	  } else {
390	    append res [list set $var $v]\n
391	  }
392	}
393      }
394    }
395    p* {
396      # procedure
397      foreach arg $args {
398	if {[string comp {} [set ps [info proc $arg]]]} {
399	  foreach p [lsort $ps] {
400	    set as {}
401	    foreach a [info args $p] {
402	      if {[info default $p $a tmp]} {
403		lappend as [list $a $tmp]
404	      } else {
405		lappend as $a
406	      }
407	    }
408	    append res [list proc $p $as [info body $p]]\n
409	  }
410	} elseif $whine {
411	  append res "\#\# No known proc $arg\n"
412	}
413      }
414    }
415    w* {
416      # widget
417    }
418    default {
419      return -code error "bad [lindex [info level 0] 0] option\
420	\"[lindex $args 0]\":\ must be procedure, variable, widget"
421    }
422  }
423  return -code $code [string trimr $res \n]
424}
425
426## which - tells you where a command is found
427# ARGS:	cmd	- command name
428# Returns:	where command is found (internal / external / unknown)
429##
430proc which cmd {
431  if [string comp {} [info commands $cmd]] {
432    if {[lsearch -exact [interp aliases] $cmd] > -1} {
433      return "$cmd:\taliased to [alias $cmd]"
434    } elseif [string comp {} [info procs $cmd]] {
435      return "$cmd:\tinternal proc"
436    } else {
437      return "$cmd:\tinternal command"
438    }
439  } else {
440    return "$cmd:\tunknown command"
441  }
442}
443
444## lremove - remove items from a list
445# OPTS:	-all	remove all instances of each item
446# ARGS:	l	a list to remove items from
447#	is	a list of items to remove
448##
449proc lremove {args} {
450  set all 0
451  if [string match \-a* [lindex $args 0]] {
452    set all 1
453    set args [lreplace $args 0 0]
454  }
455  set l [lindex $args 0]
456  eval append is [lreplace $args 0 0]
457  foreach i $is {
458    if {[set ix [lsearch -exact $l $i]] == -1} continue
459    set l [lreplace $l $ix $ix]
460    if $all {
461      while {[set ix [lsearch -exact $l $i]] != -1} {
462	set l [lreplace $l $i $i]
463      }
464    }
465  }
466  return $l
467}
468
469
470## Unknown changed to get output into tkCon window
471## See $tcl_library/init.tcl for an explanation
472##
473proc unknown args {
474  global auto_noexec auto_noload env unknown_pending tcl_interactive tkCon
475  global errorCode errorInfo
476
477  # Save the values of errorCode and errorInfo variables, since they
478  # may get modified if caught errors occur below.  The variables will
479  # be restored just before re-executing the missing command.
480
481  set savedErrorCode $errorCode
482  set savedErrorInfo $errorInfo
483  set name [lindex $args 0]
484  if ![info exists auto_noload] {
485    #
486    # Make sure we're not trying to load the same proc twice.
487    #
488    if [info exists unknown_pending($name)] {
489      unset unknown_pending($name)
490      if {[array size unknown_pending] == 0} {
491	unset unknown_pending
492      }
493      return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
494    }
495    set unknown_pending($name) pending;
496    set ret [catch {auto_load $name} msg]
497    unset unknown_pending($name);
498    if {$ret != 0} {
499      return -code $ret -errorcode $errorCode \
500	  "error while autoloading \"$name\": $msg"
501    }
502    if ![array size unknown_pending] {
503      unset unknown_pending
504    }
505    if $msg {
506      set errorCode $savedErrorCode
507      set errorInfo $savedErrorInfo
508      set code [catch {uplevel $args} msg]
509      if {$code ==  1} {
510	#
511	# Strip the last five lines off the error stack (they're
512	# from the "uplevel" command).
513	#
514
515	set new [split $errorInfo \n]
516	set new [join [lrange $new 0 [expr [llength $new] - 6]] \n]
517	return -code error -errorcode $errorCode \
518	    -errorinfo $new $msg
519      } else {
520	return -code $code $msg
521      }
522    }
523  }
524  if {[info level] == 1 && [string match {} [info script]] \
525	  && [info exists tcl_interactive] && $tcl_interactive} {
526    if ![info exists auto_noexec] {
527      if [auto_execok $name] {
528	set errorCode $savedErrorCode
529	set errorInfo $savedErrorInfo
530	return [uplevel exec $args]
531	#return [uplevel exec >&@stdout <@stdin $args]
532      }
533    }
534    set errorCode $savedErrorCode
535    set errorInfo $savedErrorInfo
536    if {[string match $name !!]} {
537      catch {set tkCon(cmd) [history event]}
538      return [uplevel {history redo}]
539    } elseif [regexp {^!(.+)$} $name dummy event] {
540      catch {set tkCon(cmd) [history event $event]}
541      return [uplevel [list history redo $event]]
542    } elseif [regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new] {
543      catch {set tkCon(cmd) [history substitute $old $new]}
544      return [uplevel [list history substitute $old $new]]
545    }
546    set cmds [info commands $name*]
547    if {[llength $cmds] == 1} {
548      return [uplevel [lreplace $args 0 0 $cmds]]
549    } elseif {[llength $cmds]} {
550      if {$name == ""} {
551	return -code error "empty command name \"\""
552      } else {
553	return -code error \
554	    "ambiguous command name \"$name\": [lsort $cmds]"
555      }
556    }
557  }
558  return -code error "invalid command name \"$name\""
559}
560
561
562# tkConClipboardKeysyms --
563# This procedure is invoked to identify the keys that correspond to
564# the "copy", "cut", and "paste" functions for the clipboard.
565#
566# Arguments:
567# copy -	Name of the key (keysym name plus modifiers, if any,
568#		such as "Meta-y") used for the copy operation.
569# cut -		Name of the key used for the cut operation.
570# paste -	Name of the key used for the paste operation.
571
572proc tkConCut w {
573  if [string match $w [selection own -displayof $w]] {
574    clipboard clear -displayof $w
575    catch {
576      clipboard append -displayof $w [selection get -displayof $w]
577      if [$w compare sel.first >= limit] {$w delete sel.first sel.last}
578    }
579  }
580}
581proc tkConCopy w {
582  if [string match $w [selection own -displayof $w]] {
583    clipboard clear -displayof $w
584    catch {clipboard append -displayof $w [selection get -displayof $w]}
585  }
586}
587
588proc tkConPaste w {
589  if ![catch {selection get -displayof $w -selection CLIPBOARD} tmp] {
590    if [$w compare insert < limit] {$w mark set insert end}
591    $w insert insert $tmp
592    $w see insert
593    if [string match *\n* $tmp] {tkConEval $w}
594  }
595}
596
597proc tkConClipboardKeysyms {copy cut paste} {
598  bind Console <$copy>	{tkConCopy %W}
599  bind Console <$cut>	{tkConCut %W}
600  bind Console <$paste>	{tkConPaste %W}
601}
602
603## Get all Text bindings into Console
604##
605foreach ev [lremove [bind Text] {<Control-Key-y> <Control-Key-w> \
606				     <Meta-Key-w> <Control-Key-o>}] {
607  bind Console $ev [bind Text $ev]
608}
609unset ev
610
611## Redefine for Console what we need
612##
613tkConClipboardKeysyms F16 F20 F18
614tkConClipboardKeysyms Control-c Control-x Control-v
615
616bind Console <Insert> {catch {tkConInsert %W [selection get -displayof %W]}}
617
618bind Console <Up> {
619  if [%W compare {insert linestart} != {limit linestart}] {
620    tkTextSetCursor %W [tkTextUpDownLine %W -1]
621  } else {
622    if {$tkCon(event) == [history nextid]} {
623      set tkCon(cmdbuf) [tkConCmdGet %W]
624    }
625    if [catch {history event [incr tkCon(event) -1]} tkCon(tmp)] {
626      incr tkCon(event)
627    } else {
628      %W delete limit end
629      %W insert limit $tkCon(tmp)
630      %W see end
631    }
632  }
633}
634bind Console <Down> {
635  if [%W compare {insert linestart} != {end-1c linestart}] {
636    tkTextSetCursor %W [tkTextUpDownLine %W 1]
637  } else {
638    if {$tkCon(event) < [history nextid]} {
639      %W delete limit end
640      if {[incr tkCon(event)] == [history nextid]} {
641	%W insert limit $tkCon(cmdbuf)
642      } else {
643	%W insert limit [history event $tkCon(event)]
644      }
645      %W see end
646    }
647  }
648}
649bind Console <Control-P> {
650  if [%W compare insert > limit] {tkConExpand %W proc}
651}
652bind Console <Control-V> {
653  if [%W compare insert > limit] {tkConExpand %W var}
654}
655bind Console <Control-i> {
656  if [%W compare insert >= limit] {
657    tkConInsert %W \t
658  }
659}
660bind Console <Return> {
661  tkConEval %W
662}
663bind Console <KP_Enter> [bind Console <Return>]
664bind Console <Delete> {
665  if {[string comp {} [%W tag nextrange sel 1.0 end]] \
666	  && [%W compare sel.first >= limit]} {
667    %W delete sel.first sel.last
668  } elseif [%W compare insert >= limit] {
669    %W delete insert
670    %W see insert
671  }
672}
673bind Console <BackSpace> {
674  if {[string comp {} [%W tag nextrange sel 1.0 end]] \
675	  && [%W compare sel.first >= limit]} {
676    %W delete sel.first sel.last
677  } elseif {[%W compare insert != 1.0] && [%W compare insert-1c >= limit]} {
678    %W delete insert-1c
679    %W see insert
680  }
681}
682bind Console <Control-h> [bind Console <BackSpace>]
683
684bind Console <KeyPress> {
685  tkConInsert %W %A
686}
687
688bind Console <Control-a> {
689  if [%W compare {limit linestart} == {insert linestart}] {
690    tkTextSetCursor %W limit
691  } else {
692    tkTextSetCursor %W {insert linestart}
693  }
694}
695bind Console <Control-d> {
696  if [%W compare insert < limit] break
697  %W delete insert
698}
699bind Console <Control-k> {
700  if [%W compare insert < limit] break
701  if [%W compare insert == {insert lineend}] {
702    %W delete insert
703  } else {
704    %W delete insert {insert lineend}
705  }
706}
707bind Console <Control-l> {
708  ## Clear console buffer, without losing current command line input
709  set tkCon(tmp) [tkConCmdGet %W]
710  clear
711  tkConPrompt
712  tkConInsert %W $tkCon(tmp)
713}
714bind Console <Control-n> {
715  ## Goto next command in history
716  if {$tkCon(event) < [history nextid]} {
717    %W delete limit end
718    if {[incr tkCon(event)] == [history nextid]} {
719      %W insert limit $tkCon(cmdbuf)
720    } else {
721      %W insert limit [history event $tkCon(event)]
722    }
723    %W see end
724  }
725}
726bind Console <Control-p> {
727  ## Goto previous command in history
728  if {$tkCon(event) == [history nextid]} {
729    set tkCon(cmdbuf) [tkConCmdGet %W]
730  }
731  if [catch {history event [incr tkCon(event) -1]} tkCon(tmp)] {
732    incr tkCon(event)
733  } else {
734    %W delete limit end
735    %W insert limit $tkCon(tmp)
736    %W see end
737  }
738}
739bind Console <Control-r> {
740  ## Search history reverse
741  if {$tkCon(svnt) == [history nextid]} {
742    set tkCon(cmdbuf) [tkConCmdGet %W]
743  }
744  set tkCon(tmp1) [string len $tkCon(cmdbuf)]
745  incr tkCon(tmp1) -1
746  while 1 {
747    if {[catch {history event [incr tkCon(svnt) -1]} tkCon(tmp)]} {
748      incr tkCon(svnt)
749      break
750    } elseif {![string comp $tkCon(cmdbuf) \
751	[string range $tkCon(tmp) 0 $tkCon(tmp1)]]} {
752      %W delete limit end
753      %W insert limit $tkCon(tmp)
754      break
755    }
756  }
757  %W see end
758}
759bind Console <Control-s> {
760  ## Search history forward
761  set tkCon(tmp1) [string len $tkCon(cmdbuf)]
762  incr tkCon(tmp1) -1
763  while {$tkCon(svnt) < [history nextid]} {
764    if {[incr tkCon(svnt)] == [history nextid]} {
765      %W delete limit end
766      %W insert limit $tkCon(cmdbuf)
767      break
768    } elseif {![catch {history event $tkCon(svnt)} tkCon(tmp)]
769	      && ![string comp $tkCon(cmdbuf) \
770		       [string range $tkCon(tmp) 0 $tkCon(tmp1)]]} {
771      %W delete limit end
772      %W insert limit $tkCon(tmp)
773      break
774    }
775  }
776  %W see end
777}
778bind Console <Control-t> {
779  ## Transpose current and previous chars
780  if [%W compare insert > limit] {
781    tkTextTranspose %W
782  }
783}
784bind Console <Control-u> {
785  ## Clear command line (Unix shell staple)
786  %W delete limit end
787}
788bind Console <Control-z> {
789  ## Save command buffer
790  set tkCon(tmp) $tkCon(cmdsave)
791  set tkCon(cmdsave) [tkConCmdGet %W]
792  if {[string match {} $tkCon(cmdsave)]} {
793    set tkCon(cmdsave) $tkCon(tmp)
794  } else {
795    %W delete limit end-1c
796  }
797  tkConInsert %W $tkCon(tmp)
798  %W see end
799}
800catch {bind Console <Key-Page_Up>   { tkTextScrollPages %W -1 }}
801catch {bind Console <Key-Prior>     { tkTextScrollPages %W -1 }}
802catch {bind Console <Key-Page_Down> { tkTextScrollPages %W 1 }}
803catch {bind Console <Key-Next>      { tkTextScrollPages %W 1 }}
804bind Console <Meta-d> {
805  if [%W compare insert >= limit] {
806    %W delete insert {insert wordend}
807  }
808}
809bind Console <Meta-BackSpace> {
810  if [%W compare {insert -1c wordstart} >= limit] {
811    %W delete {insert -1c wordstart} insert
812  }
813}
814bind Console <Meta-Delete> {
815  if [%W compare insert >= limit] {
816    %W delete insert {insert wordend}
817  }
818}
819bind Console <ButtonRelease-2> {
820  if {(!$tkPriv(mouseMoved) || $tk_strictMotif) \
821	  && ![catch {selection get -displayof %W} tkCon(tmp)]} {
822    if [%W compare @%x,%y < limit] {
823      %W insert end $tkCon(tmp)
824    } else {
825      %W insert @%x,%y $tkCon(tmp)
826    }
827    if [string match *\n* $tkCon(tmp)] {tkConEval %W}
828  }
829}
830
831##
832## End weird bindings
833##
834
835##
836## PostCon bindings, for doing special things based on certain keys
837##
838bind PostCon <Key-parenright> {
839  if {$tkCon(lightbrace) && $tkCon(blinktime)>99 &&
840      [string comp \\ [%W get insert-2c]]} {
841    tkConMatchPair %W \( \)
842  }
843}
844bind PostCon <Key-bracketright> {
845  if {$tkCon(lightbrace) && $tkCon(blinktime)>99 &&
846      [string comp \\ [%W get insert-2c]]} {
847    tkConMatchPair %W \[ \]
848  }
849}
850bind PostCon <Key-braceright> {
851  if {$tkCon(lightbrace) && $tkCon(blinktime)>99 &&
852      [string comp \\ [%W get insert-2c]]} {
853    tkConMatchPair %W \{ \}
854  }
855}
856bind PostCon <Key-quotedbl> {
857  if {$tkCon(lightbrace) && $tkCon(blinktime)>99 &&
858      [string comp \\ [%W get insert-2c]]} {
859    tkConMatchQuote %W
860  }
861}
862
863bind PostCon <KeyPress> {
864  if {$tkCon(lightcmd) && [string comp {} %A]} { tkConTagProc %W }
865}
866
867## tkConTagProc - tags a procedure in the console if it's recognized
868## This procedure is not perfect.  However, making it perfect wastes
869## too much CPU time...  Also it should check the existence of a command
870## in whatever is the connected slave, not the master interpreter.
871##
872proc tkConTagProc w {
873  set i [$w index "insert-1c wordstart"]
874  set j [$w index "insert-1c wordend"]
875  if {[string comp {} [info command [list [$w get $i $j]]]]} {
876    $w tag add proc $i $j
877  } else {
878    $w tag remove proc $i $j
879  }
880}
881
882
883## tkConMatchPair - blinks a matching pair of characters
884## c2 is assumed to be at the text index 'insert'.
885## This proc is really loopy and took me an hour to figure out given
886## all possible combinations with escaping except for escaped \'s.
887## It doesn't take into account possible commenting... Oh well.  If
888## anyone has something better, I'd like to see/use it.  This is really
889## only efficient for small contexts.
890# ARGS:	w	- console text widget
891# 	c1	- first char of pair
892# 	c2	- second char of pair
893# Calls:	tkConBlink
894##
895proc tkConMatchPair {w c1 c2} {
896  if [string comp {} [set ix [$w search -back $c1 insert limit]]] {
897    while {[string match {\\} [$w get $ix-1c]] &&
898	   [string comp {} [set ix [$w search -back $c1 $ix-1c limit]]]} {}
899    set i1 insert-1c
900    while {[string comp {} $ix]} {
901      set i0 $ix
902      set j 0
903      while {[string comp {} [set i0 [$w search $c2 $i0 $i1]]]} {
904	append i0 +1c
905	if {[string match {\\} [$w get $i0-2c]]} continue
906	incr j
907      }
908      if {!$j} break
909      set i1 $ix
910      while {$j &&
911	     [string comp {} [set ix [$w search -back $c1 $ix limit]]]} {
912	if {[string match {\\} [$w get $ix-1c]]} continue
913	incr j -1
914      }
915    }
916    if [string match {} $ix] { set ix [$w index limit] }
917  } else { set ix [$w index limit] }
918  tkConBlink $w $ix [$w index insert]
919}
920
921## tkConMatchQuote - blinks between matching quotes.
922## Blinks just the quote if it's unmatched, otherwise blinks quoted string
923## The quote to match is assumed to be at the text index 'insert'.
924# ARGS:	w	- console text widget
925# Calls:	tkConBlink
926##
927proc tkConMatchQuote w {
928  set i insert-1c
929  set j 0
930  while {[string comp {} [set i [$w search -back \" $i limit]]]} {
931    if {[string match {\\} [$w get $i-1c]]} continue
932    if {!$j} {set i0 $i}
933    incr j
934  }
935  if [expr $j%2] {
936    tkConBlink $w $i0 [$w index insert]
937  } else {
938    tkConBlink $w [$w index insert-1c] [$w index insert]
939  }
940}
941
942## tkConBlink - blinks between 2 indices for a specified duration.
943# ARGS:	w	- console text widget
944# 	i1	- start index to blink region
945# 	i2	- end index of blink region
946# 	dur	- duration in usecs to blink for
947# Outputs:	blinks selected characters in $w
948##
949proc tkConBlink {w i1 i2} {
950  global tkCon
951  $w tag add blink $i1 $i2
952  after $tkCon(blinktime) $w tag remove blink $i1 $i2
953  return
954}
955
956
957## tkConInsert
958## Insert a string into a text at the point of the insertion cursor.
959## If there is a selection in the text, and it covers the point of the
960## insertion cursor, then delete the selection before inserting.
961# ARGS:	w	- text window in which to insert the string
962# 	s	- string to insert (usually just a single char)
963# Outputs:	$s to text widget
964##
965proc tkConInsert {w s} {
966  if {[string match {} $s] || [string match disabled [$w cget -state]]} {
967    return
968  }
969  if [$w comp insert < limit] {
970    $w mark set insert end
971  }
972  catch {
973    if {[$w comp sel.first <= insert] && [$w comp sel.last >= insert]} {
974      $w delete sel.first sel.last
975    }
976  }
977  $w insert insert $s
978  $w see insert
979}
980
981## tkConExpand -
982# ARGS:	w	- text widget in which to expand str
983# 	type	- type of expansion (path / proc / variable)
984# Calls:	tkConExpand(Pathname|Procname|Variable)
985# Outputs:	The string to match is expanded to the longest possible match.
986#		If tkCon(showmultiple) is non-zero and the user longest match
987#		equaled the string to expand, then all possible matches are
988#		output to stdout.  Triggers bell if no matches are found.
989# Returns:	number of matches found
990##
991proc tkConExpand {w type} {
992  set exp "\[^\\]\[ \t\n\r\[\{\"\$]"
993  set tmp [$w search -back -regexp $exp insert-1c limit-1c]
994  if [string compare {} $tmp] {append tmp +2c} else {set tmp limit}
995  if [$w compare $tmp >= insert] return
996  set str [$w get $tmp insert]
997  switch -glob $type {
998    pr* {set res [tkConExpandProcname $str]}
999    v*  {set res [tkConExpandVariable $str]}
1000    default {set res {}}
1001  }
1002  set len [llength $res]
1003  if $len {
1004    $w delete $tmp insert
1005    $w insert $tmp [lindex $res 0]
1006    if {$len > 1} {
1007      global tkCon
1008      if {$tkCon(showmultiple) && [string match [lindex $res 0] $str]} {
1009	puts stdout [lreplace $res 0 0]
1010      }
1011    }
1012  }
1013  return [incr len -1]
1014}
1015
1016## tkConExpandProcname - expand a tcl proc name based on $str
1017# ARGS:	str	- partial proc name to expand
1018# Calls:	tkConExpandBestMatch
1019# Returns:	list containing longest unique match followed by all the
1020#		possible further matches
1021##
1022proc tkConExpandProcname str {
1023  set match [info commands $str*]
1024  if {[llength $match] > 1} {
1025    regsub -all { } [tkConExpandBestMatch $match $str] {\\ } str
1026    set match [linsert $match 0 $str]
1027  } else {
1028    regsub -all { } $match {\\ } match
1029  }
1030  return $match
1031}
1032
1033## tkConExpandVariable - expand a tcl variable name based on $str
1034# ARGS:	str	- partial tcl var name to expand
1035# Calls:	tkConExpandBestMatch
1036# Returns:	list containing longest unique match followed by all the
1037#		possible further matches
1038##
1039proc tkConExpandVariable str {
1040  if [regexp {([^\(]*)\((.*)} $str junk ary str] {
1041    set match [uplevel \#0 array names $ary $str*]
1042    if {[llength $match] > 1} {
1043      set vars $ary\([tkConExpandBestMatch $match $str]
1044      foreach var $match {lappend vars $ary\($var\)}
1045      return $vars
1046    } else {set match $ary\($match\)}
1047  } else {
1048    set match [uplevel \#0 info vars $str*]
1049    if {[llength $match] > 1} {
1050      regsub -all { } [tkConExpandBestMatch $match $str] {\\ } str
1051      set match [linsert $match 0 $str]
1052    } else {
1053      regsub -all { } $match {\\ } match
1054    }
1055  }
1056  return $match
1057}
1058
1059## tkConExpandBestMatch - finds the best unique match in a list of names
1060## The extra $e in this argument allows us to limit the innermost loop a
1061## little further.  This improves speed as $l becomes large or $e becomes long.
1062# ARGS:	l	- list to find best unique match in
1063# 	e	- currently best known unique match
1064# Returns:	longest unique match in the list
1065##
1066proc tkConExpandBestMatch {l {e {}}} {
1067  set ec [lindex $l 0]
1068  if {[llength $l]>1} {
1069    set e  [string length $e]; incr e -1
1070    set ei [string length $ec]; incr ei -1
1071    foreach l $l {
1072      while {$ei>=$e && [string first $ec $l]} {
1073	set ec [string range $ec 0 [incr ei -1]]
1074      }
1075    }
1076  }
1077  return $ec
1078}
1079
1080
1081## Initialize only if we haven't yet
1082##
1083if [catch {winfo exists $tkCon(base)}] tkConInit
1084