diff options
Diffstat (limited to 'tk/library/console.tcl')
-rw-r--r-- | tk/library/console.tcl | 841 |
1 files changed, 645 insertions, 196 deletions
diff --git a/tk/library/console.tcl b/tk/library/console.tcl index de884118c8e..cc5e3adb8bf 100644 --- a/tk/library/console.tcl +++ b/tk/library/console.tcl @@ -6,8 +6,8 @@ # # RCS: @(#) $Id$ # -# Copyright (c) 1998-1999 Scriptics Corp. # Copyright (c) 1995-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-2000 Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -15,112 +15,152 @@ # TODO: history - remember partially written command -# tkConsoleInit -- +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. # # Arguments: # None. -proc tkConsoleInit {} { +proc ::tk::ConsoleInit {} { global tcl_platform if {![consoleinterp eval {set tcl_interactive}]} { wm withdraw . } - if {[string compare $tcl_platform(platform) "macintosh"]} { - set mod "Ctrl" - } else { + if {[string equal $tcl_platform(platform) "macintosh"] + || [string equal [tk windowingsystem] "aqua"]} { set mod "Cmd" + } else { + set mod "Ctrl" } - 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 menu .menubar.file -tearoff 0 - .menubar.file add command -label "Source..." -underline 0 \ - -command tkConsoleSource - .menubar.file add command -label "Hide Console" -underline 0 \ - -command {wm withdraw .} - if {[string compare $tcl_platform(platform) "macintosh"]} { - .menubar.file add command -label "Exit" -underline 1 -command exit + .menubar.file add command -label [mc "Source..."] \ + -underline 0 -command tk::ConsoleSource + .menubar.file add command -label [mc "Hide Console"] \ + -underline 0 -command {wm withdraw .} + .menubar.file add command -label [mc "Clear Console"] \ + -underline 0 -command {.console delete 1.0 "promptEnd linestart"} + if {[string equal $tcl_platform(platform) "macintosh"] + || [string equal [tk windowingsystem] "aqua"]} { + .menubar.file add command -label [mc "Quit"] \ + -command exit -accel Cmd-Q } else { - .menubar.file add command -label "Quit" -command exit -accel Cmd-Q + .menubar.file add command -label [mc "Exit"] \ + -underline 1 -command exit } menu .menubar.edit -tearoff 0 - .menubar.edit add command -label "Cut" -underline 2 \ + .menubar.edit add command -label [mc "Cut"] -underline 2 \ -command { event generate .console <<Cut>> } -accel "$mod+X" - .menubar.edit add command -label "Copy" -underline 0 \ + .menubar.edit add command -label [mc "Copy"] -underline 0 \ -command { event generate .console <<Copy>> } -accel "$mod+C" - .menubar.edit add command -label "Paste" -underline 1 \ + .menubar.edit add command -label [mc "Paste"] -underline 1 \ -command { event generate .console <<Paste>> } -accel "$mod+V" if {[string compare $tcl_platform(platform) "windows"]} { - .menubar.edit add command -label "Clear" -underline 2 \ + .menubar.edit add command -label [mc "Clear"] -underline 2 \ -command { event generate .console <<Clear>> } } else { - .menubar.edit add command -label "Delete" -underline 0 \ + .menubar.edit add command -label [mc "Delete"] -underline 0 \ -command { event generate .console <<Clear>> } -accel "Del" - + .menubar add cascade -label Help -menu .menubar.help -underline 0 menu .menubar.help -tearoff 0 - .menubar.help add command -label "About..." -underline 0 \ - -command tkConsoleAbout + .menubar.help add command -label [mc "About..."] \ + -underline 0 -command tk::ConsoleAbout } . 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 + } + "unix" { + if {[string equal [tk windowingsystem] "aqua"]} { + $con configure -font {Monaco 9 normal} -highlightthickness 0 + } } } - tkConsoleBind .console + ConsoleBind $con - .console tag configure stderr -foreground red - .console tag configure stdin -foreground blue + $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 + + focus $con - focus .console - wm protocol . WM_DELETE_WINDOW { wm withdraw . } - wm title . "Console" + wm title . [mc "Console"] flush stdout - .console mark set output [.console index "end - 1 char"] - tkTextSetCursor .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 } -# tkConsoleSource -- +# ::tk::ConsoleSource -- # # Prompts the user for a file to source in the main interpreter. # # Arguments: # None. -proc tkConsoleSource {} { +proc ::tk::ConsoleSource {} { set filename [tk_getOpenFile -defaultextension .tcl -parent . \ - -title "Select a file to source" \ - -filetypes {{"Tcl Scripts" .tcl} {"All Files" *}}] + -title [mc "Select a file to source"] \ + -filetypes [list \ + [list [mc "Tcl Scripts"] .tcl] \ + [list [mc "All Files"] *]]] if {[string compare $filename ""]} { set cmd [list source $filename] if {[catch {consoleinterp eval $cmd} result]} { - tkConsoleOutput stderr "$result\n" + ConsoleOutput stderr "$result\n" } } } -# tkConsoleInvoke -- +# ::tk::ConsoleInvoke -- # Processes the command line input. If the command is complete it # is evaled in the main interpreter. Otherwise, the continuation # prompt is added and more input may be added. @@ -128,7 +168,7 @@ proc tkConsoleSource {} { # Arguments: # None. -proc tkConsoleInvoke {args} { +proc ::tk::ConsoleInvoke {args} { set ranges [.console tag ranges input] set cmd "" if {[llength $ranges]} { @@ -141,7 +181,7 @@ proc tkConsoleInvoke {args} { } } if {[string equal $cmd ""]} { - tkConsolePrompt + ConsolePrompt } elseif {[info complete $cmd]} { .console mark set output end .console tag delete input @@ -149,51 +189,51 @@ proc tkConsoleInvoke {args} { if {[string compare $result ""]} { puts $result } - tkConsoleHistory reset - tkConsolePrompt + ConsoleHistory reset + ConsolePrompt } else { - tkConsolePrompt partial + ConsolePrompt partial } .console yview -pickplace insert } -# tkConsoleHistory -- +# ::tk::ConsoleHistory -- # This procedure implements command line history for the # console. In general is evals the history command in the -# main interpreter to obtain the history. The global variable -# histNum is used to store the current location in the history. +# main interpreter to obtain the history. The variable +# ::tk::HistNum is used to store the current location in the history. # # Arguments: # cmd - Which action to take: prev, next, reset. -set histNum 1 -proc tkConsoleHistory {cmd} { - global histNum - +set ::tk::HistNum 1 +proc ::tk::ConsoleHistory {cmd} { + variable HistNum + switch $cmd { prev { - incr histNum -1 - if {$histNum == 0} { + incr HistNum -1 + if {$HistNum == 0} { set cmd {history event [expr {[history nextid] -1}]} } else { - set cmd "history event $histNum" + set cmd "history event $HistNum" } if {[catch {consoleinterp eval $cmd} cmd]} { - incr histNum + incr HistNum return } .console delete promptEnd end .console insert promptEnd $cmd {input stdin} } next { - incr histNum - if {$histNum == 0} { + incr HistNum + if {$HistNum == 0} { set cmd {history event [expr {[history nextid] -1}]} - } elseif {$histNum > 0} { + } elseif {$HistNum > 0} { set cmd "" - set histNum 1 + set HistNum 1 } else { - set cmd "history event $histNum" + set cmd "history event $HistNum" } if {[string compare $cmd ""]} { catch {consoleinterp eval $cmd} cmd @@ -202,12 +242,12 @@ proc tkConsoleHistory {cmd} { .console insert promptEnd $cmd {input stdin} } reset { - set histNum 1 + set HistNum 1 } } } -# tkConsolePrompt -- +# ::tk::ConsolePrompt -- # This procedure draws the prompt. If tcl_prompt1 or tcl_prompt2 # exists in the main interpreter it will be called to generate the # prompt. Otherwise, a hard coded default prompt is printed. @@ -215,18 +255,19 @@ proc tkConsoleHistory {cmd} { # Arguments: # partial - Flag to specify which prompt to print. -proc tkConsolePrompt {{partial normal}} { +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 { @@ -234,13 +275,15 @@ proc tkConsolePrompt {{partial normal}} { } } flush stdout - .console mark set output $temp - tkTextSetCursor .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 } -# tkConsoleBind -- +# ::tk::ConsoleBind -- # This procedure first ensures that the default bindings for the Text # class have been defined. Then certain bindings are overridden for # the class. @@ -248,166 +291,231 @@ proc tkConsolePrompt {{partial normal}} { # Arguments: # None. -proc tkConsoleBind {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> {} + ## ...or any Control-v binding (would block <<Paste>>) + bind Console <Control-Key-v> {} + + # For the moment, transpose isn't enabled until the console + # gets and overhaul of how it handles input -- hobbs + bind Console <Control-Key-t> {} # 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> { - tkConsoleInsert %W \t - focus %W - break - } - bind $win <Return> { + + 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-Tab> + <<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 <<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} - tkConsoleInsert %W "\n" - tkConsoleInvoke + 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]} { - tkTextSetCursor %W {insert linestart} - } else { - tkTextSetCursor %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> { - tkTextSetCursor %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_Clear>> { + ## Clear console display + %W delete 1.0 "promptEnd linestart" } - bind $win <Meta-d> { - if {[%W compare insert < promptEnd]} { - break + 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> { - tkConsoleHistory 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> { - tkConsoleHistory next - break + bind Console <Meta-Delete> { + if {[%W compare insert >= promptEnd]} { + %W delete insert {insert wordend} } } - bind $win <Insert> { - catch {tkConsoleInsert %W [selection get -displayof %W]} - break + bind Console <<Console_Prev>> { + tk::ConsoleHistory prev } - bind $win <KeyPress> { - tkConsoleInsert %W %A - break + bind Console <<Console_Next>> { + tk::ConsoleHistory next } - foreach left {Control-b Left} { - bind $win <$left> { - if {[%W compare insert == promptEnd]} { - break - } - tkTextSetCursor %W insert-1c - break - } + bind Console <Insert> { + catch {tk::ConsoleInsert %W [::tk::GetSelection %W PRIMARY]} } - foreach right {Control-f Right} { - bind $win <$right> { - tkTextSetCursor %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 + if {[catch {source [file join $tk_library console.tcl]}]} {source -rsrc console} } else { 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 [selection get -displayof %W -selection CLIPBOARD] + set clip [::tk::GetSelection %W CLIPBOARD] set list [split $clip \n\r] - tkConsoleInsert %W [lindex $list 0] + tk::ConsoleInsert %W [lindex $list 0] foreach x [lrange $list 1 end] { %W mark set insert {end - 1c} - tkConsoleInsert %W "\n" - tkConsoleInvoke - tkConsoleInsert %W $x + tk::ConsoleInsert %W "\n" + tk::ConsoleInvoke + 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 } } -# tkConsoleInsert -- +# ::tk::ConsoleInsert -- # Insert a string into a text 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. Insertion @@ -417,7 +525,7 @@ proc tkConsoleBind {win} { # w - The text window in which to insert the string # s - The string to insert (usually just a single character) -proc tkConsoleInsert {w s} { +proc ::tk::ConsoleInsert {w s} { if {[string equal $s ""]} { return } @@ -429,13 +537,13 @@ proc tkConsoleInsert {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 } -# tkConsoleOutput -- +# ::tk::ConsoleOutput -- # # This routine is called directly by ConsolePutsCmd to cause a string # to be displayed in the console. @@ -444,12 +552,14 @@ proc tkConsoleInsert {w s} { # dest - The output tag to be used: either "stderr" or "stdout". # string - The string to be displayed. -proc tkConsoleOutput {dest string} { - .console insert output $string $dest - .console see insert +proc ::tk::ConsoleOutput {dest string} { + set w .console + $w insert output $string $dest + ::tk::console::ConstrainBuffer $w $::tk::console::maxLines + $w see insert } -# tkConsoleExit -- +# ::tk::ConsoleExit -- # # This routine is called by ConsoleEventProc when the main window of # the application is destroyed. Don't call exit - that probably already @@ -458,28 +568,367 @@ proc tkConsoleOutput {dest string} { # Arguments: # None. -proc tkConsoleExit {} { +proc ::tk::ConsoleExit {} { destroy . } -# tkConsoleAbout -- +# ::tk::ConsoleAbout -- # # This routine displays an About box to show Tcl/Tk version info. # # Arguments: # None. -proc tkConsoleAbout {} { - global tk_patchLevel - tk_messageBox -type ok -message "Tcl for Windows -Copyright \251 2000 Scriptics Corporation +proc ::tk::ConsoleAbout {} { + tk_messageBox -type ok -message "[mc {Tcl for Windows}] -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" + } +} -tkConsoleInit +# ::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 |