diff options
Diffstat (limited to 'library')
| -rw-r--r-- | library/console.tcl | 691 |
1 files changed, 566 insertions, 125 deletions
diff --git a/library/console.tcl b/library/console.tcl index 170d898..6375648 100644 --- a/library/console.tcl +++ b/library/console.tcl @@ -4,7 +4,7 @@ # can be used by non-unix systems that do not have built-in support # for shells. # -# RCS: @(#) $Id: console.tcl,v 1.12 2001/08/01 16:21:11 dgp Exp $ +# RCS: @(#) $Id: console.tcl,v 1.13 2001/10/09 23:11:02 hobbs Exp $ # # Copyright (c) 1995-1997 Sun Microsystems, Inc. # Copyright (c) 1998-2000 Ajuba Solutions. @@ -14,6 +14,27 @@ # # TODO: history - remember partially written command +package require msgcat + +namespace eval ::tk::console { + variable blinkTime 500 ; # msecs to blink braced range for + variable blinkRange 1 ; # enable blinking of the entire braced range + variable magicKeys 1 ; # enable brace matching and proc/var recognition + variable maxLines 600 ; # maximum # of lines buffered in console + variable showMatches 1 ; # show multiple expand matches + + variable inPlugin [info exists embed_args] + variable defaultPrompt ; # default prompt if tcl_prompt1 isn't used + + if {$inPlugin} { + set defaultPrompt {subst "[history nextid] % "} + } else { + set defaultPrompt {subst "([file tail [pwd]]) [history nextid] % "} + } +} + +# simple compat function for tkcon code added for this console +interp alias {} EvalAttached {} consoleinterp eval # ::tk::ConsoleInit -- # This procedure constructs and configures the console windows. @@ -34,7 +55,7 @@ proc ::tk::ConsoleInit {} { set mod "Cmd" } - menu .menubar + if {[catch {menu .menubar} err]} { bgerror "INIT: $err" } .menubar add cascade -label File -menu .menubar.file -underline 0 .menubar add cascade -label Edit -menu .menubar.edit -underline 0 @@ -42,7 +63,9 @@ proc ::tk::ConsoleInit {} { .menubar.file add command -label [::msgcat::mc "Source..."] \ -underline 0 -command tk::ConsoleSource .menubar.file add command -label [::msgcat::mc "Hide Console"] \ - -underline 0 -command {wm withdraw .} + -underline 0 -command {wm withdraw .} + .menubar.file add command -label [::msgcat::mc "Clear Console"] \ + -underline 0 -command {.console delete 1.0 "promptEnd linestart"} if {[string compare $tcl_platform(platform) "macintosh"]} { .menubar.file add command -label [::msgcat::mc "Exit"] \ -underline 1 -command exit @@ -74,33 +97,39 @@ proc ::tk::ConsoleInit {} { . configure -menu .menubar - text .console -yscrollcommand ".sb set" -setgrid true - scrollbar .sb -command ".console yview" + set con [text .console -yscrollcommand [list .sb set] -setgrid true] + scrollbar .sb -command [list $con yview] pack .sb -side right -fill both - pack .console -fill both -expand 1 -side left + pack $con -fill both -expand 1 -side left switch -exact $tcl_platform(platform) { "macintosh" { - .console configure -font {Monaco 9 normal} -highlightthickness 0 + $con configure -font {Monaco 9 normal} -highlightthickness 0 } "windows" { - .console configure -font systemfixed + $con configure -font systemfixed } } - ConsoleBind .console + ConsoleBind $con + + $con tag configure stderr -foreground red + $con tag configure stdin -foreground blue + $con tag configure prompt -foreground \#8F4433 + $con tag configure proc -foreground \#008800 + $con tag configure var -background \#FFC0D0 + $con tag raise sel + $con tag configure blink -background \#FFFF00 + $con tag configure find -background \#FFFF00 - .console tag configure stderr -foreground red - .console tag configure stdin -foreground blue + focus $con - focus .console - wm protocol . WM_DELETE_WINDOW { wm withdraw . } wm title . [::msgcat::mc "Console"] flush stdout - .console mark set output [.console index "end - 1 char"] - tk::TextSetCursor .console end - .console mark set promptEnd insert - .console mark gravity promptEnd left + $con mark set output [$con index "end - 1 char"] + tk::TextSetCursor $con end + $con mark set promptEnd insert + $con mark gravity promptEnd left } # ::tk::ConsoleSource -- @@ -112,10 +141,10 @@ proc ::tk::ConsoleInit {} { proc ::tk::ConsoleSource {} { set filename [tk_getOpenFile -defaultextension .tcl -parent . \ - -title [::msgcat::mc "Select a file to source"] \ - -filetypes [list \ - [list [::msgcat::mc "Tcl Scripts"] .tcl] \ - [list [::msgcat::mc "All Files"] *]]] + -title [::msgcat::mc "Select a file to source"] \ + -filetypes [list \ + [list [::msgcat::mc "Tcl Scripts"] .tcl] \ + [list [::msgcat::mc "All Files"] *]]] if {[string compare $filename ""]} { set cmd [list source $filename] if {[catch {consoleinterp eval $cmd} result]} { @@ -173,7 +202,7 @@ proc ::tk::ConsoleInvoke {args} { set ::tk::HistNum 1 proc ::tk::ConsoleHistory {cmd} { variable HistNum - + switch $cmd { prev { incr HistNum -1 @@ -220,17 +249,18 @@ proc ::tk::ConsoleHistory {cmd} { # partial - Flag to specify which prompt to print. proc ::tk::ConsolePrompt {{partial normal}} { + set w .console if {[string equal $partial "normal"]} { - set temp [.console index "end - 1 char"] - .console mark set output end + set temp [$w index "end - 1 char"] + $w mark set output end if {[consoleinterp eval "info exists tcl_prompt1"]} { consoleinterp eval "eval \[set tcl_prompt1\]" } else { - puts -nonewline "% " + puts -nonewline [EvalAttached $::tk::console::defaultPrompt] } } else { - set temp [.console index output] - .console mark set output end + set temp [$w index output] + $w mark set output end if {[consoleinterp eval "info exists tcl_prompt2"]} { consoleinterp eval "eval \[set tcl_prompt2\]" } else { @@ -238,10 +268,12 @@ proc ::tk::ConsolePrompt {{partial normal}} { } } flush stdout - .console mark set output $temp - ::tk::TextSetCursor .console end - .console mark set promptEnd insert - .console mark gravity promptEnd left + $w mark set output $temp + ::tk::TextSetCursor $w end + $w mark set promptEnd insert + $w mark gravity promptEnd left + ::tk::console::ConstrainBuffer $w $::tk::console::maxLines + $w see end } # ::tk::ConsoleBind -- @@ -252,127 +284,166 @@ proc ::tk::ConsolePrompt {{partial normal}} { # Arguments: # None. -proc ::tk::ConsoleBind {win} { - bindtags $win "$win Text . all" +proc ::tk::ConsoleBind {w} { + bindtags $w [list $w Console PostConsole [winfo toplevel $w] all] + + ## Get all Text bindings into Console + foreach ev [bind Text] { bind Console $ev [bind Text $ev] } + ## We really didn't want the newline insertion + bind Console <Control-Key-o> {} # Ignore all Alt, Meta, and Control keypresses unless explicitly bound. # Otherwise, if a widget binding for one of these is defined, the - # <KeyPress> class binding will also fire and insert the character, - # which is wrong. Ditto for <Escape>. - - bind $win <Alt-KeyPress> {# nothing } - bind $win <Meta-KeyPress> {# nothing} - bind $win <Control-KeyPress> {# nothing} - bind $win <Escape> {# nothing} - bind $win <KP_Enter> {# nothing} - bind $win <Tab> { + bind Console <Alt-KeyPress> {# nothing } + bind Console <Meta-KeyPress> {# nothing} + bind Console <Control-KeyPress> {# nothing} + + foreach {ev key} { + <<Console_Prev>> <Key-Up> + <<Console_Next>> <Key-Down> + <<Console_NextImmediate>> <Control-Key-n> + <<Console_PrevImmediate>> <Control-Key-p> + <<Console_PrevSearch>> <Control-Key-r> + <<Console_NextSearch>> <Control-Key-s> + + <<Console_Expand>> <Key-Escape> + <<Console_ExpandFile>> <Control-Shift-Key-F> + <<Console_ExpandProc>> <Control-Shift-Key-P> + <<Console_ExpandVar>> <Control-Shift-Key-V> + <<Console_Tab>> <Control-Key-i> + <<Console_Tab>> <Meta-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> + } { + event add $ev $key + bind Console $key {} + } + + bind Console <Tab> { tk::ConsoleInsert %W \t focus %W break } - bind $win <Return> { + bind Console <<Console_Expand>> { + if {[%W compare insert > promptEnd]} {::tk::console::Expand %W} + } + bind Console <<Console_ExpandFile>> { + if {[%W compare insert > promptEnd]} {::tk::console::Expand %W path} + } + bind Console <<Console_ExpandProc>> { + if {[%W compare insert > promptEnd]} {::tk::console::Expand %W proc} + } + bind Console <<Console_ExpandVar>> { + if {[%W compare insert > promptEnd]} {::tk::console::Expand %W var} + } + bind Console <<Console_Eval>> { %W mark set insert {end - 1c} tk::ConsoleInsert %W "\n" tk::ConsoleInvoke break } - bind $win <Delete> { - if {[string compare [%W tag nextrange sel 1.0 end] ""]} { - %W tag remove sel sel.first promptEnd - } elseif {[%W compare insert < promptEnd]} { - break + bind Console <Delete> { + if {[string compare {} [%W tag nextrange sel 1.0 end]] \ + && [%W compare sel.first >= promptEnd]} { + %W delete sel.first sel.last + } elseif {[%W compare insert >= promptEnd]} { + %W delete insert + %W see insert } } - bind $win <BackSpace> { - if {[string compare [%W tag nextrange sel 1.0 end] ""]} { - %W tag remove sel sel.first promptEnd - } elseif {[%W compare insert <= promptEnd]} { - break + bind Console <BackSpace> { + if {[string compare {} [%W tag nextrange sel 1.0 end]] \ + && [%W compare sel.first >= promptEnd]} { + %W delete sel.first sel.last + } elseif {[%W compare insert != 1.0] && \ + [%W compare insert > promptEnd]} { + %W delete insert-1c + %W see insert } } - foreach left {Control-a Home} { - bind $win <$left> { - if {[%W compare insert < promptEnd]} { - tk::TextSetCursor %W {insert linestart} - } else { - tk::TextSetCursor %W promptEnd - } - break + bind Console <Control-h> [bind Console <BackSpace>] + + bind Console <Home> { + if {[%W compare insert < promptEnd]} { + tk::TextSetCursor %W {insert linestart} + } else { + tk::TextSetCursor %W promptEnd } } - foreach right {Control-e End} { - bind $win <$right> { - tk::TextSetCursor %W {insert lineend} - break - } + bind Console <Control-a> [bind Console <Home>] + bind Console <End> { + tk::TextSetCursor %W {insert lineend} } - bind $win <Control-d> { - if {[%W compare insert < promptEnd]} { - break - } + bind Console <Control-e> [bind Console <End>] + bind Console <Control-d> { + if {[%W compare insert < promptEnd]} break + %W delete insert } - bind $win <Control-k> { - if {[%W compare insert < promptEnd]} { - %W mark set insert promptEnd + bind Console <<Console_KillLine>> { + if {[%W compare insert < promptEnd]} break + if {[%W compare insert == {insert lineend}]} { + %W delete insert + } else { + %W delete insert {insert lineend} } } - bind $win <Control-t> { - if {[%W compare insert < promptEnd]} { - break - } + bind Console <<Console_Transpose>> { + ## Transpose current and previous chars + if {[%W compare insert > promptEnd]} { ::tk::TextTranspose %W } } - bind $win <Meta-d> { - if {[%W compare insert < promptEnd]} { - break + bind Console <<Console_Clear>> { + ## Clear console display + %W delete 1.0 "promptEnd linestart" + } + bind Console <<Console_ClearLine>> { + ## Clear command line (Unix shell staple) + %W delete promptEnd end + } + bind Console <Meta-d> { + if {[%W compare insert >= promptEnd]} { + %W delete insert {insert wordend} } } - bind $win <Meta-BackSpace> { - if {[%W compare insert <= promptEnd]} { - break + bind Console <Meta-BackSpace> { + if {[%W compare {insert -1c wordstart} >= promptEnd]} { + %W delete {insert -1c wordstart} insert } } - bind $win <Control-h> { - if {[%W compare insert <= promptEnd]} { - break + bind Console <Meta-d> { + if {[%W compare insert >= promptEnd]} { + %W delete insert {insert wordend} } } - foreach prev {Control-p Up} { - bind $win <$prev> { - tk::ConsoleHistory prev - break + bind Console <Meta-BackSpace> { + if {[%W compare {insert -1c wordstart} >= promptEnd]} { + %W delete {insert -1c wordstart} insert } } - foreach prev {Control-n Down} { - bind $win <$prev> { - tk::ConsoleHistory next - break + bind Console <Meta-Delete> { + if {[%W compare insert >= promptEnd]} { + %W delete insert {insert wordend} } } - bind $win <Insert> { - catch {tk::ConsoleInsert %W [::tk::GetSelection %W PRIMARY]} - break + bind Console <<Console_Prev>> { + tk::ConsoleHistory prev } - bind $win <KeyPress> { - tk::ConsoleInsert %W %A - break + bind Console <<Console_Next>> { + tk::ConsoleHistory next } - foreach left {Control-b Left} { - bind $win <$left> { - if {[%W compare insert == promptEnd]} { - break - } - tk::TextSetCursor %W insert-1c - break - } + bind Console <Insert> { + catch {tk::ConsoleInsert %W [::tk::GetSelection %W PRIMARY]} } - foreach right {Control-f Right} { - bind $win <$right> { - tk::TextSetCursor %W insert+1c - break - } + bind Console <KeyPress> { + tk::ConsoleInsert %W %A } - bind $win <F9> { + bind Console <F9> { eval destroy [winfo child .] if {[string equal $tcl_platform(platform) "macintosh"]} { source -rsrc Console @@ -380,22 +451,20 @@ proc ::tk::ConsoleBind {win} { source [file join $tk_library console.tcl] } } - bind $win <<Cut>> { + bind Console <<Cut>> { # Same as the copy event if {![catch {set data [%W get sel.first sel.last]}]} { clipboard clear -displayof %W clipboard append -displayof %W $data } - break } - bind $win <<Copy>> { + bind Console <<Copy>> { if {![catch {set data [%W get sel.first sel.last]}]} { clipboard clear -displayof %W clipboard append -displayof %W $data } - break } - bind $win <<Paste>> { + bind Console <<Paste>> { catch { set clip [::tk::GetSelection %W CLIPBOARD] set list [split $clip \n\r] @@ -407,6 +476,36 @@ proc ::tk::ConsoleBind {win} { tk::ConsoleInsert %W $x } } + } + + ## + ## Bindings for doing special things based on certain keys + ## + bind PostConsole <Key-parenright> { + if {[string compare \\ [%W get insert-2c]]} { + ::tk::console::MatchPair %W \( \) promptEnd + } + } + bind PostConsole <Key-bracketright> { + if {[string compare \\ [%W get insert-2c]]} { + ::tk::console::MatchPair %W \[ \] promptEnd + } + } + bind PostConsole <Key-braceright> { + if {[string compare \\ [%W get insert-2c]]} { + ::tk::console::MatchPair %W \{ \} promptEnd + } + } + bind PostConsole <Key-quotedbl> { + if {[string compare \\ [%W get insert-2c]]} { + ::tk::console::MatchQuote %W promptEnd + } + } + + bind PostConsole <KeyPress> { + if {"%A" != ""} { + ::tk::console::TagProc %W + } break } } @@ -433,7 +532,7 @@ proc ::tk::ConsoleInsert {w s} { } } if {[$w compare insert < promptEnd]} { - $w mark set insert end + $w mark set insert end } $w insert insert $s {input stdin} $w see insert @@ -450,6 +549,7 @@ proc ::tk::ConsoleInsert {w s} { proc ::tk::ConsoleOutput {dest string} { .console insert output $string $dest + ::tk::console::ConstrainBuffer $w $::tk::console::maxLines .console see insert } @@ -474,14 +574,355 @@ proc ::tk::ConsoleExit {} { # None. proc ::tk::ConsoleAbout {} { - global tk_patchLevel tk_messageBox -type ok -message "[::msgcat::mc {Tcl for Windows}] -Copyright \251 2000 Ajuba Solutions -Tcl [info patchlevel] -Tk $tk_patchLevel" +Tcl $::tcl_patchLevel +Tk $::tk_patchLevel" } -# now initialize the console +# ::tk::console::TagProc -- +# +# Tags a procedure in the console if it's recognized +# This procedure is not perfect. However, making it perfect wastes +# too much CPU time... +# +# Arguments: +# w - console text widget + +proc ::tk::console::TagProc w { + if {!$::tk::console::magicKeys} { return } + set exp "\[^\\\\\]\[\[ \t\n\r\;{}\"\$\]" + set i [$w search -backwards -regexp $exp insert-1c promptEnd-1c] + if {$i == ""} {set i promptEnd} else {append i +2c} + regsub -all "\[\[\\\\\\?\\*\]" [$w get $i "insert-1c wordend"] {\\\0} c + if {[llength [EvalAttached [list info commands $c]]]} { + $w tag add proc $i "insert-1c wordend" + } else { + $w tag remove proc $i "insert-1c wordend" + } + if {[llength [EvalAttached [list info vars $c]]]} { + $w tag add var $i "insert-1c wordend" + } else { + $w tag remove var $i "insert-1c wordend" + } +} + +# ::tk::console::MatchPair -- +# +# 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. +# +# Arguments: +# w - console text widget +# c1 - first char of pair +# c2 - second char of pair +# +# Calls: ::tk::console::Blink + +proc ::tk::console::MatchPair {w c1 c2 {lim 1.0}} { + if {!$::tk::console::magicKeys} { return } + if {[string compare {} [set ix [$w search -back $c1 insert $lim]]]} { + while { + [string match {\\} [$w get $ix-1c]] && + [string compare {} [set ix [$w search -back $c1 $ix-1c $lim]]] + } {} + set i1 insert-1c + while {[string compare {} $ix]} { + set i0 $ix + set j 0 + while {[string compare {} [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 compare {} \ + [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 {$::tk::console::blinkRange} { + Blink $w $ix [$w index insert] + } else { + Blink $w $ix $ix+1c [$w index insert-1c] [$w index insert] + } +} + +# ::tk::console::MatchQuote -- +# +# 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'. +# +# Arguments: +# w - console text widget +# +# Calls: ::tk::console::Blink + +proc ::tk::console::MatchQuote {w {lim 1.0}} { + if {!$::tk::console::magicKeys} { return } + set i insert-1c + set j 0 + while {[string compare [set i [$w search -back \" $i $lim]] {}]} { + if {[string match {\\} [$w get $i-1c]]} continue + if {!$j} {set i0 $i} + incr j + } + if {$j&1} { + if {$::tk::console::blinkRange} { + Blink $w $i0 [$w index insert] + } else { + Blink $w $i0 $i0+1c [$w index insert-1c] [$w index insert] + } + } else { + Blink $w [$w index insert-1c] [$w index insert] + } +} + +# ::tk::console::Blink -- +# +# Blinks between n index pairs for a specified duration. +# +# Arguments: +# w - console text widget +# i1 - start index to blink region +# i2 - end index of blink region +# dur - duration in usecs to blink for +# +# Outputs: +# blinks selected characters in $w + +proc ::tk::console::Blink {w args} { + eval [list $w tag add blink] $args + after $::tk::console::blinkTime [list $w] tag remove blink $args +} + +# ::tk::console::ConstrainBuffer -- +# +# This limits the amount of data in the text widget +# Called by Prompt and ConsoleOutput +# +# Arguments: +# w - console text widget +# size - # of lines to constrain to +# +# Outputs: +# may delete data in console widget + +proc ::tk::console::ConstrainBuffer {w size} { + if {[$w index end] > $size} { + $w delete 1.0 [expr {int([$w index end])-$size}].0 + } +} +# ::tk::console::Expand -- +# +# Arguments: +# ARGS: w - text widget in which to expand str +# type - type of expansion (path / proc / variable) +# +# Calls: ::tk::console::Expand(Pathname|Procname|Variable) +# +# Outputs: The string to match is expanded to the longest possible match. +# If ::tk::console::showMatches is non-zero and the 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 ::tk::console::Expand {w {type ""}} { + set exp "\[^\\\\\]\[\[ \t\n\r\\\{\"\\\\\$\]" + set tmp [$w search -backwards -regexp $exp insert-1c promptEnd-1c] + if {$tmp == ""} {set tmp promptEnd} else {append tmp +2c} + if {[$w compare $tmp >= insert]} { return } + set str [$w get $tmp insert] + switch -glob $type { + path* { set res [ExpandPathname $str] } + proc* { set res [ExpandProcname $str] } + var* { set res [ExpandVariable $str] } + default { + set res {} + foreach t {Pathname Procname Variable} { + if {![catch {Expand$t $str} res] && ($res != "")} { break } + } + } + } + set len [llength $res] + if {$len} { + set repl [lindex $res 0] + $w delete $tmp insert + $w insert $tmp $repl {input stdin} + if {($len > 1) && $::tk::console::showMatches \ + && [string equal $repl $str]} { + puts stdout [lsort [lreplace $res 0 0]] + } + } else { bell } + return [incr len -1] +} + +# ::tk::console::ExpandPathname -- +# +# Expand a file pathname based on $str +# This is based on UNIX file name conventions +# +# Arguments: +# str - partial file pathname to expand +# +# Calls: ::tk::console::ExpandBestMatch +# +# Returns: list containing longest unique match followed by all the +# possible further matches + +proc ::tk::console::ExpandPathname str { + set pwd [EvalAttached pwd] + if {[catch {EvalAttached [list cd [file dirname $str]]} err]} { + return -code error $err + } + set dir [file tail $str] + ## Check to see if it was known to be a directory and keep the trailing + ## slash if so (file tail cuts it off) + if {[string match */ $str]} { append dir / } + if {[catch {lsort [EvalAttached [list glob $dir*]]} m]} { + set match {} + } else { + if {[llength $m] > 1} { + global tcl_platform + if {[string match windows $tcl_platform(platform)]} { + ## Windows is screwy because it's case insensitive + set tmp [ExpandBestMatch [string tolower $m] \ + [string tolower $dir]] + ## Don't change case if we haven't changed the word + if {[string length $dir]==[string length $tmp]} { + set tmp $dir + } + } else { + set tmp [ExpandBestMatch $m $dir] + } + 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] + } + } + EvalAttached [list cd $pwd] + return $match +} + +# ::tk::console::ExpandProcname -- +# +# Expand a tcl proc name based on $str +# +# Arguments: +# str - partial proc name to expand +# +# Calls: ::tk::console::ExpandBestMatch +# +# Returns: list containing longest unique match followed by all the +# possible further matches + +proc ::tk::console::ExpandProcname str { + set match [EvalAttached [list info commands $str*]] + if {[llength $match] == 0} { + set ns [EvalAttached \ + "namespace children \[namespace current\] [list $str*]"] + if {[llength $ns]==1} { + set match [EvalAttached [list info commands ${ns}::*]] + } else { + set match $ns + } + } + if {[llength $match] > 1} { + regsub -all { } [ExpandBestMatch $match $str] {\\ } str + set match [linsert $match 0 $str] + } else { + regsub -all { } $match {\\ } match + } + return $match +} + +# ::tk::console::ExpandVariable -- +# +# Expand a tcl variable name based on $str +# +# Arguments: +# str - partial tcl var name to expand +# +# Calls: ::tk::console::ExpandBestMatch +# +# Returns: list containing longest unique match followed by all the +# possible further matches + +proc ::tk::console::ExpandVariable str { + if {[regexp {([^\(]*)\((.*)} $str junk ary str]} { + ## Looks like they're trying to expand an array. + set match [EvalAttached [list array names $ary $str*]] + if {[llength $match] > 1} { + set vars $ary\([ExpandBestMatch $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 [EvalAttached [list info vars $str*]] + if {[llength $match] > 1} { + regsub -all { } [ExpandBestMatch $match $str] {\\ } str + set match [linsert $match 0 $str] + } else { + regsub -all { } $match {\\ } match + } + } + return $match +} + +# ::tk::console::ExpandBestMatch -- +# +# 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. +# +# Arguments: +# l - list to find best unique match in +# e - currently best known unique match +# +# Returns: longest unique match in the list + +proc ::tk::console::ExpandBestMatch {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 +} + +# now initialize the console ::tk::ConsoleInit |