# console.tcl -- # # This code constructs the console window for an application. It # can be used by non-unix systems that do not have built-in support # for shells. # # RCS: @(#) $Id: console.tcl,v 1.22.2.5 2006/01/25 18:21:41 dgp Exp $ # # 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. # # TODO: history - remember partially written command 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 ::tk::ConsoleInit {} { global tcl_platform if {![consoleinterp eval {set tcl_interactive}]} { wm withdraw . } if {$tcl_platform(platform) eq "macintosh" || [tk windowingsystem] eq "aqua"} { set mod "Cmd" } else { set mod "Ctrl" } 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 [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 {$tcl_platform(platform) eq "macintosh" || [tk windowingsystem] eq "aqua"} { .menubar.file add command -label [mc "Quit"] \ -command exit -accel Cmd-Q } else { .menubar.file add command -label [mc "Exit"] \ -underline 1 -command exit } menu .menubar.edit -tearoff 0 .menubar.edit add command -label [mc "Cut"] -underline 2 \ -command { event generate .console <> } -accel "$mod+X" .menubar.edit add command -label [mc "Copy"] -underline 0 \ -command { event generate .console <> } -accel "$mod+C" .menubar.edit add command -label [mc "Paste"] -underline 1 \ -command { event generate .console <> } -accel "$mod+V" if {$tcl_platform(platform) ne "windows"} { .menubar.edit add command -label [mc "Clear"] -underline 2 \ -command { event generate .console <> } } else { .menubar.edit add command -label [mc "Delete"] -underline 0 \ -command { event generate .console <> } -accel "Del" .menubar add cascade -label Help -menu .menubar.help -underline 0 menu .menubar.help -tearoff 0 .menubar.help add command -label [mc "About..."] \ -underline 0 -command tk::ConsoleAbout } . configure -menu .menubar set con [text .console -yscrollcommand [list .sb set] -setgrid true] scrollbar .sb -command [list $con yview] pack .sb -side right -fill both pack $con -fill both -expand 1 -side left switch -exact $tcl_platform(platform) { "macintosh" { $con configure -font {Monaco 9 normal} -highlightthickness 0 } "windows" { $con configure -font systemfixed } "unix" { if {[tk windowingsystem] eq "aqua"} { $con configure -font {Monaco 9 normal} -highlightthickness 0 } } } 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 focus $con wm protocol . WM_DELETE_WINDOW { wm withdraw . } wm title . [mc "Console"] flush stdout $con mark set output [$con index "end - 1 char"] tk::TextSetCursor $con end $con mark set promptEnd insert $con mark gravity promptEnd left # A variant of ConsolePrompt to avoid a 'puts' call set w $con set temp [$w index "end - 1 char"] $w mark set output end if {![consoleinterp eval "info exists tcl_prompt1"]} { set string [EvalAttached $::tk::console::defaultPrompt] $w insert output $string stdout } $w mark set output $temp ::tk::TextSetCursor $w end $w mark set promptEnd insert $w mark gravity promptEnd left if {$tcl_platform(platform) eq "windows"} { # Subtle work-around to erase the '% ' that tclMain.c prints out after idle [subst -nocommand { if {[$con get 1.0 output] eq "% "} { $con delete 1.0 output } }] } } # ::tk::ConsoleSource -- # # Prompts the user for a file to source in the main interpreter. # # Arguments: # None. proc ::tk::ConsoleSource {} { set filename [tk_getOpenFile -defaultextension .tcl -parent . \ -title [mc "Select a file to source"] \ -filetypes [list \ [list [mc "Tcl Scripts"] .tcl] \ [list [mc "All Files"] *]]] if {$filename ne ""} { set cmd [list source $filename] if {[catch {consoleinterp eval $cmd} result]} { ConsoleOutput stderr "$result\n" } } } # ::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. # # Arguments: # None. proc ::tk::ConsoleInvoke {args} { set ranges [.console tag ranges input] set cmd "" if {[llength $ranges]} { set pos 0 while {[lindex $ranges $pos] ne ""} { set start [lindex $ranges $pos] set end [lindex $ranges [incr pos]] append cmd [.console get $start $end] incr pos } } if {$cmd eq ""} { ConsolePrompt } elseif {[info complete $cmd]} { .console mark set output end .console tag delete input set result [consoleinterp record $cmd] if {$result ne ""} { puts $result } ConsoleHistory reset ConsolePrompt } else { ConsolePrompt partial } .console yview -pickplace insert } # ::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 variable # ::tk::HistNum is used to store the current location in the history. # # Arguments: # cmd - Which action to take: prev, next, reset. set ::tk::HistNum 1 proc ::tk::ConsoleHistory {cmd} { variable HistNum switch $cmd { prev { incr HistNum -1 if {$HistNum == 0} { set cmd {history event [expr {[history nextid] -1}]} } else { set cmd "history event $HistNum" } if {[catch {consoleinterp eval $cmd} cmd]} { incr HistNum return } .console delete promptEnd end .console insert promptEnd $cmd {input stdin} } next { incr HistNum if {$HistNum == 0} { set cmd {history event [expr {[history nextid] -1}]} } elseif {$HistNum > 0} { set cmd "" set HistNum 1 } else { set cmd "history event $HistNum" } if {$cmd ne ""} { catch {consoleinterp eval $cmd} cmd } .console delete promptEnd end .console insert promptEnd $cmd {input stdin} } reset { set HistNum 1 } } } # ::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. # # Arguments: # partial - Flag to specify which prompt to print. proc ::tk::ConsolePrompt {{partial normal}} { set w .console if {$partial eq "normal"} { 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 [EvalAttached $::tk::console::defaultPrompt] } } else { set temp [$w index output] $w mark set output end if {[consoleinterp eval "info exists tcl_prompt2"]} { consoleinterp eval "eval \[set tcl_prompt2\]" } else { puts -nonewline "> " } } flush stdout $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 -- # This procedure first ensures that the default bindings for the Text # class have been defined. Then certain bindings are overridden for # the class. # # Arguments: # None. 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 {} ## ...or any Control-v binding (would block <>) bind Console {} # For the moment, transpose isn't enabled until the console # gets and overhaul of how it handles input -- hobbs bind Console {} # Ignore all Alt, Meta, and Control keypresses unless explicitly bound. # Otherwise, if a widget binding for one of these is defined, the bind Console {# nothing } bind Console {# nothing} bind Console {# nothing} foreach {ev key} { <> <> <> <> <> <> <> <> <> <> <> <> <> <> <> <> <> <> <> <> } { event add $ev $key bind Console $key {} } bind Console <> { if {[%W compare insert > promptEnd]} {::tk::console::Expand %W} } bind Console <> { if {[%W compare insert > promptEnd]} {::tk::console::Expand %W path} } bind Console <> { if {[%W compare insert > promptEnd]} {::tk::console::Expand %W proc} } bind Console <> { if {[%W compare insert > promptEnd]} {::tk::console::Expand %W var} } bind Console <> { %W mark set insert {end - 1c} tk::ConsoleInsert %W "\n" tk::ConsoleInvoke break } bind Console { if {[%W tag nextrange sel 1.0 end] ne "" && [%W compare sel.first >= promptEnd]} { %W delete sel.first sel.last } elseif {[%W compare insert >= promptEnd]} { %W delete insert %W see insert } } bind Console { if {[%W tag nextrange sel 1.0 end] ne "" && [%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 } } bind Console [bind Console ] bind Console { if {[%W compare insert < promptEnd]} { tk::TextSetCursor %W {insert linestart} } else { tk::TextSetCursor %W promptEnd } } bind Console [bind Console ] bind Console { tk::TextSetCursor %W {insert lineend} } bind Console [bind Console ] bind Console { if {[%W compare insert < promptEnd]} break %W delete insert } bind Console <> { if {[%W compare insert < promptEnd]} break if {[%W compare insert == {insert lineend}]} { %W delete insert } else { %W delete insert {insert lineend} } } bind Console <> { ## Clear console display %W delete 1.0 "promptEnd linestart" } bind Console <> { ## Clear command line (Unix shell staple) %W delete promptEnd end } bind Console { if {[%W compare insert >= promptEnd]} { %W delete insert {insert wordend} } } bind Console { if {[%W compare {insert -1c wordstart} >= promptEnd]} { %W delete {insert -1c wordstart} insert } } bind Console { if {[%W compare insert >= promptEnd]} { %W delete insert {insert wordend} } } bind Console { if {[%W compare {insert -1c wordstart} >= promptEnd]} { %W delete {insert -1c wordstart} insert } } bind Console { if {[%W compare insert >= promptEnd]} { %W delete insert {insert wordend} } } bind Console <> { tk::ConsoleHistory prev } bind Console <> { tk::ConsoleHistory next } bind Console { catch {tk::ConsoleInsert %W [::tk::GetSelection %W PRIMARY]} } bind Console { tk::ConsoleInsert %W %A } bind Console { eval destroy [winfo child .] if {$tcl_platform(platform) eq "macintosh"} { if {[catch {source [file join $tk_library console.tcl]}]} {source -rsrc console} } else { source [file join $tk_library console.tcl] } } if {$::tcl_platform(platform) eq "macintosh" || [tk windowingsystem] eq "aqua"} { bind Console { exit } } bind Console <> { # Same as the copy event if {![catch {set data [%W get sel.first sel.last]}]} { clipboard clear -displayof %W clipboard append -displayof %W $data } } bind Console <> { if {![catch {set data [%W get sel.first sel.last]}]} { clipboard clear -displayof %W clipboard append -displayof %W $data } } bind Console <> { catch { set clip [::tk::GetSelection %W CLIPBOARD] set list [split $clip \n\r] tk::ConsoleInsert %W [lindex $list 0] foreach x [lrange $list 1 end] { %W mark set insert {end - 1c} tk::ConsoleInsert %W "\n" tk::ConsoleInvoke tk::ConsoleInsert %W $x } } } ## ## Bindings for doing special things based on certain keys ## bind PostConsole { if {"\\" ne [%W get insert-2c]} { ::tk::console::MatchPair %W \( \) promptEnd } } bind PostConsole { if {"\\" ne [%W get insert-2c]} { ::tk::console::MatchPair %W \[ \] promptEnd } } bind PostConsole { if {"\\" ne [%W get insert-2c]} { ::tk::console::MatchPair %W \{ \} promptEnd } } bind PostConsole { if {"\\" ne [%W get insert-2c]} { ::tk::console::MatchQuote %W promptEnd } } bind PostConsole { if {"%A" ne ""} { ::tk::console::TagProc %W } break } } # ::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 # is restricted to the prompt area. # # Arguments: # w - The text window in which to insert the string # s - The string to insert (usually just a single character) proc ::tk::ConsoleInsert {w s} { if {$s eq ""} { return } catch { if {[$w compare sel.first <= insert] && [$w compare sel.last >= insert]} { $w tag remove sel sel.first promptEnd $w delete sel.first sel.last } } if {[$w compare insert < promptEnd]} { $w mark set insert end } $w insert insert $s {input stdin} $w see insert } # ::tk::ConsoleOutput -- # # This routine is called directly by ConsolePutsCmd to cause a string # to be displayed in the console. # # Arguments: # dest - The output tag to be used: either "stderr" or "stdout". # string - The string to be displayed. proc ::tk::ConsoleOutput {dest string} { set w .console $w insert output $string $dest ::tk::console::ConstrainBuffer $w $::tk::console::maxLines $w see insert } # ::tk::ConsoleExit -- # # This routine is called by ConsoleEventProc when the main window of # the application is destroyed. Don't call exit - that probably already # happened. Just delete our window. # # Arguments: # None. proc ::tk::ConsoleExit {} { destroy . } # ::tk::ConsoleAbout -- # # This routine displays an About box to show Tcl/Tk version info. # # Arguments: # None. proc ::tk::ConsoleAbout {} { tk_messageBox -type ok -message "[mc {Tcl for Windows}] Tcl $::tcl_patchLevel Tk $::tk_patchLevel" } # ::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 eq ""} {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 {[set ix [$w search -back $c1 insert $lim]] ne ""} { while { [string match {\\} [$w get $ix-1c]] && [set ix [$w search -back $c1 $ix-1c $lim]] ne "" } {} set i1 insert-1c while {$ix ne ""} { set i0 $ix set j 0 while {[set i0 [$w search $c2 $i0 $i1]] ne ""} { append i0 +1c if {[string match {\\} [$w get $i0-2c]]} continue incr j } if {!$j} break set i1 $ix while {$j && [set ix [$w search -back $c1 $ix $lim]] ne ""} { 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 {[set i [$w search -back \" $i $lim]] ne ""} { 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 eq ""} {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 ne "")} { 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 && $repl eq $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 } elseif {[llength $match] == 1} { 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