summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tltcl/lib/tk8.6/console.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tltcl/lib/tk8.6/console.tcl')
-rw-r--r--systems/texlive/tlnet/tlpkg/tltcl/lib/tk8.6/console.tcl1150
1 files changed, 1150 insertions, 0 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tltcl/lib/tk8.6/console.tcl b/systems/texlive/tlnet/tlpkg/tltcl/lib/tk8.6/console.tcl
new file mode 100644
index 0000000000..355a43b003
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tltcl/lib/tk8.6/console.tcl
@@ -0,0 +1,1150 @@
+# 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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-08 07:34:55 +0000