1151 lines
32 KiB
Tcl
1151 lines
32 KiB
Tcl
# 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.
|
|
#
|
|
# Copyright (c) 1995-1997 Sun Microsystems, Inc.
|
|
# Copyright (c) 1998-2000 Ajuba Solutions.
|
|
# Copyright (c) 2007-2008 Daniel A. Steffen <das@users.sourceforge.net>
|
|
#
|
|
# 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 useFontchooser [llength [info command ::tk::fontchooser]]
|
|
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 {} {
|
|
if {![consoleinterp eval {set tcl_interactive}]} {
|
|
wm withdraw .
|
|
}
|
|
|
|
if {[tk windowingsystem] eq "aqua"} {
|
|
set mod "Cmd"
|
|
} else {
|
|
set mod "Ctrl"
|
|
}
|
|
|
|
if {[catch {menu .menubar} err]} {
|
|
bgerror "INIT: $err"
|
|
}
|
|
AmpMenuArgs .menubar add cascade -label [mc &File] -menu .menubar.file
|
|
AmpMenuArgs .menubar add cascade -label [mc &Edit] -menu .menubar.edit
|
|
|
|
menu .menubar.file -tearoff 0
|
|
AmpMenuArgs .menubar.file add command -label [mc "&Source..."] \
|
|
-command {tk::ConsoleSource}
|
|
AmpMenuArgs .menubar.file add command -label [mc "&Hide Console"] \
|
|
-command {wm withdraw .}
|
|
AmpMenuArgs .menubar.file add command -label [mc "&Clear Console"] \
|
|
-command {.console delete 1.0 "promptEnd linestart"}
|
|
if {[tk windowingsystem] ne "aqua"} {
|
|
AmpMenuArgs .menubar.file add command -label [mc E&xit] -command {exit}
|
|
}
|
|
|
|
menu .menubar.edit -tearoff 0
|
|
AmpMenuArgs .menubar.edit add command -label [mc Cu&t] -accel "$mod+X"\
|
|
-command {event generate .console <<Cut>>}
|
|
AmpMenuArgs .menubar.edit add command -label [mc &Copy] -accel "$mod+C"\
|
|
-command {event generate .console <<Copy>>}
|
|
AmpMenuArgs .menubar.edit add command -label [mc P&aste] -accel "$mod+V"\
|
|
-command {event generate .console <<Paste>>}
|
|
|
|
if {[tk windowingsystem] ne "win32"} {
|
|
AmpMenuArgs .menubar.edit add command -label [mc Cl&ear] \
|
|
-command {event generate .console <<Clear>>}
|
|
} else {
|
|
AmpMenuArgs .menubar.edit add command -label [mc &Delete] \
|
|
-command {event generate .console <<Clear>>} -accel "Del"
|
|
|
|
AmpMenuArgs .menubar add cascade -label [mc &Help] -menu .menubar.help
|
|
menu .menubar.help -tearoff 0
|
|
AmpMenuArgs .menubar.help add command -label [mc &About...] \
|
|
-command tk::ConsoleAbout
|
|
}
|
|
|
|
AmpMenuArgs .menubar.edit add separator
|
|
if {$::tk::console::useFontchooser} {
|
|
if {[tk windowingsystem] eq "aqua"} {
|
|
.menubar.edit add command -label tk_choose_font_marker
|
|
set index [.menubar.edit index tk_choose_font_marker]
|
|
.menubar.edit entryconfigure $index \
|
|
-label [mc "Show Fonts"]\
|
|
-accelerator "$mod-T"\
|
|
-command [list ::tk::console::FontchooserToggle]
|
|
bind Console <<TkFontchooserVisibility>> \
|
|
[list ::tk::console::FontchooserVisibility $index]
|
|
::tk::console::FontchooserVisibility $index
|
|
} else {
|
|
AmpMenuArgs .menubar.edit add command -label [mc "&Font..."] \
|
|
-command [list ::tk::console::FontchooserToggle]
|
|
}
|
|
bind Console <FocusIn> [list ::tk::console::FontchooserFocus %W 1]
|
|
bind Console <FocusOut> [list ::tk::console::FontchooserFocus %W 0]
|
|
}
|
|
AmpMenuArgs .menubar.edit add command -label [mc "&Increase Font Size"] \
|
|
-accel "$mod++" -command {event generate .console <<Console_FontSizeIncr>>}
|
|
AmpMenuArgs .menubar.edit add command -label [mc "&Decrease Font Size"] \
|
|
-accel "$mod+-" -command {event generate .console <<Console_FontSizeDecr>>}
|
|
AmpMenuArgs .menubar.edit add command -label [mc "Fit To Screen Width"] \
|
|
-command {event generate .console <<Console_FitScreenWidth>>}
|
|
|
|
if {[tk windowingsystem] eq "aqua"} {
|
|
.menubar add cascade -label [mc Window] -menu [menu .menubar.window]
|
|
.menubar add cascade -label [mc Help] -menu [menu .menubar.help]
|
|
}
|
|
|
|
. configure -menu .menubar
|
|
|
|
# See if we can find a better font than the TkFixedFont
|
|
catch {font create TkConsoleFont {*}[font configure TkFixedFont]}
|
|
set families [font families]
|
|
switch -exact -- [tk windowingsystem] {
|
|
aqua { set preferred {Monaco 10} }
|
|
win32 { set preferred {ProFontWindows 8 Consolas 8} }
|
|
default { set preferred {} }
|
|
}
|
|
foreach {family size} $preferred {
|
|
if {[lsearch -exact $families $family] != -1} {
|
|
font configure TkConsoleFont -family $family -size $size
|
|
break
|
|
}
|
|
}
|
|
|
|
# Provide the right border for the text widget (platform dependent).
|
|
::ttk::style layout ConsoleFrame {
|
|
Entry.field -sticky news -border 1 -children {
|
|
ConsoleFrame.padding -sticky news
|
|
}
|
|
}
|
|
::ttk::frame .consoleframe -style ConsoleFrame
|
|
|
|
set con [text .console -yscrollcommand [list .sb set] -setgrid true \
|
|
-borderwidth 0 -highlightthickness 0 -font TkConsoleFont]
|
|
if {[tk windowingsystem] eq "aqua"} {
|
|
scrollbar .sb -command [list $con yview]
|
|
} else {
|
|
::ttk::scrollbar .sb -command [list $con yview]
|
|
}
|
|
pack .sb -in .consoleframe -fill both -side right -padx 1 -pady 1
|
|
pack $con -in .consoleframe -fill both -expand 1 -side left -padx 1 -pady 1
|
|
pack .consoleframe -fill both -expand 1 -side left
|
|
|
|
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
|
|
|
|
# Avoid listing this console in [winfo interps]
|
|
if {[info command ::send] eq "::send"} {rename ::send {}}
|
|
|
|
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 {[tk windowingsystem] ne "aqua"} {
|
|
# 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}
|
|
.console see end
|
|
}
|
|
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}
|
|
.console see end
|
|
}
|
|
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
|
|
}
|
|
|
|
# Copy selected text from the console
|
|
proc ::tk::console::Copy {w} {
|
|
if {![catch {set data [$w get sel.first sel.last]}]} {
|
|
clipboard clear -displayof $w
|
|
clipboard append -displayof $w $data
|
|
}
|
|
}
|
|
# Copies selected text. If the selection is within the current active edit
|
|
# region then it will be cut, if not it is only copied.
|
|
proc ::tk::console::Cut {w} {
|
|
if {![catch {set data [$w get sel.first sel.last]}]} {
|
|
clipboard clear -displayof $w
|
|
clipboard append -displayof $w $data
|
|
if {[$w compare sel.first >= output]} {
|
|
$w delete sel.first sel.last
|
|
}
|
|
}
|
|
}
|
|
# Paste text from the clipboard
|
|
proc ::tk::console::Paste {w} {
|
|
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
|
|
}
|
|
}
|
|
}
|
|
|
|
# Fit TkConsoleFont to window width
|
|
proc ::tk::console::FitScreenWidth {w} {
|
|
set width [winfo screenwidth $w]
|
|
set cwidth [$w cget -width]
|
|
set s -50
|
|
set fit 0
|
|
array set fi [font configure TkConsoleFont]
|
|
while {$s < 0} {
|
|
set fi(-size) $s
|
|
set f [font create {*}[array get fi]]
|
|
set c [font measure $f "eM"]
|
|
font delete $f
|
|
if {$c * $cwidth < 1.667 * $width} {
|
|
font configure TkConsoleFont -size $s
|
|
break
|
|
}
|
|
incr s 2
|
|
}
|
|
}
|
|
|
|
# ::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 <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.
|
|
|
|
bind Console <Alt-KeyPress> {# nothing }
|
|
bind Console <Meta-KeyPress> {# nothing}
|
|
bind Console <Control-KeyPress> {# nothing}
|
|
|
|
foreach {ev key} {
|
|
<<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>
|
|
<<Console_FontSizeIncr>> <Control-Key-plus>
|
|
<<Console_FontSizeDecr>> <Control-Key-minus>
|
|
} {
|
|
event add $ev $key
|
|
bind Console $key {}
|
|
}
|
|
if {[tk windowingsystem] eq "aqua"} {
|
|
foreach {ev key} {
|
|
<<Console_FontSizeIncr>> <Command-Key-plus>
|
|
<<Console_FontSizeDecr>> <Command-Key-minus>
|
|
} {
|
|
event add $ev $key
|
|
bind Console $key {}
|
|
}
|
|
if {$::tk::console::useFontchooser} {
|
|
bind Console <Command-Key-t> [list ::tk::console::FontchooserToggle]
|
|
}
|
|
}
|
|
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 Console <Delete> {
|
|
if {{} ne [%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 Console <BackSpace> {
|
|
if {{} ne [%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
|
|
}
|
|
}
|
|
bind Console <Control-h> [bind Console <BackSpace>]
|
|
|
|
bind Console <<LineStart>> {
|
|
if {[%W compare insert < promptEnd]} {
|
|
tk::TextSetCursor %W {insert linestart}
|
|
} else {
|
|
tk::TextSetCursor %W promptEnd
|
|
}
|
|
}
|
|
bind Console <<LineEnd>> {
|
|
tk::TextSetCursor %W {insert lineend}
|
|
}
|
|
bind Console <Control-d> {
|
|
if {[%W compare insert < promptEnd]} {
|
|
break
|
|
}
|
|
%W delete insert
|
|
}
|
|
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 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 Console <Meta-BackSpace> {
|
|
if {[%W compare {insert -1c wordstart} >= promptEnd]} {
|
|
%W delete {insert -1c wordstart} insert
|
|
}
|
|
}
|
|
bind Console <Meta-d> {
|
|
if {[%W compare insert >= promptEnd]} {
|
|
%W delete insert {insert wordend}
|
|
}
|
|
}
|
|
bind Console <Meta-BackSpace> {
|
|
if {[%W compare {insert -1c wordstart} >= promptEnd]} {
|
|
%W delete {insert -1c wordstart} insert
|
|
}
|
|
}
|
|
bind Console <Meta-Delete> {
|
|
if {[%W compare insert >= promptEnd]} {
|
|
%W delete insert {insert wordend}
|
|
}
|
|
}
|
|
bind Console <<PrevLine>> {
|
|
tk::ConsoleHistory prev
|
|
}
|
|
bind Console <<NextLine>> {
|
|
tk::ConsoleHistory next
|
|
}
|
|
bind Console <Insert> {
|
|
catch {tk::ConsoleInsert %W [::tk::GetSelection %W PRIMARY]}
|
|
}
|
|
bind Console <KeyPress> {
|
|
tk::ConsoleInsert %W %A
|
|
}
|
|
bind Console <F9> {
|
|
eval destroy [winfo child .]
|
|
source [file join $tk_library console.tcl]
|
|
}
|
|
if {[tk windowingsystem] eq "aqua"} {
|
|
bind Console <Command-q> {
|
|
exit
|
|
}
|
|
}
|
|
bind Console <<Cut>> { ::tk::console::Cut %W }
|
|
bind Console <<Copy>> { ::tk::console::Copy %W }
|
|
bind Console <<Paste>> { ::tk::console::Paste %W }
|
|
|
|
bind Console <<Console_FontSizeIncr>> {
|
|
set size [font configure TkConsoleFont -size]
|
|
if {$size < 0} {set sign -1} else {set sign 1}
|
|
set size [expr {(abs($size) + 1) * $sign}]
|
|
font configure TkConsoleFont -size $size
|
|
if {$::tk::console::useFontchooser} {
|
|
tk fontchooser configure -font TkConsoleFont
|
|
}
|
|
}
|
|
bind Console <<Console_FontSizeDecr>> {
|
|
set size [font configure TkConsoleFont -size]
|
|
if {abs($size) < 2} { return }
|
|
if {$size < 0} {set sign -1} else {set sign 1}
|
|
set size [expr {(abs($size) - 1) * $sign}]
|
|
font configure TkConsoleFont -size $size
|
|
if {$::tk::console::useFontchooser} {
|
|
tk fontchooser configure -font TkConsoleFont
|
|
}
|
|
}
|
|
bind Console <<Console_FitScreenWidth>> {
|
|
::tk::console::FitScreenWidth %W
|
|
}
|
|
|
|
##
|
|
## Bindings for doing special things based on certain keys
|
|
##
|
|
bind PostConsole <Key-parenright> {
|
|
if {"\\" ne [%W get insert-2c]} {
|
|
::tk::console::MatchPair %W \( \) promptEnd
|
|
}
|
|
}
|
|
bind PostConsole <Key-bracketright> {
|
|
if {"\\" ne [%W get insert-2c]} {
|
|
::tk::console::MatchPair %W \[ \] promptEnd
|
|
}
|
|
}
|
|
bind PostConsole <Key-braceright> {
|
|
if {"\\" ne [%W get insert-2c]} {
|
|
::tk::console::MatchPair %W \{ \} promptEnd
|
|
}
|
|
}
|
|
bind PostConsole <Key-quotedbl> {
|
|
if {"\\" ne [%W get insert-2c]} {
|
|
::tk::console::MatchQuote %W promptEnd
|
|
}
|
|
}
|
|
|
|
bind PostConsole <KeyPress> {
|
|
if {"%A" ne ""} {
|
|
::tk::console::TagProc %W
|
|
}
|
|
}
|
|
}
|
|
|
|
# ::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::Fontchooser* --
|
|
# Let the user select the console font (TIP 324).
|
|
|
|
proc ::tk::console::FontchooserToggle {} {
|
|
if {[tk fontchooser configure -visible]} {
|
|
tk fontchooser hide
|
|
} else {
|
|
tk fontchooser show
|
|
}
|
|
}
|
|
proc ::tk::console::FontchooserVisibility {index} {
|
|
if {[tk fontchooser configure -visible]} {
|
|
.menubar.edit entryconfigure $index -label [msgcat::mc "Hide Fonts"]
|
|
} else {
|
|
.menubar.edit entryconfigure $index -label [msgcat::mc "Show Fonts"]
|
|
}
|
|
}
|
|
proc ::tk::console::FontchooserFocus {w isFocusIn} {
|
|
if {$isFocusIn} {
|
|
tk fontchooser configure -parent $w -font TkConsoleFont \
|
|
-command [namespace code [list FontchooserApply]]
|
|
} else {
|
|
tk fontchooser configure -parent $w -font {} -command {}
|
|
}
|
|
}
|
|
proc ::tk::console::FontchooserApply {font args} {
|
|
catch {font configure TkConsoleFont {*}[font actual $font]}
|
|
}
|
|
|
|
# ::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 {{} ne [set ix [$w search -back $c1 insert $lim]]} {
|
|
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 opt]} {
|
|
return -options $opt $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} {
|
|
if { $::tcl_platform(platform) eq "windows" } {
|
|
## 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 -> 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 [expr {[string length $e] - 1}]
|
|
set ei [expr {[string length $ec] - 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
|