summaryrefslogtreecommitdiffstats
path: root/tkcon/extra/console1_1.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'tkcon/extra/console1_1.tcl')
-rw-r--r--tkcon/extra/console1_1.tcl2209
1 files changed, 2209 insertions, 0 deletions
diff --git a/tkcon/extra/console1_1.tcl b/tkcon/extra/console1_1.tcl
new file mode 100644
index 0000000..78975f0
--- /dev/null
+++ b/tkcon/extra/console1_1.tcl
@@ -0,0 +1,2209 @@
+##
+## Copyright 1996-1997 Jeffrey Hobbs
+##
+## source standard_disclaimer.tcl
+## source beer_ware.tcl
+##
+## Based off previous work for TkCon
+##
+
+##------------------------------------------------------------------------
+## PROCEDURE
+## console
+##
+## DESCRIPTION
+## Implements a console mega-widget
+##
+## ARGUMENTS
+## console <window pathname> <options>
+##
+## OPTIONS
+## (Any toplevel widget option may be used in addition to these)
+##
+## -blinkcolor color DEFAULT: yellow
+## Specifies the background blink color for brace highlighting.
+## This doubles as the highlight color for the find box.
+##
+## -blinkrange TCL_BOOLEAN DEFAULT: 1
+## When doing electric brace matching, specifies whether to blink
+## the entire range or just the matching braces.
+##
+## -proccolor color DEFAULT: darkgreen
+## Specifies the color to highlight recognized procs.
+##
+## -promptcolor color DEFAULT: brown
+## Specifies the prompt color.
+##
+## -stdincolor color DEFAULT: black
+## Specifies the color for "stdin".
+## This doubles as the console foreground color.
+##
+## -stdoutcolor color DEFAULT: blue
+## Specifies the color for "stdout".
+##
+## -stderrcolor color DEFAULT: red
+## Specifies the color for "stderr".
+##
+## -blinktime delay DEFAULT: 500
+## For electric brace matching, specifies the amount of time to
+## blink the background for.
+##
+## -cols ## DEFAULT: 80
+## Specifies the startup width of the console.
+##
+## -grabputs TCL_BOOLEAN DEFAULT: 1
+## Whether this console should grab the "puts" default output
+##
+## -lightbrace TCL_BOOLEAN DEFAULT: 1
+## Specifies whether to activate electric brace matching.
+##
+## -lightcmd TCL_BOOLEAN DEFAULT: 1
+## Specifies whether to highlight recognized commands.
+##
+## -rows ## DEFAULT: 20
+## Specifies the startup height of the console.
+##
+## -scrollypos left|right DEFAULT: right
+## Specified position of the console scrollbar relative to the text.
+##
+## -showmultiple TCL_BOOLEAN DEFAULT: 1
+## For file/proc/var completion, specifies whether to display
+## completions when multiple choices are possible.
+##
+## -showmenu TCL_BOOLEAN DEFAULT: 1
+## Specifies whether to show the menubar.
+##
+## -subhistory TCL_BOOLEAN DEFAULT: 1
+## Specifies whether to allow substitution in the history.
+##
+## RETURNS: the window pathname
+##
+## BINDINGS (these are the bindings for Console, used in the text widget)
+##
+## <<Console_ExpandFile>> <Key-Tab>
+## <<Console_ExpandProc>> <Control-Shift-Key-P>
+## <<Console_ExpandVar>> <Control-Shift-Key-V>
+## <<Console_Tab>> <Control-Key-i>
+## <<Console_Eval>> <Key-Return> <Key-KP_Enter>
+##
+## <<Console_Clear>> <Control-Key-l>
+## <<Console_KillLine>> <Control-Key-k>
+## <<Console_Transpose>> <Control-Key-t>
+## <<Console_ClearLine>> <Control-Key-u>
+## <<Console_SaveCommand>> <Control-Key-z>
+##
+## <<Console_Previous>> <Key-Up>
+## <<Console_Next>> <Key-Down>
+## <<Console_NextImmediate>> <Control-Key-n>
+## <<Console_PreviousImmediate>> <Control-Key-p>
+## <<Console_PreviousSearch>> <Control-Key-r>
+## <<Console_NextSearch>> <Control-Key-s>
+##
+## <<Console_Exit>> <Control-Key-q>
+## <<Console_New>> <Control-Key-N>
+## <<Console_Close>> <Control-Key-w>
+## <<Console_About>> <Control-Key-A>
+## <<Console_Help>> <Control-Key-H>
+## <<Console_Find>> <Control-Key-F>
+##
+## METHODS
+## These are the methods that the console megawidget recognizes.
+##
+## configure ?option? ?value option value ...?
+## cget option
+## Standard tk widget routines.
+##
+## load ?filename?
+## Loads the named file into the current interpreter.
+## If no file is specified, it pops up the file requester.
+##
+## save ?filename?
+## Saves the console buffer to the named file.
+## If no file is specified, it pops up the file requester.
+##
+## clear ?percentage?
+## Clears a percentage of the console buffer (1-100). If no
+## percentage is specified, the entire buffer is cleared.
+##
+## error
+## Displays the last error in the interpreter in a dialog box.
+##
+## hide
+## Withdraws the console from the screen
+##
+## history ?-newline?
+## Prints out the history without numbers (basically providing a
+## list of the commands you've used).
+##
+## show
+## Deiconifies and raises the console
+##
+## subwidget widget
+## Returns the true widget path of the specified widget. Valid
+## widgets are console, scrolly, menubar.
+##
+## NAMESPACE & STATE
+## The megawidget creates a global array with the classname, and a
+## global array which is the name of each megawidget created. The latter
+## array is deleted when the megawidget is destroyed.
+## The procedure console and those beginning with Console are
+## used. Also, when a widget is created, commands named .$widgetname
+## and Console$widgetname are created.
+##
+## EXAMPLE USAGE:
+##
+## console .con -rows 24 -showmenu false
+##
+##------------------------------------------------------------------------
+
+package require Tk
+
+proc megawidget {CLASS} {
+ upvar \#0 $CLASS class
+
+ foreach o [array names class -*] {
+ foreach {name cname val} $class($o) {
+ if [string match -* $name] continue
+ option add *$CLASS.$name [uplevel \#0 [list subst $val]] widgetDefault
+ }
+ }
+ set class(class) $CLASS
+
+ bind $CLASS <Destroy> "catch {${CLASS}_destroy %W}"
+
+ ;proc $CLASS:eval {w method args} {
+ upvar \#0 $w data
+ set class [winfo class $w]
+ if [string match {} [set arg [info command ${class}_$method]]] {
+ set arg [info command ${class}_$method*]
+ }
+ set num [llength $arg]
+ if {$num==1} {
+ return [uplevel $arg [list $w] $args]
+ } elseif {$num} {
+ return -code error "ambiguous option \"$method\""
+ } elseif {[catch {uplevel [list $data(cmd) $method] $args} err]} {
+ return -code error $err
+ } else {
+ return $err
+ }
+ }
+
+ ;proc ${CLASS}_destroy w {
+ upvar \#0 $w data
+ catch { [winfo class $w]:destroy $w }
+ catch { rename $w {} }
+ catch { rename $data(cmd) {} }
+ catch { unset data }
+ }
+
+ ;proc ${CLASS}_cget {w args} {
+ if {[llength $args] != 1} {
+ return -code error "wrong \# args: should be \"$w cget option\""
+ }
+ upvar \#0 $w data [winfo class $w] class
+ if {[info exists class($args)] && [string match -* $class($args)]} {
+ set args $class($args)
+ }
+ if [string match {} [set arg [array names data $args]]] {
+ set arg [array names data ${args}*]
+ }
+ set num [llength $arg]
+ if {$num==1} {
+ return $data($arg)
+ } elseif {$num} {
+ return -code error "ambiguous option \"$args\""
+ } elseif {[catch {$data(cmd) cget $args} err]} {
+ return -code error $err
+ } else {
+ return $err
+ }
+ }
+
+ ;proc ${CLASS}_configure {w args} {
+ upvar \#0 $w data [winfo class $w] class
+
+ set num [llength $args]
+ if {$num==1} {
+ if {[info exists class($args)] && [string match -* $class($args)]} {
+ set args $class($args)
+ }
+ if [string match {} [set arg [array names data $args]]] {
+ set arg [array names data ${args}*]
+ }
+ set num [llength $arg]
+ if {$num==1} {
+ return [list $arg $class($arg) $data($arg)]
+ } elseif {$num} {
+ return -code error "ambiguous option \"$args\""
+ } elseif {[catch {$data(cmd) config $args} err]} {
+ return -code error $err
+ } else {
+ return $err
+ }
+ } elseif {$num} {
+ for {set i 0} {$i<$num} {incr i} {
+ set key [lindex $args $i]
+ if {[info exists class($key)] && [string match -* $class($key)]} {
+ set key $class($key)
+ }
+ if [string match {} [set arg [array names data $key]]] {
+ set arg [array names data $key*]
+ }
+ set val [lindex $args [incr i]]
+ set len [llength $arg]
+ if {$len==1} {
+ $class(class):configure $w $arg $val
+ } elseif {$len} {
+ return -code error "ambiguous option \"$args\""
+ } elseif {[catch {$data(cmd) configure $key $val} err]} {
+ return -code error $err
+ }
+ }
+ return
+ } else {
+ set conf [$data(cmd) config]
+ foreach i [array names data -*] {
+ lappend conf "$i $class($i) [list $data($i)]"
+ }
+ return [lsort $conf]
+ }
+ }
+
+ ;proc $CLASS:configure {w key value} {
+ puts "$w: $key configured to [list $value]"
+ }
+
+ return $CLASS
+}
+
+foreach pkg [info loaded {}] {
+ set file [lindex $pkg 0]
+ set name [lindex $pkg 1]
+ if {![catch {set version [package require $name]}]} {
+ if {[string match {} [package ifneeded $name $version]]} {
+ package ifneeded $name $version "load [list $file $name]"
+ }
+ }
+}
+catch {unset file name version}
+
+set Console(WWW) [info exists embed_args]
+
+array set Console {
+ -blinkcolor {blinkColor BlinkColor yellow}
+ -blinkrange {blinkRange BlinkRange 1}
+ -proccolor {procColor ProcColor darkgreen}
+ -promptcolor {promptColor PromptColor brown}
+ -stdincolor {stdinColor StdinColor black}
+ -stdoutcolor {stdoutColor StdoutColor blue}
+ -stderrcolor {stderrColor StderrColor red}
+
+ -blinktime {blinkTime BlinkTime 500}
+ -cols {columns Columns 80}
+ -grabputs {grabPuts GrabPuts 0}
+ -lightbrace {lightBrace LightBrace 1}
+ -lightcmd {lightCmd LightCmd 1}
+ -rows {rows Rows 20}
+ -scrollypos {scrollYPos ScrollYPos right}
+ -showmultiple {showMultiple ShowMultiple 1}
+ -showmenu {showMenu ShowMenu 1}
+ -subhistory {subhistory SubHistory 1}
+
+ active {}
+ version 1.2
+ release {February 1997}
+ contact {jhobbs@cs.uoregon.edu}
+ docs {http://www.sunlabs.com/tcl/plugin/}
+ slavealias { console }
+ slaveprocs { alias dir dump lremove puts echo unknown tcl_unknown which }
+}
+
+if [string compare unix $tcl_platform(platform)] {
+ set Console(-font) {font Font {Courier 14}}
+} else {
+ set Console(-font) {font Font fixed}
+}
+
+if $Console(WWW) {
+ set Console(-prompt) {prompt Prompt {\[history nextid\] % }}
+} else {
+ set Console(-prompt) {prompt Prompt \
+ {(\[file tail \[pwd\]\]) \[history nextid\] % }}
+}
+
+megawidget Console
+
+## console -
+# ARGS: w - widget pathname of the Console console
+# args
+# Calls: ConsoleInitUI
+# Outputs: errors found in Console resource file
+##
+proc console {W args} {
+ set CLASS Console
+ upvar \#0 $W data $CLASS class
+ if {[winfo exists $W]} {
+ catch {eval destroy [winfo children $W]}
+ } else {
+ toplevel $W -class $CLASS
+ }
+ wm withdraw $W
+ wm title $W "Console $class(version)"
+
+ ## User definable options
+ foreach o [array names class -*] {
+ if [string match -* $class($o)] continue
+ set data($o) [option get $W [lindex $class($o) 0] $CLASS]
+ }
+
+ global auto_path tcl_pkgPath tcl_interactive
+ set tcl_interactive 1
+
+ ## Private variables
+ array set data {
+ appname {} cmdbuf {} cmdsave {} errorInfo {}
+ event 1 histid 0 find {} find,case 0 find,reg 0
+ }
+ array set data [list class $CLASS cmd $CLASS$W \
+ menubar $W.bar \
+ console $W.text \
+ scrolly $W.sy \
+ ]
+
+ rename $W $data(cmd)
+ if {[string comp {} $args] && \
+ [catch {eval ${CLASS}_configure $W $args} err]} {
+ catch {destroy $W}
+ catch {unset data}
+ return -code error $err
+ }
+ ;proc $W args "eval $CLASS:eval [list $W] \$args"
+
+ if {![info exists tcl_pkgPath]} {
+ set dir [file join [file dirname [info nameofexec]] lib]
+ if [string comp {} [info commands @scope]] {
+ set dir [file join $dir itcl]
+ }
+ catch {source [file join $dir pkgIndex.tcl]}
+ }
+ catch {tclPkgUnknown dummy-name dummy-version}
+
+ ## Menus
+ frame $data(menubar) -relief raised -bd 2
+ set c [text $data(console) -font $data(-font) -wrap char -setgrid 1 \
+ -yscrollcomm [list $W.sy set] -foreground $data(-stdincolor) \
+ -width $data(-cols) -height $data(-rows)]
+ bindtags $W [list $W all]
+ bindtags $c [list $c PreCon Console PostCon $W all]
+ scrollbar $data(scrolly) -takefocus 0 -bd 1 -command "$c yview"
+
+ ConsoleInitMenus $W
+
+ if $data(-showmenu) { pack $data(menubar) -fill x }
+ pack $data(scrolly) -side $data(-scrollypos) -fill y
+ pack $c -fill both -expand 1
+
+ Console:prompt $W "console display active\n"
+
+ foreach col {prompt stdout stderr stdin proc} {
+ $c tag configure $col -foreground $data(-${col}color)
+ }
+ $c tag configure blink -background $data(-blinkcolor)
+ $c tag configure find -background $data(-blinkcolor)
+
+ bind $c <Configure> {
+ set W [winfo toplevel %W]
+ scan [wm geometry $W] "%%dx%%d" $W\(-cols\) $W\(-rows\)
+ }
+ wm deiconify $W
+ focus -force $c
+
+ return $W
+}
+
+;proc Console:configure { W key val } {
+ upvar \#0 $W data
+ global Console
+
+ set truth {^(1|yes|true|on)$}
+ switch -- $key {
+ -blinkcolor {
+ $data(console) tag config blink -background $val
+ $data(console) tag config find -background $val
+ }
+ -proccolor { $data(console) tag config proc -foreground $val }
+ -promptcolor { $data(console) tag config prompt -foreground $val }
+ -stdincolor {
+ $data(console) tag config stdin -foreground $val
+ $data(console) config -foreground $val
+ }
+ -stdoutcolor { $data(console) tag config stdout -foreground $val }
+ -stderrcolor { $data(console) tag config stderr -foreground $val }
+
+ -blinktime {
+ if ![regexp {[0-9]+} $val] {
+ return -code error "$key option requires an integer value"
+ }
+ }
+ -cols {
+ if [winfo exists $data(console)] { $data(console) config -width $val }
+ }
+ -font { $data(console) config -font $val }
+ -grabputs {
+ set val [regexp -nocase $truth $val]
+ if $val {
+ set Console(active) [linsert $Console(active) 0 $W]
+ } else {
+ set Console(active) [lremove -all $Console(active) $W]
+ }
+ }
+ -lightbrace { set val [regexp -nocase $truth $val] }
+ -lightcmd { set val [regexp -nocase $truth $val] }
+ -prompt {
+ if [catch {uplevel \#0 [list subst $val]} err] {
+ return -code error "\"$val\" threw an error:\n$err"
+ }
+ }
+ -rows {
+ if [winfo exists $data(console)] { $data(console) config -height $val }
+ }
+ -scrollypos {
+ if [regexp {^(left|right)$} $val junk val] {
+ if [winfo exists $data(scrolly)] {
+ pack config $data(scrolly) -side $val
+ }
+ } else {
+ return -code error "bad option \"$val\": must be left or right"
+ }
+ }
+ -showmultiple { set val [regexp -nocase $truth $val] }
+ -showmenu {
+ set val [regexp -nocase $truth $val]
+ if [winfo exists $data(menubar)] {
+ if $val {
+ pack $data(menubar) -fill x -before $data(console) \
+ -before $data(scrolly)
+ } else { pack forget $data(menubar) }
+ }
+ }
+ -subhistory { set val [regexp -nocase $truth $val] }
+ }
+ set data($key) $val
+}
+
+;proc Console:destroy W {
+ global Console
+ set Console(active) [lremove $Console(active) $W]
+}
+
+## ConsoleEval - evaluates commands input into console window
+## This is the first stage of the evaluating commands in the console.
+## They need to be broken up into consituent commands (by ConsoleCmdSep) in
+## case a multiple commands were pasted in, then each is eval'ed (by
+## ConsoleEvalCmd) in turn. Any uncompleted command will not be eval'ed.
+# ARGS: w - console text widget
+# Calls: ConsoleCmdGet, ConsoleCmdSep, ConsoleEvalCmd
+##
+;proc ConsoleEval {w} {
+ ConsoleCmdSep [ConsoleCmdGet $w] cmds cmd
+ $w mark set insert end-1c
+ $w insert end \n
+ if [llength $cmds] {
+ foreach c $cmds {ConsoleEvalCmd $w $c}
+ $w insert insert $cmd {}
+ } elseif {[info complete $cmd] && ![regexp {[^\\]\\$} $cmd]} {
+ ConsoleEvalCmd $w $cmd
+ }
+ $w see insert
+}
+
+## ConsoleEvalCmd - evaluates a single command, adding it to history
+# ARGS: w - console text widget
+# cmd - the command to evaluate
+# Calls: Console:prompt
+# Outputs: result of command to stdout (or stderr if error occured)
+# Returns: next event number
+##
+;proc ConsoleEvalCmd {w cmd} {
+ ## HACK to get $W as we need it
+ set W [winfo parent $w]
+ upvar \#0 $W data
+
+ $w mark set output end
+ if [string comp {} $cmd] {
+ set err 0
+ if $data(-subhistory) {
+ set ev [ConsoleEvalSlave history nextid]
+ incr ev -1
+ if {[string match !! $cmd]} {
+ set err [catch {ConsoleEvalSlave history event $ev} cmd]
+ if !$err {$w insert output $cmd\n stdin}
+ } elseif {[regexp {^!(.+)$} $cmd dummy event]} {
+ ## Check last event because history event is broken
+ set err [catch {ConsoleEvalSlave history event $ev} cmd]
+ if {!$err && ![string match ${event}* $cmd]} {
+ set err [catch {ConsoleEvalSlave history event $event} cmd]
+ }
+ if !$err {$w insert output $cmd\n stdin}
+ } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $cmd dummy old new]} {
+ if ![set err [catch {ConsoleEvalSlave history event $ev} cmd]] {
+ regsub -all -- $old $cmd $new cmd
+ $w insert output $cmd\n stdin
+ }
+ }
+ }
+ if $err {
+ $w insert output $cmd\n stderr
+ } else {
+ if [string match {} $data(appname)] {
+ if [catch {ConsoleEvalSlave eval $cmd} res] {
+ set data(errorInfo) [ConsoleEvalSlave set errorInfo]
+ set err 1
+ }
+ } else {
+ if [catch [list ConsoleEvalAttached $cmd] res] {
+ if [catch {ConsoleEvalAttached set errorInfo} err] {
+ set data(errorInfo) {Error attempting to retrieve errorInfo}
+ } else {
+ set data(errorInfo) $err
+ }
+ set err 1
+ }
+ }
+ ConsoleEvalSlave history add $cmd
+ if $err {
+ $w insert output $res\n stderr
+ } elseif {[string comp {} $res]} {
+ $w insert output $res\n stdout
+ }
+ }
+ }
+ Console:prompt $W
+ set data(event) [ConsoleEvalSlave history nextid]
+}
+
+## ConsoleEvalSlave - evaluates the args in the associated slave
+## args should be passed to this procedure like they would be at
+## the command line (not like to 'eval').
+# ARGS: args - the command and args to evaluate
+##
+;proc ConsoleEvalSlave {args} {
+ uplevel \#0 $args
+}
+
+## ConsoleEvalAttached
+##
+;proc ConsoleEvalAttached {args} {
+ eval uplevel \#0 $args
+}
+
+## ConsoleCmdGet - gets the current command from the console widget
+# ARGS: w - console text widget
+# Returns: text which compromises current command line
+##
+;proc ConsoleCmdGet w {
+ if [string match {} [$w tag nextrange prompt limit end]] {
+ $w tag add stdin limit end-1c
+ return [$w get limit end-1c]
+ }
+}
+
+## ConsoleCmdSep - separates multiple commands into a list and remainder
+# ARGS: cmd - (possible) multiple command to separate
+# list - varname for the list of commands that were separated.
+# rmd - varname of any remainder (like an incomplete final command).
+# If there is only one command, it's placed in this var.
+# Returns: constituent command info in varnames specified by list & rmd.
+##
+;proc ConsoleCmdSep {cmd ls rmd} {
+ upvar $ls cmds $rmd tmp
+
+ set tmp {}
+ set cmds {}
+ foreach cmd [split [set cmd] \n] {
+ if [string comp {} $tmp] {
+ append tmp \n$cmd
+ } else {
+ append tmp $cmd
+ }
+ if {[info complete $tmp] && ![regexp {[^\\]\\$} $tmp]} {
+ lappend cmds $tmp
+ set tmp {}
+ }
+ }
+ if {[string comp {} [lindex $cmds end]] && [string match {} $tmp]} {
+ set tmp [lindex $cmds end]
+ set cmds [lreplace $cmds end end]
+ }
+}
+
+## Console:prompt - displays the prompt in the console widget
+# ARGS: w - console text widget
+# Outputs: prompt (specified in data(-prompt)) to console
+##
+;proc Console:prompt {W {pre {}} {post {}} {prompt {}}} {
+ upvar \#0 $W data
+
+ set w $data(console)
+ if [string comp {} $pre] { $w insert end $pre stdout }
+ set i [$w index end-1c]
+ if [string comp {} $data(appname)] {
+ $w insert end ">$data(appname)< " prompt
+ }
+ if [string comp {} $prompt] {
+ $w insert end $prompt prompt
+ } else {
+ $w insert end [ConsoleEvalSlave subst $data(-prompt)] prompt
+ }
+ $w mark set output $i
+ $w mark set insert end
+ $w mark set limit insert
+ $w mark gravity limit left
+ if [string comp {} $post] { $w insert end $post stdin }
+ $w see end
+}
+
+## ConsoleAbout - gives about info for Console
+##
+;proc ConsoleAbout W {
+ global Console
+
+ set w $W.about
+ if [winfo exists $w] {
+ wm deiconify $w
+ } else {
+ toplevel $w
+ wm title $w "About Console v$Console(version)"
+ button $w.b -text Dismiss -command [list wm withdraw $w]
+ text $w.text -height 8 -bd 1 -width 60
+ pack $w.b -fill x -side bottom
+ pack $w.text -fill both -side left -expand 1
+ $w.text tag config center -justify center
+ $w.text tag config title -justify center -font {Courier 18 bold}
+ $w.text insert 1.0 "About Console v$Console(version)\n\n" title \
+ "Copyright 1995-1997 Jeffrey Hobbs, $Console(contact)\
+ \nhttp://www.cs.uoregon.edu/~jhobbs/\
+ \nRelease Date: v$Console(version), $Console(release)\
+ \nDocumentation available at:\n$Console(docs)" center
+ }
+}
+
+## ConsoleInitMenus - inits the menubar and popup for the console
+# ARGS: W - console
+##
+;proc ConsoleInitMenus {W} {
+ upvar \#0 $W data
+
+ set w $data(menubar)
+ set text $data(console)
+
+ if [catch {menu $w.pop -tearoff 0}] {
+ label $w.label -text "Menus not available in plugin mode"
+ pack $w.label
+ return
+ }
+ bind [winfo toplevel $w] <Button-3> "tk_popup $w.pop %X %Y"
+
+ pack [menubutton $w.con -text "Console" -un 0 -menu $w.con.m] -side left
+ $w.pop add cascade -label "Console" -un 0 -menu $w.pop.con
+
+ pack [menubutton $w.edit -text "Edit" -un 0 -menu $w.edit.m] -side left
+ $w.pop add cascade -label "Edit" -un 0 -menu $w.pop.edit
+
+ pack [menubutton $w.pref -text "Prefs" -un 0 -menu $w.pref.m] -side left
+ $w.pop add cascade -label "Prefs" -un 0 -menu $w.pop.pref
+
+ pack [menubutton $w.hist -text "History" -un 0 -menu $w.hist.m] -side left
+ $w.pop add cascade -label "History" -un 0 -menu $w.pop.hist
+
+ pack [menubutton $w.help -text "Help" -un 0 -menu $w.help.m] -side right
+ $w.pop add cascade -label "Help" -un 0 -menu $w.pop.help
+
+ ## Console Menu
+ ##
+ foreach m [list [menu $w.con.m -disabledfore $data(-promptcolor)] \
+ [menu $w.pop.con -disabledfore $data(-promptcolor)]] {
+ $m add command -label "Console $W" -state disabled
+ $m add command -label "Close Console " -un 0 \
+ -acc [event info <<Console_Close>>] -com [list destroy $W]
+ $m add command -label "Clear Console " -un 1 \
+ -acc [event info <<Console_Clear>>] -com [list Console_clear $W]
+ $m add separator
+ $m add command -label "Quit" -un 0 -acc [event info <<Console_Exit>>] \
+ -command exit
+ }
+
+ ## Edit Menu
+ ##
+ foreach m [list [menu $w.edit.m] [menu $w.pop.edit]] {
+ $m add command -label "Cut" -un 1 \
+ -acc [lindex [event info <<Cut>>] 0] \
+ -command [list ConsoleCut $text]
+ $m add command -label "Copy" -un 1 \
+ -acc [lindex [event info <<Copy>>] 0] \
+ -command [list ConsoleCopy $text]
+ $m add command -label "Paste" -un 0 \
+ -acc [lindex [event info <<Paste>>] 0] \
+ -command [list ConsolePaste $text]
+ $m add separator
+ $m add command -label "Find" -un 0 -acc [event info <<Console_Find>>] \
+ -command [list ConsoleFindBox $W]
+ }
+
+ ## Prefs Menu
+ ##
+ foreach m [list [menu $w.pref.m] [menu $w.pop.pref]] {
+ $m add checkbutton -label "Brace Highlighting" -var $W\(-lightbrace\)
+ $m add checkbutton -label "Command Highlighting" -var $W\(-lightcmd\)
+ $m add checkbutton -label "History Substitution" -var $W\(-subhistory\)
+ $m add checkbutton -label "Show Multiple Matches" -var $W\(-showmultiple\)
+ $m add checkbutton -label "Show Menubar" -var $W\(-showmenu\) \
+ -command "Console:configure $W -showmenu \[set $W\(-showmenu\)\]"
+ $m add cascade -label Scrollbar -un 0 -menu $m.scroll
+
+ ## Scrollbar Menu
+ ##
+ set m [menu $m.scroll -tearoff 0]
+ $m add radio -label "Left" -var $W\(-scrollypos\) -value left \
+ -command [list Console:configure $W -scrollypos left]
+ $m add radio -label "Right" -var $W\(-scrollypos\) -value right \
+ -command [list Console:configure $W -scrollypos right]
+ }
+
+ ## History Menu
+ ##
+ foreach m [list $w.hist.m $w.pop.hist] {
+ menu $m -disabledfore $data(-promptcolor) \
+ -postcommand [list ConsoleHistoryMenu $W $m]
+ }
+
+ ## Help Menu
+ ##
+ foreach m [list [menu $w.help.m] [menu $w.pop.help]] {
+ $m config -disabledfore $data(-promptcolor)
+ $m add command -label "About " -un 0 -acc [event info <<Console_About>>] \
+ -command [list ConsoleAbout $W]
+ }
+
+ bind $W <<Console_Exit>> exit
+ #bind $W <<Console_New>> ConsoleNew
+ bind $W <<Console_Close>> [list destroy $W]
+ bind $W <<Console_About>> [list ConsoleAbout $W]
+ bind $W <<Console_Help>> [list ConsoleHelp $W]
+ bind $W <<Console_Find>> [list ConsoleFindBox $W]
+
+ ## Menu items need null PostCon bindings to avoid the TagProc
+ ##
+ foreach ev [bind $W] {
+ bind PostCon $ev {
+ # empty
+ }
+ }
+}
+
+## ConsoleHistoryMenu - dynamically build the menu for attached interpreters
+##
+# ARGS: w - menu widget
+##
+;proc ConsoleHistoryMenu {W w} {
+ upvar \#0 $W data
+
+ if ![winfo exists $w] return
+ set id [ConsoleEvalSlave history nextid]
+ if {$data(histid)==$id} return
+ set data(histid) $id
+ $w delete 0 end
+ set con $data(console)
+ while {($id>$data(histid)-10) && \
+ ![catch {ConsoleEvalSlave history event [incr id -1]} tmp]} {
+ set lbl [lindex [split $tmp "\n"] 0]
+ if {[string len $lbl]>32} { set lbl [string range $tmp 0 30]... }
+ $w add command -label "$id: $lbl" -command "
+ $con delete limit end
+ $con insert limit [list $tmp]
+ $con see end
+ ConsoleEval $con
+ "
+ }
+}
+
+## ConsoleFindBox - creates minimal dialog interface to ConsoleFind
+# ARGS: w - text widget
+# str - optional seed string for data(find)
+##
+;proc ConsoleFindBox {W {str {}}} {
+ upvar \#0 $W data
+
+ set t $data(console)
+ set base $W.find
+ if ![winfo exists $base] {
+ toplevel $base
+ wm withdraw $base
+ wm title $base "Console Find"
+
+ pack [frame $base.f] -fill x -expand 1
+ label $base.f.l -text "Find:"
+ entry $base.f.e -textvar $W\(find\)
+ pack [frame $base.opt] -fill x
+ checkbutton $base.opt.c -text "Case Sensitive" -variable $W\(find,case\)
+ checkbutton $base.opt.r -text "Use Regexp" -variable $W\(find,reg\)
+ pack $base.f.l -side left
+ pack $base.f.e $base.opt.c $base.opt.r -side left -fill both -expand 1
+ pack [frame $base.sep -bd 2 -relief sunken -height 4] -fill x
+ pack [frame $base.btn] -fill both
+ button $base.btn.fnd -text "Find" -width 6
+ button $base.btn.clr -text "Clear" -width 6
+ button $base.btn.dis -text "Dismiss" -width 6
+ eval pack [winfo children $base.btn] -padx 4 -pady 2 -side left -fill both
+
+ focus $base.f.e
+
+ bind $base.f.e <Return> [list $base.btn.fnd invoke]
+ bind $base.f.e <Escape> [list $base.btn.dis invoke]
+ }
+ $base.btn.fnd config -command "Console_find $W \$data(find) \
+ -case \$data(find,case) -reg \$data(find,reg)"
+ $base.btn.clr config -command "
+ $t tag remove find 1.0 end
+ set data(find) {}
+ "
+ $base.btn.dis config -command "
+ $t tag remove find 1.0 end
+ wm withdraw $base
+ "
+ if [string comp {} $str] {
+ set data(find) $str
+ $base.btn.fnd invoke
+ }
+
+ if {[string comp normal [wm state $base]]} {
+ wm deiconify $base
+ } else { raise $base }
+ $base.f.e select range 0 end
+}
+
+## Console_find - searches in text widget for $str and highlights it
+## If $str is empty, it just deletes any highlighting
+# ARGS: W - console widget
+# str - string to search for
+# -case TCL_BOOLEAN whether to be case sensitive DEFAULT: 0
+# -regexp TCL_BOOLEAN whether to use $str as pattern DEFAULT: 0
+##
+;proc ConsoleFind {W str args} {
+ upvar \#0 $W data
+ set t $data(console)
+ $t tag remove find 1.0 end
+ set truth {^(1|yes|true|on)$}
+ set opts {}
+ foreach {key val} $args {
+ switch -glob -- $key {
+ -c* { if [regexp -nocase $truth $val] { set case 1 } }
+ -r* { if [regexp -nocase $truth $val] { lappend opts -regexp } }
+ default { return -code error "Unknown option $key" }
+ }
+ }
+ if ![info exists case] { lappend opts -nocase }
+ if [string match {} $str] return
+ $t mark set findmark 1.0
+ while {[string comp {} [set ix [eval $t search $opts -count numc -- \
+ [list $str] findmark end]]]} {
+ $t tag add find $ix ${ix}+${numc}c
+ $t mark set findmark ${ix}+1c
+ }
+ catch {$t see find.first}
+ return [expr [llength [$t tag ranges find]]/2]
+}
+
+## Console:savecommand - saves a command in a buffer for later retrieval
+#
+##
+;proc Console:savecommand {w} {
+ upvar \#0 [winfo parent $w] data
+
+ set tmp $data(cmdsave)
+ set data(cmdsave) [ConsoleCmdGet $w]
+ if {[string match {} $data(cmdsave)]} {
+ set data(cmdsave) $tmp
+ } else {
+ $w delete limit end-1c
+ }
+ $w insert limit $tmp
+ $w see end
+}
+
+## Console_load - sources a file into the console
+# ARGS: fn - (optional) filename to source in
+# Returns: selected filename ({} if nothing was selected)
+##
+;proc Console_load {W {fn {}}} {
+ if {[string match {} $fn] &&
+ ([catch {tk_getOpenFile} fn] || [string match {} $fn])} return
+ ConsoleEvalAttached [list source $fn]
+}
+
+## Console_save - saves the console buffer to a file
+## This does not eval in a slave because it's not necessary
+# ARGS: w - console text widget
+# fn - (optional) filename to save to
+##
+;proc Console_save {W {fn {}}} {
+ upvar \#0 $W data
+
+ if {[string match {} $fn] &&
+ ([catch {tk_getSaveFile} fn] || [string match {} $fn])} return
+ if [catch {open $fn w} fid] {
+ return -code error "Save Error: Unable to open '$fn' for writing\n$fid"
+ }
+ puts $fid [$data(console) get 1.0 end-1c]
+ close $fid
+}
+
+## clear - clears the buffer of the console (not the history though)
+##
+;proc Console_clear {W {pcnt 100}} {
+ upvar \#0 $W data
+
+ set data(tmp) [ConsoleCmdGet $data(console)]
+ if {![regexp {^[0-9]*$} $pcnt] || $pcnt < 1 || $pcnt > 100} {
+ return -code error \
+ "invalid percentage to clear: must be 1-100 (100 default)"
+ } elseif {$pcnt == 100} {
+ $data(console) delete 1.0 end
+ } else {
+ set tmp [expr $pcnt/100.0*[$data(console) index end]]
+ $data(console) delete 1.0 "$tmp linestart"
+ }
+ Console:prompt $W {} $data(tmp)
+}
+
+;proc Console_error {W} {
+ ## Outputs stack caused by last error.
+ upvar \#0 $W data
+ set info $data(errorInfo)
+ if [string match {} $info] { set info {errorInfo empty} }
+ catch {destroy $W.error}
+ set w [toplevel $W.error]
+ wm title $w "Console Last Error"
+ button $w.close -text Dismiss -command [list destroy $w]
+ scrollbar $w.sy -takefocus 0 -bd 1 -command [list $w.text yview]
+ text $w.text -font $data(-font) -yscrollcommand [list $w.sy set]
+ pack $w.close -side bottom -fill x
+ pack $w.sy -side right -fill y
+ pack $w.text -fill both -expand 1
+ $w.text insert 1.0 $info
+ $w.text config -state disabled
+}
+
+## Console_event - searches for history based on a string
+## Search forward (next) if $int>0, otherwise search back (prev)
+# ARGS: W - console widget
+##
+;proc Console_event {W int {str {}}} {
+ upvar \#0 $W data
+
+ if !$int return
+ set w $data(console)
+
+ set nextid [ConsoleEvalSlave history nextid]
+ if [string comp {} $str] {
+ ## String is not empty, do an event search
+ set event $data(event)
+ if {$int < 0 && $event == $nextid} { set data(cmdbuf) $str }
+ set len [string len $data(cmdbuf)]
+ incr len -1
+ if {$int > 0} {
+ ## Search history forward
+ while {$event < $nextid} {
+ if {[incr event] == $nextid} {
+ $w delete limit end
+ $w insert limit $data(cmdbuf)
+ break
+ } elseif {![catch {ConsoleEvalSlave history event $event} res] \
+ && ![string comp $data(cmdbuf) [string range $res 0 $len]]} {
+ $w delete limit end
+ $w insert limit $res
+ break
+ }
+ }
+ set data(event) $event
+ } else {
+ ## Search history reverse
+ while {![catch {ConsoleEvalSlave history event [incr event -1]} res]} {
+ if {![string comp $data(cmdbuf) [string range $res 0 $len]]} {
+ $w delete limit end
+ $w insert limit $res
+ set data(event) $event
+ break
+ }
+ }
+ }
+ } else {
+ ## String is empty, just get next/prev event
+ if {$int > 0} {
+ ## Goto next command in history
+ if {$data(event) < $nextid} {
+ $w delete limit end
+ if {[incr data(event)] == $nextid} {
+ $w insert limit $data(cmdbuf)
+ } else {
+ $w insert limit [ConsoleEvalSlave history event $data(event)]
+ }
+ }
+ } else {
+ ## Goto previous command in history
+ if {$data(event) == $nextid} { set data(cmdbuf) [ConsoleCmdGet $w] }
+ if [catch {ConsoleEvalSlave history event [incr data(event) -1]} res] {
+ incr data(event)
+ } else {
+ $w delete limit end
+ $w insert limit $res
+ }
+ }
+ }
+ $w mark set insert end
+ $w see end
+}
+
+;proc Console_history {W args} {
+ set sub {\2}
+ if [string match -n* $args] { append sub "\n" }
+ set h [ConsoleEvalSlave history]
+ regsub -all "( *\[0-9\]+ |\t)(\[^\n\]*\n?)" $h $sub h
+ return $h
+}
+
+;proc Console_hide {W} {
+ wm withdraw $W
+}
+
+;proc Console_show {W} {
+ wm deiconify $W
+ raise $W
+}
+
+##
+## Some procedures to make up for lack of built-in shell commands
+##
+
+## puts
+## This allows me to capture all stdout/stderr to the console window
+# ARGS: same as usual
+# Outputs: the string with a color-coded text tag
+##
+if ![catch {rename puts tcl_puts}] {
+ ;proc puts args {
+ global Console
+ set w [lindex $Console(active) 0].text
+ if {[llength $Console(active)] && [winfo exists $w]} {
+ set len [llength $args]
+ if {$len==1} {
+ eval $w insert output $args stdout {\n} stdout
+ $w see output
+ } elseif {$len==2 && \
+ [regexp {(stdout|stderr|-nonewline)} [lindex $args 0] junk tmp]} {
+ if [string comp $tmp -nonewline] {
+ eval $w insert output [lreplace $args 0 0] $tmp {\n} $tmp
+ } else {
+ eval $w insert output [lreplace $args 0 0] stdout
+ }
+ $w see output
+ } elseif {$len==3 && \
+ [regexp {(stdout|stderr)} [lreplace $args 2 2] junk tmp]} {
+ if [string comp [lreplace $args 1 2] -nonewline] {
+ eval $w insert output [lrange $args 1 1] $tmp
+ } else {
+ eval $w insert output [lreplace $args 0 1] $tmp
+ }
+ $w see output
+ } else {
+ global errorCode errorInfo
+ if [catch "tcl_puts $args" msg] {
+ regsub tcl_puts $msg puts msg
+ regsub -all tcl_puts $errorInfo puts errorInfo
+ error $msg
+ }
+ return $msg
+ }
+ if $len update
+ } else {
+ global errorCode errorInfo
+ if [catch "tcl_puts $args" msg] {
+ regsub tcl_puts $msg puts msg
+ regsub -all tcl_puts $errorInfo puts errorInfo
+ error $msg
+ }
+ return $msg
+ }
+ }
+}
+
+## echo
+## Relaxes the one string restriction of 'puts'
+# ARGS: any number of strings to output to stdout
+##
+proc echo args { puts [concat $args] }
+
+## alias - akin to the csh alias command
+## If called with no args, then it dumps out all current aliases
+## If called with one arg, returns the alias of that arg (or {} if none)
+# ARGS: newcmd - (optional) command to bind alias to
+# args - command and args being aliased
+##
+proc alias {{newcmd {}} args} {
+ if [string match {} $newcmd] {
+ set res {}
+ foreach a [interp aliases] {
+ lappend res [list $a -> [interp alias {} $a]]
+ }
+ return [join $res \n]
+ } elseif {[string match {} $args]} {
+ interp alias {} $newcmd
+ } else {
+ eval interp alias [list {} $newcmd {}] $args
+ }
+}
+
+## dump - outputs variables/procedure/widget info in source'able form.
+## Accepts glob style pattern matching for the names
+# ARGS: type - type of thing to dump: must be variable, procedure, widget
+# OPTS: -nocomplain
+# don't complain if no vars match something
+# -filter pattern
+# specifies a glob filter pattern to be used by the variable
+# method as an array filter pattern (it filters down for
+# nested elements) and in the widget method as a config
+# option filter pattern
+# -- forcibly ends options recognition
+# Returns: the values of the requested items in a 'source'able form
+##
+proc dump {type args} {
+ set whine 1
+ set code ok
+ while {[string match -* $args]} {
+ switch -glob -- [lindex $args 0] {
+ -n* { set whine 0; set args [lreplace $args 0 0] }
+ -f* { set fltr [lindex $args 1]; set args [lreplace $args 0 1] }
+ -- { set args [lreplace $args 0 0]; break }
+ default { return -code error "unknown option \"[lindex $args 0]\"" }
+ }
+ }
+ if {$whine && [string match {} $args]} {
+ return -code error "wrong \# args: [lindex [info level 0] 0]\
+ ?-nocomplain? ?-filter pattern? ?--? pattern ?pattern ...?"
+ }
+ set res {}
+ switch -glob -- $type {
+ c* {
+ # command
+ # outpus commands by figuring out, as well as possible, what it is
+ # this does not attempt to auto-load anything
+ foreach arg $args {
+ if [string comp {} [set cmds [info comm $arg]]] {
+ foreach cmd [lsort $cmds] {
+ if {[lsearch -exact [interp aliases] $cmd] > -1} {
+ append res "\#\# ALIAS: $cmd => [interp alias {} $cmd]\n"
+ } elseif {[string comp {} [info procs $cmd]]} {
+ if {[catch {dump p -- $cmd} msg] && $whine} { set code error }
+ append res $msg\n
+ } else {
+ append res "\#\# COMMAND: $cmd\n"
+ }
+ }
+ } elseif $whine {
+ append res "\#\# No known command $arg\n"
+ set code error
+ }
+ }
+ }
+ v* {
+ # variable
+ # outputs variables value(s), whether array or simple.
+ if ![info exists fltr] { set fltr * }
+ foreach arg $args {
+ if {[string match {} [set vars [uplevel info vars [list $arg]]]]} {
+ if {[uplevel info exists $arg]} {
+ set vars $arg
+ } elseif $whine {
+ append res "\#\# No known variable $arg\n"
+ set code error
+ continue
+ } else continue
+ }
+ foreach var [lsort $vars] {
+ upvar $var v
+ if {[array exists v]} {
+ set nest {}
+ append res "array set $var \{\n"
+ foreach i [lsort [array names v $fltr]] {
+ upvar 0 v\($i\) __ary
+ if {[array exists __ary]} {
+ append nest "\#\# NESTED ARRAY ELEMENT: $i\n"
+ append nest "upvar 0 [list $var\($i\)] __ary;\
+ [dump v -filter $fltr __ary]\n"
+ } else {
+ append res " [list $i]\t[list $v($i)]\n"
+ }
+ }
+ append res "\}\n$nest"
+ } else {
+ append res [list set $var $v]\n
+ }
+ }
+ }
+ }
+ p* {
+ # procedure
+ foreach arg $args {
+ if {[string comp {} [set ps [info proc $arg]]] ||
+ ([auto_load $arg] &&
+ [string comp {} [set ps [info proc $arg]]])} {
+ foreach p [lsort $ps] {
+ set as {}
+ foreach a [info args $p] {
+ if {[info default $p $a tmp]} {
+ lappend as [list $a $tmp]
+ } else {
+ lappend as $a
+ }
+ }
+ append res [list proc $p $as [info body $p]]\n
+ }
+ } elseif $whine {
+ append res "\#\# No known proc $arg\n"
+ set code error
+ }
+ }
+ }
+ w* {
+ # widget
+ ## The user should have Tk loaded
+ if [string match {} [info command winfo]] {
+ return -code error "winfo not present, cannot dump widgets"
+ }
+ if ![info exists fltr] { set fltr .* }
+ foreach arg $args {
+ if [string comp {} [set ws [info command $arg]]] {
+ foreach w [lsort $ws] {
+ if [winfo exists $w] {
+ if [catch {$w configure} cfg] {
+ append res "\#\# Widget $w does not support configure method"
+ set code error
+ } else {
+ append res "\#\# [winfo class $w] $w\n$w configure"
+ foreach c $cfg {
+ if {[llength $c] != 5} continue
+ if {[regexp -nocase -- $fltr $c]} {
+ append res " \\\n\t[list [lindex $c 0] [lindex $c 4]]"
+ }
+ }
+ append res \n
+ }
+ }
+ }
+ } elseif $whine {
+ append res "\#\# No known widget $arg\n"
+ set code error
+ }
+ }
+ }
+ default {
+ return -code error "bad [lindex [info level 0] 0] option\
+ \"$type\":\ must be procedure, variable, widget"
+ }
+ }
+ return -code $code [string trimr $res \n]
+}
+
+## which - tells you where a command is found
+# ARGS: cmd - command name
+# Returns: where command is found (internal / external / unknown)
+##
+proc which cmd {
+ if {[string comp {} [info commands $cmd]] ||
+ ([auto_load $cmd] && [string comp {} [info commands $cmd]])} {
+ if {[lsearch -exact [interp aliases] $cmd] > -1} {
+ return "$cmd:\taliased to [alias $cmd]"
+ } elseif {[string comp {} [info procs $cmd]]} {
+ return "$cmd:\tinternal proc"
+ } else {
+ return "$cmd:\tinternal command"
+ }
+ } elseif {[string comp {} [auto_execok $cmd]]} {
+ return [auto_execok $cmd]
+ } else {
+ return -code error "$cmd:\tunknown command"
+ }
+}
+
+## dir - directory list
+# ARGS: args - names/glob patterns of directories to list
+# OPTS: -all - list hidden files as well (Unix dot files)
+# -long - list in full format "permissions size date filename"
+# -full - displays / after directories and link paths for links
+# Returns: a directory listing
+##
+proc dir {args} {
+ array set s {
+ all 0 full 0 long 0
+ 0 --- 1 --x 2 -w- 3 -wx 4 r-- 5 r-x 6 rw- 7 rwx
+ }
+ while {[string match \-* [lindex $args 0]]} {
+ set str [lindex $args 0]
+ set args [lreplace $args 0 0]
+ switch -glob -- $str {
+ -a* {set s(all) 1} -f* {set s(full) 1}
+ -l* {set s(long) 1} -- break
+ default {
+ return -code error \
+ "unknown option \"$str\", should be one of: -all, -full, -long"
+ }
+ }
+ }
+ set sep [string trim [file join . .] .]
+ if [string match {} $args] { set args . }
+ foreach arg $args {
+ if {[file isdir $arg]} {
+ set arg [string trimr $arg $sep]$sep
+ if $s(all) {
+ lappend out [list $arg [lsort [glob -nocomplain -- $arg.* $arg*]]]
+ } else {
+ lappend out [list $arg [lsort [glob -nocomplain -- $arg*]]]
+ }
+ } else {
+ lappend out [list [file dirname $arg]$sep \
+ [lsort [glob -nocomplain -- $arg]]]
+ }
+ }
+ if $s(long) {
+ set old [clock scan {1 year ago}]
+ set fmt "%s%9d %s %s\n"
+ foreach o $out {
+ set d [lindex $o 0]
+ append res $d:\n
+ foreach f [lindex $o 1] {
+ file lstat $f st
+ set f [file tail $f]
+ if $s(full) {
+ switch -glob $st(type) {
+ d* { append f $sep }
+ l* { append f "@ -> [file readlink $d$sep$f]" }
+ default { if [file exec $d$sep$f] { append f * } }
+ }
+ }
+ if [string match file $st(type)] {
+ set mode -
+ } else {
+ set mode [string index $st(type) 0]
+ }
+ foreach j [split [format %o [expr $st(mode)&0777]] {}] {
+ append mode $s($j)
+ }
+ if {$st(mtime)>$old} {
+ set cfmt {%b %d %H:%M}
+ } else {
+ set cfmt {%b %d %Y}
+ }
+ append res [format $fmt $mode $st(size) \
+ [clock format $st(mtime) -format $cfmt] $f]
+ }
+ append res \n
+ }
+ } else {
+ foreach o $out {
+ set d [lindex $o 0]
+ append res $d:\n
+ set i 0
+ foreach f [lindex $o 1] {
+ if {[string len [file tail $f]] > $i} {
+ set i [string len [file tail $f]]
+ }
+ }
+ set i [expr $i+2+$s(full)]
+ ## This gets the number of cols in the Console console widget
+ set j [expr 64/$i]
+ set k 0
+ foreach f [lindex $o 1] {
+ set f [file tail $f]
+ if $s(full) {
+ switch -glob [file type $d$sep$f] {
+ d* { append f $sep }
+ l* { append f @ }
+ default { if [file exec $d$sep$f] { append f * } }
+ }
+ }
+ append res [format "%-${i}s" $f]
+ if {[incr k]%$j == 0} {set res [string trimr $res]\n}
+ }
+ append res \n\n
+ }
+ }
+ return [string trimr $res]
+}
+interp alias {} ls {} dir
+
+## lremove - remove items from a list
+# OPTS: -all remove all instances of each item
+# ARGS: l a list to remove items from
+# args items to remove
+##
+proc lremove {args} {
+ set all 0
+ if [string match \-a* [lindex $args 0]] {
+ set all 1
+ set args [lreplace $args 0 0]
+ }
+ set l [lindex $args 0]
+ eval append is [lreplace $args 0 0]
+ foreach i $is {
+ if {[set ix [lsearch -exact $l $i]] == -1} continue
+ set l [lreplace $l $ix $ix]
+ if $all {
+ while {[set ix [lsearch -exact $l $i]] != -1} {
+ set l [lreplace $l $ix $ix]
+ }
+ }
+ }
+ return $l
+}
+
+## Unknown changed to get output into Console window
+# unknown:
+# Invoked automatically whenever an unknown command is encountered.
+# Works through a list of "unknown handlers" that have been registered
+# to deal with unknown commands. Extensions can integrate their own
+# handlers into the "unknown" facility via "unknown_handle".
+#
+# If a handler exists that recognizes the command, then it will
+# take care of the command action and return a valid result or a
+# Tcl error. Otherwise, it should return "-code continue" (=2)
+# and responsibility for the command is passed to the next handler.
+#
+# Arguments:
+# args - A list whose elements are the words of the original
+# command, including the command name.
+
+proc unknown args {
+ global unknown_handler_order unknown_handlers errorInfo errorCode
+
+ #
+ # Be careful to save error info now, and restore it later
+ # for each handler. Some handlers generate their own errors
+ # and disrupt handling.
+ #
+ set savedErrorCode $errorCode
+ set savedErrorInfo $errorInfo
+
+ if {![info exists unknown_handler_order] || ![info exists unknown_handlers]} {
+ set unknown_handlers(tcl) tcl_unknown
+ set unknown_handler_order tcl
+ }
+
+ foreach handler $unknown_handler_order {
+ set status [catch {uplevel $unknown_handlers($handler) $args} result]
+
+ if {$status == 1} {
+ #
+ # Strip the last five lines off the error stack (they're
+ # from the "uplevel" command).
+ #
+ set new [split $errorInfo \n]
+ set new [join [lrange $new 0 [expr [llength $new] - 6]] \n]
+ return -code $status -errorcode $errorCode \
+ -errorinfo $new $result
+
+ } elseif {$status != 4} {
+ return -code $status $result
+ }
+
+ set errorCode $savedErrorCode
+ set errorInfo $savedErrorInfo
+ }
+
+ set name [lindex $args 0]
+ return -code error "invalid command name \"$name\""
+}
+
+# tcl_unknown:
+# Invoked when a Tcl command is invoked that doesn't exist in the
+# interpreter:
+#
+# 1. See if the autoload facility can locate the command in a
+# Tcl script file. If so, load it and execute it.
+# 2. If the command was invoked interactively at top-level:
+# (a) see if the command exists as an executable UNIX program.
+# If so, "exec" the command.
+# (b) see if the command requests csh-like history substitution
+# in one of the common forms !!, !<number>, or ^old^new. If
+# so, emulate csh's history substitution.
+# (c) see if the command is a unique abbreviation for another
+# command. If so, invoke the command.
+#
+# Arguments:
+# args - A list whose elements are the words of the original
+# command, including the command name.
+
+proc tcl_unknown args {
+ global auto_noexec auto_noload env unknown_pending tcl_interactive Console
+ global errorCode errorInfo
+
+ # Save the values of errorCode and errorInfo variables, since they
+ # may get modified if caught errors occur below. The variables will
+ # be restored just before re-executing the missing command.
+
+ set savedErrorCode $errorCode
+ set savedErrorInfo $errorInfo
+ set name [lindex $args 0]
+ if ![info exists auto_noload] {
+ #
+ # Make sure we're not trying to load the same proc twice.
+ #
+ if [info exists unknown_pending($name)] {
+ unset unknown_pending($name)
+ if {[array size unknown_pending] == 0} {
+ unset unknown_pending
+ }
+ return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
+ }
+ set unknown_pending($name) pending;
+ set ret [catch {auto_load $name} msg]
+ unset unknown_pending($name);
+ if $ret {
+ return -code $ret -errorcode $errorCode \
+ "error while autoloading \"$name\": $msg"
+ }
+ if ![array size unknown_pending] {
+ unset unknown_pending
+ }
+ if $msg {
+ set errorCode $savedErrorCode
+ set errorInfo $savedErrorInfo
+ set code [catch {uplevel $args} msg]
+ if {$code == 1} {
+ #
+ # Strip the last five lines off the error stack (they're
+ # from the "uplevel" command).
+ #
+
+ set new [split $errorInfo \n]
+ set new [join [lrange $new 0 [expr [llength $new] - 6]] \n]
+ return -code error -errorcode $errorCode \
+ -errorinfo $new $msg
+ } else {
+ return -code $code $msg
+ }
+ }
+ }
+ if {[info level] == 1 && [string match {} [info script]] \
+ && [info exists tcl_interactive] && $tcl_interactive} {
+ if ![info exists auto_noexec] {
+ set new [auto_execok $name]
+ if {$new != ""} {
+ set errorCode $savedErrorCode
+ set errorInfo $savedErrorInfo
+ return [uplevel exec [list $new] [lrange $args 1 end]]
+ #return [uplevel exec >&@stdout <@stdin $new [lrange $args 1 end]]
+ }
+ }
+ set errorCode $savedErrorCode
+ set errorInfo $savedErrorInfo
+ ##
+ ## History substitution moved into ConsoleEvalCmd
+ ##
+ set cmds [info commands $name*]
+ if {[llength $cmds] == 1} {
+ return [uplevel [lreplace $args 0 0 $cmds]]
+ }
+ if {[llength $cmds]} {
+ if {$name == ""} {
+ return -code error "empty command name \"\""
+ } else {
+ return -code error \
+ "ambiguous command name \"$name\": [lsort $cmds]"
+ }
+ }
+ }
+ return -code continue
+}
+
+switch -glob $tcl_platform(platform) {
+ win* { set META Alt }
+ mac* { set META Command }
+ default { set META Meta }
+}
+
+# ConsoleClipboardKeysyms --
+# This procedure is invoked to identify the keys that correspond to
+# the "copy", "cut", and "paste" functions for the clipboard.
+#
+# Arguments:
+# copy - Name of the key (keysym name plus modifiers, if any,
+# such as "Meta-y") used for the copy operation.
+# cut - Name of the key used for the cut operation.
+# paste - Name of the key used for the paste operation.
+
+;proc ConsoleClipboardKeysyms {copy cut paste} {
+ bind Console <$copy> {ConsoleCopy %W}
+ bind Console <$cut> {ConsoleCut %W}
+ bind Console <$paste> {ConsolePaste %W}
+}
+
+;proc ConsoleCut w {
+ if [string match $w [selection own -displayof $w]] {
+ clipboard clear -displayof $w
+ catch {
+ clipboard append -displayof $w [selection get -displayof $w]
+ if [$w compare sel.first >= limit] {$w delete sel.first sel.last}
+ }
+ }
+}
+;proc ConsoleCopy w {
+ if [string match $w [selection own -displayof $w]] {
+ clipboard clear -displayof $w
+ catch {clipboard append -displayof $w [selection get -displayof $w]}
+ }
+}
+
+;proc ConsolePaste w {
+ if ![catch {selection get -displayof $w -selection CLIPBOARD} tmp] {
+ if [$w compare insert < limit] {$w mark set insert end}
+ $w insert insert $tmp
+ $w see insert
+ if [string match *\n* $tmp] {ConsoleEval $w}
+ }
+}
+
+## Get all Text bindings into Console except Unix cut/copy/paste
+## and newline insertion
+foreach ev [lremove [bind Text] {<Control-Key-y> <Control-Key-w> \
+ <Meta-Key-w> <Control-Key-o> <Control-Key-v> <Control-Key-c> \
+ <Control-Key-x>}] {
+ bind Console $ev [bind Text $ev]
+}
+
+foreach {ev key} {
+ <<Console_Previous>> <Key-Up>
+ <<Console_Next>> <Key-Down>
+ <<Console_NextImmediate>> <Control-Key-n>
+ <<Console_PreviousImmediate>> <Control-Key-p>
+ <<Console_PreviousSearch>> <Control-Key-r>
+ <<Console_NextSearch>> <Control-Key-s>
+
+ <<Console_ExpandFile>> <Key-Tab>
+ <<Console_ExpandProc>> <Control-Shift-Key-P>
+ <<Console_ExpandVar>> <Control-Shift-Key-V>
+ <<Console_Tab>> <Control-Key-i>
+ <<Console_Eval>> <Key-Return>
+ <<Console_Eval>> <Key-KP_Enter>
+
+ <<Console_Clear>> <Control-Key-l>
+ <<Console_KillLine>> <Control-Key-k>
+ <<Console_Transpose>> <Control-Key-t>
+ <<Console_ClearLine>> <Control-Key-u>
+ <<Console_SaveCommand>> <Control-Key-z>
+
+ <<Console_Exit>> <Control-Key-q>
+ <<Console_New>> <Control-Key-N>
+ <<Console_Close>> <Control-Key-w>
+ <<Console_About>> <Control-Key-A>
+ <<Console_Help>> <Control-Key-H>
+ <<Console_Find>> <Control-Key-F>
+} {
+ event add $ev $key
+ bind Console $key {}
+}
+catch {unset ev key}
+
+## Redefine for Console what we need
+##
+event delete <<Paste>> <Control-V>
+ConsoleClipboardKeysyms <Copy> <Cut> <Paste>
+
+bind Console <Insert> {catch {ConsoleInsert %W [selection get -displayof %W]}}
+
+bind Console <Triple-1> {+
+catch {
+ eval %W tag remove sel [%W tag nextrange prompt sel.first sel.last]
+ %W mark set insert sel.first
+}
+}
+
+bind Console <<Console_ExpandFile>> {
+ if [%W compare insert > limit] {Console:expand %W path}
+ break
+}
+bind Console <<Console_ExpandProc>> {
+ if [%W compare insert > limit] {Console:expand %W proc}
+}
+bind Console <<Console_ExpandVar>> {
+ if [%W compare insert > limit] {Console:expand %W var}
+}
+bind Console <<Console_Tab>> {
+ if [%W compare insert >= limit] {
+ ConsoleInsert %W \t
+ }
+}
+bind Console <<Console_Eval>> {
+ ConsoleEval %W
+}
+bind Console <Delete> {
+ if {[string comp {} [%W tag nextrange sel 1.0 end]] \
+ && [%W compare sel.first >= limit]} {
+ %W delete sel.first sel.last
+ } elseif {[%W compare insert >= limit]} {
+ %W delete insert
+ %W see insert
+ }
+}
+bind Console <BackSpace> {
+ if {[string comp {} [%W tag nextrange sel 1.0 end]] \
+ && [%W compare sel.first >= limit]} {
+ %W delete sel.first sel.last
+ } elseif {[%W compare insert != 1.0] && [%W compare insert > limit]} {
+ %W delete insert-1c
+ %W see insert
+ }
+}
+bind Console <Control-h> [bind Console <BackSpace>]
+
+bind Console <KeyPress> {
+ ConsoleInsert %W %A
+}
+
+bind Console <Control-a> {
+ if [%W compare {limit linestart} == {insert linestart}] {
+ tkTextSetCursor %W limit
+ } else {
+ tkTextSetCursor %W {insert linestart}
+ }
+}
+bind Console <Control-d> {
+ if [%W compare insert < limit] break
+ %W delete insert
+}
+bind Console <<Console_KillLine>> {
+ if [%W compare insert < limit] break
+ if [%W compare insert == {insert lineend}] {
+ %W delete insert
+ } else {
+ %W delete insert {insert lineend}
+ }
+}
+bind Console <<Console_Clear>> {
+ Console_clear [winfo parent %W]
+}
+bind Console <<Console_Previous>> {
+ if [%W compare {insert linestart} != {limit linestart}] {
+ tkTextSetCursor %W [tkTextUpDownLine %W -1]
+ } else {
+ Console_event [winfo parent %W] -1
+ }
+}
+bind Console <<Console_Next>> {
+ if [%W compare {insert linestart} != {end-1c linestart}] {
+ tkTextSetCursor %W [tkTextUpDownLine %W 1]
+ } else {
+ Console_event [winfo parent %W] 1
+ }
+}
+bind Console <<Console_NextImmediate>> {
+ Console_event [winfo parent %W] 1
+}
+bind Console <<Console_PreviousImmediate>> {
+ Console_event [winfo parent %W] -1
+}
+bind Console <<Console_PreviousSearch>> {
+ Console_event [winfo parent %W] -1 [ConsoleCmdGet %W]
+}
+bind Console <<Console_NextSearch>> {
+ Console_event [winfo parent %W] 1 [ConsoleCmdGet %W]
+}
+bind Console <<Console_Transpose>> {
+ ## Transpose current and previous chars
+ if [%W compare insert > limit] { tkTextTranspose %W }
+}
+bind Console <<Console_ClearLine>> {
+ ## Clear command line (Unix shell staple)
+ %W delete limit end
+}
+bind Console <<Console_SaveCommand>> {
+ ## Save command buffer (swaps with current command)
+ Console:savecommand %W
+}
+catch {bind Console <Key-Page_Up> { tkTextScrollPages %W -1 }}
+catch {bind Console <Key-Prior> { tkTextScrollPages %W -1 }}
+catch {bind Console <Key-Page_Down> { tkTextScrollPages %W 1 }}
+catch {bind Console <Key-Next> { tkTextScrollPages %W 1 }}
+bind Console <$META-d> {
+ if [%W compare insert >= limit] {
+ %W delete insert {insert wordend}
+ }
+}
+bind Console <$META-BackSpace> {
+ if [%W compare {insert -1c wordstart} >= limit] {
+ %W delete {insert -1c wordstart} insert
+ }
+}
+bind Console <$META-Delete> {
+ if [%W compare insert >= limit] {
+ %W delete insert {insert wordend}
+ }
+}
+bind Console <ButtonRelease-2> {
+ if {(!$tkPriv(mouseMoved) || $tk_strictMotif) \
+ && ![catch {selection get -displayof %W} tkPriv(junk)]} {
+ if [%W compare @%x,%y < limit] {
+ %W insert end $tkPriv(junk)
+ } else {
+ %W insert @%x,%y $tkPriv(junk)
+ }
+ if [string match *\n* $tkPriv(junk)] {ConsoleEval %W}
+ }
+}
+
+##
+## End Console bindings
+##
+
+##
+## Bindings for doing special things based on certain keys
+##
+bind PostCon <Key-parenright> {
+ if [string comp \\ [%W get insert-2c]] { ConsoleMatchPair %W \( \) limit }
+}
+bind PostCon <Key-bracketright> {
+ if [string comp \\ [%W get insert-2c]] { ConsoleMatchPair %W \[ \] limit }
+}
+bind PostCon <Key-braceright> {
+ if [string comp \\ [%W get insert-2c]] { ConsoleMatchPair %W \{ \} limit }
+}
+bind PostCon <Key-quotedbl> {
+ if [string comp \\ [%W get insert-2c]] { ConsoleMatchQuote %W limit }
+}
+
+bind PostCon <KeyPress> {
+ if [string comp {} %A] { ConsoleTagProc %W }
+}
+
+
+## ConsoleTagProc - tags a procedure in the console if it's recognized
+## This procedure is not perfect. However, making it perfect wastes
+## too much CPU time... Also it should check the existence of a command
+## in whatever is the connected slave, not the master interpreter.
+##
+;proc ConsoleTagProc w {
+ upvar \#0 [winfo parent $w] data
+ if !$data(-lightcmd) return
+ set i [$w index "insert-1c wordstart"]
+ set j [$w index "insert-1c wordend"]
+ if {[string comp {} \
+ [ConsoleEvalAttached info command [list [$w get $i $j]]]]} {
+ $w tag add proc $i $j
+ } else {
+ $w tag remove proc $i $j
+ }
+}
+
+## ConsoleMatchPair - blinks a matching pair of characters
+## c2 is assumed to be at the text index 'insert'.
+## This proc is really loopy and took me an hour to figure out given
+## all possible combinations with escaping except for escaped \'s.
+## It doesn't take into account possible commenting... Oh well. If
+## anyone has something better, I'd like to see/use it. This is really
+## only efficient for small contexts.
+# ARGS: w - console text widget
+# c1 - first char of pair
+# c2 - second char of pair
+# Calls: Console:blink
+##
+;proc ConsoleMatchPair {w c1 c2 {lim 1.0}} {
+ upvar \#0 [winfo parent $w] data
+ if {!$data(-lightbrace) || $data(-blinktime)<100} return
+ if [string comp {} [set ix [$w search -back $c1 insert $lim]]] {
+ while {[string match {\\} [$w get $ix-1c]] &&
+ [string comp {} [set ix [$w search -back $c1 $ix-1c $lim]]]} {}
+ set i1 insert-1c
+ while {[string comp {} $ix]} {
+ set i0 $ix
+ set j 0
+ while {[string comp {} [set i0 [$w search $c2 $i0 $i1]]]} {
+ append i0 +1c
+ if {[string match {\\} [$w get $i0-2c]]} continue
+ incr j
+ }
+ if {!$j} break
+ set i1 $ix
+ while {$j && [string comp {} [set ix [$w search -back $c1 $ix $lim]]]} {
+ if {[string match {\\} [$w get $ix-1c]]} continue
+ incr j -1
+ }
+ }
+ if [string match {} $ix] { set ix [$w index $lim] }
+ } else { set ix [$w index $lim] }
+ if $data(-blinkrange) {
+ Console:blink $w $data(-blinktime) $ix [$w index insert]
+ } else {
+ Console:blink $w $data(-blinktime) $ix $ix+1c \
+ [$w index insert-1c] [$w index insert]
+ }
+}
+
+## ConsoleMatchQuote - blinks between matching quotes.
+## Blinks just the quote if it's unmatched, otherwise blinks quoted string
+## The quote to match is assumed to be at the text index 'insert'.
+# ARGS: w - console text widget
+# Calls: Console:blink
+##
+;proc ConsoleMatchQuote {w {lim 1.0}} {
+ upvar \#0 [winfo parent $w] data
+ if {!$data(-lightbrace) || $data(-blinktime)<100} return
+ set i insert-1c
+ set j 0
+ while {[string comp {} [set i [$w search -back \" $i $lim]]]} {
+ if {[string match {\\} [$w get $i-1c]]} continue
+ if {!$j} {set i0 $i}
+ incr j
+ }
+ if [expr $j%2] {
+ if $data(-blinkrange) {
+ Console:blink $w $data(-blinktime) $i0 [$w index insert]
+ } else {
+ Console:blink $w $data(-blinktime) $i0 $i0+1c \
+ [$w index insert-1c] [$w index insert]
+ }
+ } else {
+ Console:blink $w $data(-blinktime) [$w index insert-1c] [$w index insert]
+ }
+}
+
+## Console:blink - blinks between 2 indices for a specified duration.
+# ARGS: w - console text widget
+# delay - millisecs to blink for
+# args - indices of regions to blink
+# Outputs: blinks selected characters in $w
+##
+;proc Console:blink {w delay args} {
+ eval $w tag add blink $args
+ after $delay eval $w tag remove blink $args
+ return
+}
+
+
+## ConsoleInsert
+## Insert a string into a text console at the point of the insertion cursor.
+## If there is a selection in the text, and it covers the point of the
+## insertion cursor, then delete the selection before inserting.
+# ARGS: w - text window in which to insert the string
+# s - string to insert (usually just a single char)
+# Outputs: $s to text widget
+##
+;proc ConsoleInsert {w s} {
+ if {[string match {} $s] || [string match disabled [$w cget -state]]} {
+ return
+ }
+ if [$w comp insert < limit] {
+ $w mark set insert end
+ }
+ catch {
+ if {[$w comp sel.first <= insert] && [$w comp sel.last >= insert]} {
+ $w delete sel.first sel.last
+ }
+ }
+ $w insert insert $s
+ $w see insert
+}
+
+## Console:expand -
+# ARGS: w - text widget in which to expand str
+# type - type of expansion (path / proc / variable)
+# Calls: ConsoleExpand(Pathname|Procname|Variable)
+# Outputs: The string to match is expanded to the longest possible match.
+# If data(-showmultiple) is non-zero and the user longest match
+# equaled the string to expand, then all possible matches are
+# output to stdout. Triggers bell if no matches are found.
+# Returns: number of matches found
+##
+;proc Console:expand {w type} {
+ set exp "\[^\\]\[ \t\n\r\[\{\"\$]"
+ set tmp [$w search -back -regexp $exp insert-1c limit-1c]
+ if [string compare {} $tmp] {append tmp +2c} else {set tmp limit}
+ if [$w compare $tmp >= insert] return
+ set str [$w get $tmp insert]
+ switch -glob $type {
+ pa* { set res [ConsoleExpandPathname $str] }
+ pr* { set res [ConsoleExpandProcname $str] }
+ v* { set res [ConsoleExpandVariable $str] }
+ default {set res {}}
+ }
+ set len [llength $res]
+ if $len {
+ $w delete $tmp insert
+ $w insert $tmp [lindex $res 0]
+ if {$len > 1} {
+ upvar \#0 [winfo parent $w] data
+ if {$data(-showmultiple) && ![string comp [lindex $res 0] $str]} {
+ puts stdout [lreplace $res 0 0]
+ }
+ }
+ } else bell
+ return [incr len -1]
+}
+
+## ConsoleExpandPathname - expand a file pathname based on $str
+## This is based on UNIX file name conventions
+# ARGS: str - partial file pathname to expand
+# Calls: ConsoleExpandBestMatch
+# Returns: list containing longest unique match followed by all the
+# possible further matches
+##
+;proc ConsoleExpandPathname str {
+ set pwd [ConsoleEvalAttached pwd]
+ if [catch {ConsoleEvalAttached [list cd [file dirname $str]]} err] {
+ return -code error $err
+ }
+ if [catch {lsort [ConsoleEvalAttached glob [file tail $str]*]} m] {
+ set match {}
+ } else {
+ if {[llength $m] > 1} {
+ set tmp [ConsoleExpandBestMatch $m [file tail $str]]
+ if [string match ?*/* $str] {
+ set tmp [file dirname $str]/$tmp
+ } elseif {[string match /* $str]} {
+ set tmp /$tmp
+ }
+ regsub -all { } $tmp {\\ } tmp
+ set match [linsert $m 0 $tmp]
+ } else {
+ ## This may look goofy, but it handles spaces in path names
+ eval append match $m
+ if [file isdir $match] {append match /}
+ if [string match ?*/* $str] {
+ set match [file dirname $str]/$match
+ } elseif {[string match /* $str]} {
+ set match /$match
+ }
+ regsub -all { } $match {\\ } match
+ ## Why is this one needed and the ones below aren't!!
+ set match [list $match]
+ }
+ }
+ ConsoleEvalAttached [list cd $pwd]
+ return $match
+}
+
+## ConsoleExpandProcname - expand a tcl proc name based on $str
+# ARGS: str - partial proc name to expand
+# Calls: ConsoleExpandBestMatch
+# Returns: list containing longest unique match followed by all the
+# possible further matches
+##
+;proc ConsoleExpandProcname str {
+ set match [ConsoleEvalAttached info commands $str*]
+ if {[llength $match] > 1} {
+ regsub -all { } [ConsoleExpandBestMatch $match $str] {\\ } str
+ set match [linsert $match 0 $str]
+ } else {
+ regsub -all { } $match {\\ } match
+ }
+ return $match
+}
+
+## ConsoleExpandVariable - expand a tcl variable name based on $str
+# ARGS: str - partial tcl var name to expand
+# Calls: ConsoleExpandBestMatch
+# Returns: list containing longest unique match followed by all the
+# possible further matches
+##
+;proc ConsoleExpandVariable str {
+ if [regexp {([^\(]*)\((.*)} $str junk ary str] {
+ ## Looks like they're trying to expand an array.
+ set match [ConsoleEvalAttached array names $ary $str*]
+ if {[llength $match] > 1} {
+ set vars $ary\([ConsoleExpandBestMatch $match $str]
+ foreach var $match {lappend vars $ary\($var\)}
+ return $vars
+ } else {set match $ary\($match\)}
+ ## Space transformation avoided for array names.
+ } else {
+ set match [ConsoleEvalAttached info vars $str*]
+ if {[llength $match] > 1} {
+ regsub -all { } [ConsoleExpandBestMatch $match $str] {\\ } str
+ set match [linsert $match 0 $str]
+ } else {
+ regsub -all { } $match {\\ } match
+ }
+ }
+ return $match
+}
+
+## ConsoleExpandBestMatch2 - finds the best unique match in a list of names
+## Improves upon the speed of the below proc only when $l is small
+## or $e is {}. $e is extra for compatibility with proc below.
+# ARGS: l - list to find best unique match in
+# Returns: longest unique match in the list
+##
+;proc ConsoleExpandBestMatch2 {l {e {}}} {
+ set s [lindex $l 0]
+ if {[llength $l]>1} {
+ set i [expr [string length $s]-1]
+ foreach l $l {
+ while {$i>=0 && [string first $s $l]} {
+ set s [string range $s 0 [incr i -1]]
+ }
+ }
+ }
+ return $s
+}
+
+## ConsoleExpandBestMatch - finds the best unique match in a list of names
+## The extra $e in this argument allows us to limit the innermost loop a
+## little further. This improves speed as $l becomes large or $e becomes long.
+# ARGS: l - list to find best unique match in
+# e - currently best known unique match
+# Returns: longest unique match in the list
+##
+;proc ConsoleExpandBestMatch {l {e {}}} {
+ set ec [lindex $l 0]
+ if {[llength $l]>1} {
+ set e [string length $e]; incr e -1
+ set ei [string length $ec]; incr ei -1
+ foreach l $l {
+ while {$ei>=$e && [string first $ec $l]} {
+ set ec [string range $ec 0 [incr ei -1]]
+ }
+ }
+ }
+ return $ec
+}
+
+
+## ConsoleResource - re'source's this script into current console
+## Meant primarily for my development of this program. It follows
+## links until the ultimate source is found.
+##
+set Console(SCRIPT) [info script]
+if !$Console(WWW) {
+ while {[string match link [file type $Console(SCRIPT)]]} {
+ set link [file readlink $Console(SCRIPT)]
+ if [string match relative [file pathtype $link]] {
+ set Console(SCRIPT) [file join [file dirname $Console(SCRIPT)] $link]
+ } else {
+ set Console(SCRIPT) $link
+ }
+ }
+ catch {unset link}
+ if [string match relative [file pathtype $Console(SCRIPT)]] {
+ set Console(SCRIPT) [file join [pwd] $Console(SCRIPT)]
+ }
+}
+
+;proc Console:resource {} {
+ global Console
+ uplevel \#0 [list source $Console(SCRIPT)]
+}
+
+catch {destroy .c}
+console .c
+wm iconify .c
+wm title .c "Tcl Plugin Console"
+wm geometry .c +10+10
generated by cgit v0.12 at 2024-07-05 05:44:56 (GMT)