"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tltcl/lib/tk8.6/console.tcl" (17 Mar 2020, 32784 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Tcl/Tk source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 # console.tcl --
    2 #
    3 # This code constructs the console window for an application.  It
    4 # can be used by non-unix systems that do not have built-in support
    5 # for shells.
    6 #
    7 # Copyright (c) 1995-1997 Sun Microsystems, Inc.
    8 # Copyright (c) 1998-2000 Ajuba Solutions.
    9 # Copyright (c) 2007-2008 Daniel A. Steffen <das@users.sourceforge.net>
   10 #
   11 # See the file "license.terms" for information on usage and redistribution
   12 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
   13 #
   14 
   15 # TODO: history - remember partially written command
   16 
   17 namespace eval ::tk::console {
   18     variable blinkTime   500 ; # msecs to blink braced range for
   19     variable blinkRange  1   ; # enable blinking of the entire braced range
   20     variable magicKeys   1   ; # enable brace matching and proc/var recognition
   21     variable maxLines    600 ; # maximum # of lines buffered in console
   22     variable showMatches 1   ; # show multiple expand matches
   23     variable useFontchooser [llength [info command ::tk::fontchooser]]
   24     variable inPlugin [info exists embed_args]
   25     variable defaultPrompt   ; # default prompt if tcl_prompt1 isn't used
   26 
   27     if {$inPlugin} {
   28     set defaultPrompt {subst {[history nextid] % }}
   29     } else {
   30     set defaultPrompt {subst {([file tail [pwd]]) [history nextid] % }}
   31     }
   32 }
   33 
   34 # simple compat function for tkcon code added for this console
   35 interp alias {} EvalAttached {} consoleinterp eval
   36 
   37 # ::tk::ConsoleInit --
   38 # This procedure constructs and configures the console windows.
   39 #
   40 # Arguments:
   41 #   None.
   42 
   43 proc ::tk::ConsoleInit {} {
   44     if {![consoleinterp eval {set tcl_interactive}]} {
   45     wm withdraw .
   46     }
   47 
   48     if {[tk windowingsystem] eq "aqua"} {
   49     set mod "Cmd"
   50     } else {
   51     set mod "Ctrl"
   52     }
   53 
   54     if {[catch {menu .menubar} err]} {
   55     bgerror "INIT: $err"
   56     }
   57     AmpMenuArgs .menubar add cascade -label [mc &File] -menu .menubar.file
   58     AmpMenuArgs .menubar add cascade -label [mc &Edit] -menu .menubar.edit
   59 
   60     menu .menubar.file -tearoff 0
   61     AmpMenuArgs .menubar.file add command -label [mc "&Source..."] \
   62         -command {tk::ConsoleSource}
   63     AmpMenuArgs .menubar.file add command -label [mc "&Hide Console"] \
   64         -command {wm withdraw .}
   65     AmpMenuArgs .menubar.file add command -label [mc "&Clear Console"] \
   66         -command {.console delete 1.0 "promptEnd linestart"}
   67     if {[tk windowingsystem] ne "aqua"} {
   68     AmpMenuArgs .menubar.file add command -label [mc E&xit] -command {exit}
   69     }
   70 
   71     menu .menubar.edit -tearoff 0
   72     AmpMenuArgs .menubar.edit add command -label [mc Cu&t]   -accel "$mod+X"\
   73         -command {event generate .console <<Cut>>}
   74     AmpMenuArgs .menubar.edit add command -label [mc &Copy]  -accel "$mod+C"\
   75         -command {event generate .console <<Copy>>}
   76     AmpMenuArgs .menubar.edit add command -label [mc P&aste] -accel "$mod+V"\
   77         -command {event generate .console <<Paste>>}
   78 
   79     if {[tk windowingsystem] ne "win32"} {
   80     AmpMenuArgs .menubar.edit add command -label [mc Cl&ear] \
   81         -command {event generate .console <<Clear>>}
   82     } else {
   83     AmpMenuArgs .menubar.edit add command -label [mc &Delete] \
   84         -command {event generate .console <<Clear>>} -accel "Del"
   85 
   86     AmpMenuArgs .menubar add cascade -label [mc &Help] -menu .menubar.help
   87     menu .menubar.help -tearoff 0
   88     AmpMenuArgs .menubar.help add command -label [mc &About...] \
   89         -command tk::ConsoleAbout
   90     }
   91 
   92     AmpMenuArgs .menubar.edit add separator
   93     if {$::tk::console::useFontchooser} {
   94         if {[tk windowingsystem] eq "aqua"} {
   95             .menubar.edit add command -label tk_choose_font_marker
   96             set index [.menubar.edit index tk_choose_font_marker]
   97             .menubar.edit entryconfigure $index \
   98                 -label [mc "Show Fonts"]\
   99                 -accelerator "$mod-T"\
  100                 -command [list ::tk::console::FontchooserToggle]
  101             bind Console <<TkFontchooserVisibility>> \
  102                 [list ::tk::console::FontchooserVisibility $index]
  103         ::tk::console::FontchooserVisibility $index
  104         } else {
  105             AmpMenuArgs .menubar.edit add command -label [mc "&Font..."] \
  106                 -command [list ::tk::console::FontchooserToggle]
  107         }
  108     bind Console <FocusIn>  [list ::tk::console::FontchooserFocus %W 1]
  109     bind Console <FocusOut> [list ::tk::console::FontchooserFocus %W 0]
  110     }
  111     AmpMenuArgs .menubar.edit add command -label [mc "&Increase Font Size"] \
  112         -accel "$mod++" -command {event generate .console <<Console_FontSizeIncr>>}
  113     AmpMenuArgs .menubar.edit add command -label [mc "&Decrease Font Size"] \
  114         -accel "$mod+-" -command {event generate .console <<Console_FontSizeDecr>>}
  115     AmpMenuArgs .menubar.edit add command -label [mc "Fit To Screen Width"] \
  116         -command {event generate .console <<Console_FitScreenWidth>>}
  117 
  118     if {[tk windowingsystem] eq "aqua"} {
  119     .menubar add cascade -label [mc Window] -menu [menu .menubar.window]
  120     .menubar add cascade -label [mc Help] -menu [menu .menubar.help]
  121     }
  122 
  123     . configure -menu .menubar
  124 
  125     # See if we can find a better font than the TkFixedFont
  126     catch {font create TkConsoleFont {*}[font configure TkFixedFont]}
  127     set families [font families]
  128     switch -exact -- [tk windowingsystem] {
  129         aqua { set preferred {Monaco 10} }
  130         win32 { set preferred {ProFontWindows 8 Consolas 8} }
  131         default { set preferred {} }
  132     }
  133     foreach {family size} $preferred {
  134         if {[lsearch -exact $families $family] != -1} {
  135             font configure TkConsoleFont -family $family -size $size
  136             break
  137         }
  138     }
  139 
  140     # Provide the right border for the text widget (platform dependent).
  141     ::ttk::style layout ConsoleFrame {
  142         Entry.field -sticky news -border 1 -children {
  143             ConsoleFrame.padding -sticky news
  144         }
  145     }
  146     ::ttk::frame .consoleframe -style ConsoleFrame
  147 
  148     set con [text .console -yscrollcommand [list .sb set] -setgrid true \
  149                  -borderwidth 0 -highlightthickness 0 -font TkConsoleFont]
  150     if {[tk windowingsystem] eq "aqua"} {
  151         scrollbar .sb -command [list $con yview]
  152     } else {
  153         ::ttk::scrollbar .sb -command [list $con yview]
  154     }
  155     pack .sb  -in .consoleframe -fill both -side right -padx 1 -pady 1
  156     pack $con -in .consoleframe -fill both -expand 1 -side left -padx 1 -pady 1
  157     pack .consoleframe -fill both -expand 1 -side left
  158 
  159     ConsoleBind $con
  160 
  161     $con tag configure stderr   -foreground red
  162     $con tag configure stdin    -foreground blue
  163     $con tag configure prompt   -foreground \#8F4433
  164     $con tag configure proc -foreground \#008800
  165     $con tag configure var  -background \#FFC0D0
  166     $con tag raise sel
  167     $con tag configure blink    -background \#FFFF00
  168     $con tag configure find -background \#FFFF00
  169 
  170     focus $con
  171 
  172     # Avoid listing this console in [winfo interps]
  173     if {[info command ::send] eq "::send"} {rename ::send {}}
  174 
  175     wm protocol . WM_DELETE_WINDOW { wm withdraw . }
  176     wm title . [mc "Console"]
  177     flush stdout
  178     $con mark set output [$con index "end - 1 char"]
  179     tk::TextSetCursor $con end
  180     $con mark set promptEnd insert
  181     $con mark gravity promptEnd left
  182 
  183     # A variant of ConsolePrompt to avoid a 'puts' call
  184     set w $con
  185     set temp [$w index "end - 1 char"]
  186     $w mark set output end
  187     if {![consoleinterp eval "info exists tcl_prompt1"]} {
  188     set string [EvalAttached $::tk::console::defaultPrompt]
  189     $w insert output $string stdout
  190     }
  191     $w mark set output $temp
  192     ::tk::TextSetCursor $w end
  193     $w mark set promptEnd insert
  194     $w mark gravity promptEnd left
  195 
  196     if {[tk windowingsystem] ne "aqua"} {
  197     # Subtle work-around to erase the '% ' that tclMain.c prints out
  198     after idle [subst -nocommand {
  199         if {[$con get 1.0 output] eq "% "} { $con delete 1.0 output }
  200     }]
  201     }
  202 }
  203 
  204 # ::tk::ConsoleSource --
  205 #
  206 # Prompts the user for a file to source in the main interpreter.
  207 #
  208 # Arguments:
  209 # None.
  210 
  211 proc ::tk::ConsoleSource {} {
  212     set filename [tk_getOpenFile -defaultextension .tcl -parent . \
  213         -title [mc "Select a file to source"] \
  214         -filetypes [list \
  215         [list [mc "Tcl Scripts"] .tcl] \
  216         [list [mc "All Files"] *]]]
  217     if {$filename ne ""} {
  218         set cmd [list source $filename]
  219     if {[catch {consoleinterp eval $cmd} result]} {
  220         ConsoleOutput stderr "$result\n"
  221     }
  222     }
  223 }
  224 
  225 # ::tk::ConsoleInvoke --
  226 # Processes the command line input.  If the command is complete it
  227 # is evaled in the main interpreter.  Otherwise, the continuation
  228 # prompt is added and more input may be added.
  229 #
  230 # Arguments:
  231 # None.
  232 
  233 proc ::tk::ConsoleInvoke {args} {
  234     set ranges [.console tag ranges input]
  235     set cmd ""
  236     if {[llength $ranges]} {
  237     set pos 0
  238     while {[lindex $ranges $pos] ne ""} {
  239         set start [lindex $ranges $pos]
  240         set end [lindex $ranges [incr pos]]
  241         append cmd [.console get $start $end]
  242         incr pos
  243     }
  244     }
  245     if {$cmd eq ""} {
  246     ConsolePrompt
  247     } elseif {[info complete $cmd]} {
  248     .console mark set output end
  249     .console tag delete input
  250     set result [consoleinterp record $cmd]
  251     if {$result ne ""} {
  252         puts $result
  253     }
  254     ConsoleHistory reset
  255     ConsolePrompt
  256     } else {
  257     ConsolePrompt partial
  258     }
  259     .console yview -pickplace insert
  260 }
  261 
  262 # ::tk::ConsoleHistory --
  263 # This procedure implements command line history for the
  264 # console.  In general is evals the history command in the
  265 # main interpreter to obtain the history.  The variable
  266 # ::tk::HistNum is used to store the current location in the history.
  267 #
  268 # Arguments:
  269 # cmd - Which action to take: prev, next, reset.
  270 
  271 set ::tk::HistNum 1
  272 proc ::tk::ConsoleHistory {cmd} {
  273     variable HistNum
  274 
  275     switch $cmd {
  276         prev {
  277         incr HistNum -1
  278         if {$HistNum == 0} {
  279         set cmd {history event [expr {[history nextid] -1}]}
  280         } else {
  281         set cmd "history event $HistNum"
  282         }
  283             if {[catch {consoleinterp eval $cmd} cmd]} {
  284                 incr HistNum
  285                 return
  286             }
  287         .console delete promptEnd end
  288             .console insert promptEnd $cmd {input stdin}
  289         .console see end
  290         }
  291         next {
  292         incr HistNum
  293         if {$HistNum == 0} {
  294         set cmd {history event [expr {[history nextid] -1}]}
  295         } elseif {$HistNum > 0} {
  296         set cmd ""
  297         set HistNum 1
  298         } else {
  299         set cmd "history event $HistNum"
  300         }
  301         if {$cmd ne ""} {
  302         catch {consoleinterp eval $cmd} cmd
  303         }
  304         .console delete promptEnd end
  305         .console insert promptEnd $cmd {input stdin}
  306         .console see end
  307         }
  308         reset {
  309             set HistNum 1
  310         }
  311     }
  312 }
  313 
  314 # ::tk::ConsolePrompt --
  315 # This procedure draws the prompt.  If tcl_prompt1 or tcl_prompt2
  316 # exists in the main interpreter it will be called to generate the
  317 # prompt.  Otherwise, a hard coded default prompt is printed.
  318 #
  319 # Arguments:
  320 # partial - Flag to specify which prompt to print.
  321 
  322 proc ::tk::ConsolePrompt {{partial normal}} {
  323     set w .console
  324     if {$partial eq "normal"} {
  325     set temp [$w index "end - 1 char"]
  326     $w mark set output end
  327         if {[consoleinterp eval "info exists tcl_prompt1"]} {
  328             consoleinterp eval "eval \[set tcl_prompt1\]"
  329         } else {
  330             puts -nonewline [EvalAttached $::tk::console::defaultPrompt]
  331         }
  332     } else {
  333     set temp [$w index output]
  334     $w mark set output end
  335         if {[consoleinterp eval "info exists tcl_prompt2"]} {
  336             consoleinterp eval "eval \[set tcl_prompt2\]"
  337         } else {
  338         puts -nonewline "> "
  339         }
  340     }
  341     flush stdout
  342     $w mark set output $temp
  343     ::tk::TextSetCursor $w end
  344     $w mark set promptEnd insert
  345     $w mark gravity promptEnd left
  346     ::tk::console::ConstrainBuffer $w $::tk::console::maxLines
  347     $w see end
  348 }
  349 
  350 # Copy selected text from the console
  351 proc ::tk::console::Copy {w} {
  352     if {![catch {set data [$w get sel.first sel.last]}]} {
  353         clipboard clear -displayof $w
  354         clipboard append -displayof $w $data
  355     }
  356 }
  357 # Copies selected text. If the selection is within the current active edit
  358 # region then it will be cut, if not it is only copied.
  359 proc ::tk::console::Cut {w} {
  360     if {![catch {set data [$w get sel.first sel.last]}]} {
  361         clipboard clear -displayof $w
  362         clipboard append -displayof $w $data
  363         if {[$w compare sel.first >= output]} {
  364             $w delete sel.first sel.last
  365     }
  366     }
  367 }
  368 # Paste text from the clipboard
  369 proc ::tk::console::Paste {w} {
  370     catch {
  371         set clip [::tk::GetSelection $w CLIPBOARD]
  372         set list [split $clip \n\r]
  373         tk::ConsoleInsert $w [lindex $list 0]
  374         foreach x [lrange $list 1 end] {
  375             $w mark set insert {end - 1c}
  376             tk::ConsoleInsert $w "\n"
  377             tk::ConsoleInvoke
  378             tk::ConsoleInsert $w $x
  379         }
  380     }
  381 }
  382 
  383 # Fit TkConsoleFont to window width
  384 proc ::tk::console::FitScreenWidth {w} {
  385     set width [winfo screenwidth $w]
  386     set cwidth [$w cget -width]
  387     set s -50
  388     set fit 0
  389     array set fi [font configure TkConsoleFont]
  390     while {$s < 0} {
  391         set fi(-size) $s
  392         set f [font create {*}[array get fi]]
  393         set c [font measure $f "eM"]
  394         font delete $f
  395         if {$c * $cwidth < 1.667 * $width} {
  396             font configure TkConsoleFont -size $s
  397             break
  398         }
  399     incr s 2
  400     }
  401 }
  402 
  403 # ::tk::ConsoleBind --
  404 # This procedure first ensures that the default bindings for the Text
  405 # class have been defined.  Then certain bindings are overridden for
  406 # the class.
  407 #
  408 # Arguments:
  409 # None.
  410 
  411 proc ::tk::ConsoleBind {w} {
  412     bindtags $w [list $w Console PostConsole [winfo toplevel $w] all]
  413 
  414     ## Get all Text bindings into Console
  415     foreach ev [bind Text] {
  416     bind Console $ev [bind Text $ev]
  417     }
  418     ## We really didn't want the newline insertion...
  419     bind Console <Control-Key-o> {}
  420     ## ...or any Control-v binding (would block <<Paste>>)
  421     bind Console <Control-Key-v> {}
  422 
  423     # For the moment, transpose isn't enabled until the console
  424     # gets and overhaul of how it handles input -- hobbs
  425     bind Console <Control-Key-t> {}
  426 
  427     # Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
  428     # Otherwise, if a widget binding for one of these is defined, the
  429     # <Keypress> class binding will also fire and insert the character
  430     # which is wrong.
  431 
  432     bind Console <Alt-KeyPress> {# nothing }
  433     bind Console <Meta-KeyPress> {# nothing}
  434     bind Console <Control-KeyPress> {# nothing}
  435 
  436     foreach {ev key} {
  437     <<Console_NextImmediate>>   <Control-Key-n>
  438     <<Console_PrevImmediate>>   <Control-Key-p>
  439     <<Console_PrevSearch>>      <Control-Key-r>
  440     <<Console_NextSearch>>      <Control-Key-s>
  441 
  442     <<Console_Expand>>      <Key-Tab>
  443     <<Console_Expand>>      <Key-Escape>
  444     <<Console_ExpandFile>>      <Control-Shift-Key-F>
  445     <<Console_ExpandProc>>      <Control-Shift-Key-P>
  446     <<Console_ExpandVar>>       <Control-Shift-Key-V>
  447     <<Console_Tab>>         <Control-Key-i>
  448     <<Console_Tab>>         <Meta-Key-i>
  449     <<Console_Eval>>        <Key-Return>
  450     <<Console_Eval>>        <Key-KP_Enter>
  451 
  452     <<Console_Clear>>       <Control-Key-l>
  453     <<Console_KillLine>>        <Control-Key-k>
  454     <<Console_Transpose>>       <Control-Key-t>
  455     <<Console_ClearLine>>       <Control-Key-u>
  456     <<Console_SaveCommand>>     <Control-Key-z>
  457         <<Console_FontSizeIncr>>    <Control-Key-plus>
  458         <<Console_FontSizeDecr>>    <Control-Key-minus>
  459     } {
  460     event add $ev $key
  461     bind Console $key {}
  462     }
  463     if {[tk windowingsystem] eq "aqua"} {
  464     foreach {ev key} {
  465         <<Console_FontSizeIncr>>    <Command-Key-plus>
  466         <<Console_FontSizeDecr>>    <Command-Key-minus>
  467     } {
  468         event add $ev $key
  469         bind Console $key {}
  470     }
  471     if {$::tk::console::useFontchooser} {
  472         bind Console <Command-Key-t> [list ::tk::console::FontchooserToggle]
  473     }
  474     }
  475     bind Console <<Console_Expand>> {
  476     if {[%W compare insert > promptEnd]} {
  477         ::tk::console::Expand %W
  478     }
  479     }
  480     bind Console <<Console_ExpandFile>> {
  481     if {[%W compare insert > promptEnd]} {
  482         ::tk::console::Expand %W path
  483     }
  484     }
  485     bind Console <<Console_ExpandProc>> {
  486     if {[%W compare insert > promptEnd]} {
  487         ::tk::console::Expand %W proc
  488     }
  489     }
  490     bind Console <<Console_ExpandVar>> {
  491     if {[%W compare insert > promptEnd]} {
  492         ::tk::console::Expand %W var
  493     }
  494     }
  495     bind Console <<Console_Eval>> {
  496     %W mark set insert {end - 1c}
  497     tk::ConsoleInsert %W "\n"
  498     tk::ConsoleInvoke
  499     break
  500     }
  501     bind Console <Delete> {
  502     if {{} ne [%W tag nextrange sel 1.0 end] \
  503         && [%W compare sel.first >= promptEnd]} {
  504         %W delete sel.first sel.last
  505     } elseif {[%W compare insert >= promptEnd]} {
  506         %W delete insert
  507         %W see insert
  508     }
  509     }
  510     bind Console <BackSpace> {
  511     if {{} ne [%W tag nextrange sel 1.0 end] \
  512         && [%W compare sel.first >= promptEnd]} {
  513         %W delete sel.first sel.last
  514     } elseif {[%W compare insert != 1.0] && \
  515         [%W compare insert > promptEnd]} {
  516         %W delete insert-1c
  517         %W see insert
  518     }
  519     }
  520     bind Console <Control-h> [bind Console <BackSpace>]
  521 
  522     bind Console <<LineStart>> {
  523     if {[%W compare insert < promptEnd]} {
  524         tk::TextSetCursor %W {insert linestart}
  525     } else {
  526         tk::TextSetCursor %W promptEnd
  527     }
  528     }
  529     bind Console <<LineEnd>> {
  530     tk::TextSetCursor %W {insert lineend}
  531     }
  532     bind Console <Control-d> {
  533     if {[%W compare insert < promptEnd]} {
  534         break
  535     }
  536     %W delete insert
  537     }
  538     bind Console <<Console_KillLine>> {
  539     if {[%W compare insert < promptEnd]} {
  540         break
  541     }
  542     if {[%W compare insert == {insert lineend}]} {
  543         %W delete insert
  544     } else {
  545         %W delete insert {insert lineend}
  546     }
  547     }
  548     bind Console <<Console_Clear>> {
  549     ## Clear console display
  550     %W delete 1.0 "promptEnd linestart"
  551     }
  552     bind Console <<Console_ClearLine>> {
  553     ## Clear command line (Unix shell staple)
  554     %W delete promptEnd end
  555     }
  556     bind Console <Meta-d> {
  557     if {[%W compare insert >= promptEnd]} {
  558         %W delete insert {insert wordend}
  559     }
  560     }
  561     bind Console <Meta-BackSpace> {
  562     if {[%W compare {insert -1c wordstart} >= promptEnd]} {
  563         %W delete {insert -1c wordstart} insert
  564     }
  565     }
  566     bind Console <Meta-d> {
  567     if {[%W compare insert >= promptEnd]} {
  568         %W delete insert {insert wordend}
  569     }
  570     }
  571     bind Console <Meta-BackSpace> {
  572     if {[%W compare {insert -1c wordstart} >= promptEnd]} {
  573         %W delete {insert -1c wordstart} insert
  574     }
  575     }
  576     bind Console <Meta-Delete> {
  577     if {[%W compare insert >= promptEnd]} {
  578         %W delete insert {insert wordend}
  579     }
  580     }
  581     bind Console <<PrevLine>> {
  582     tk::ConsoleHistory prev
  583     }
  584     bind Console <<NextLine>> {
  585     tk::ConsoleHistory next
  586     }
  587     bind Console <Insert> {
  588     catch {tk::ConsoleInsert %W [::tk::GetSelection %W PRIMARY]}
  589     }
  590     bind Console <KeyPress> {
  591     tk::ConsoleInsert %W %A
  592     }
  593     bind Console <F9> {
  594     eval destroy [winfo child .]
  595     source [file join $tk_library console.tcl]
  596     }
  597     if {[tk windowingsystem] eq "aqua"} {
  598     bind Console <Command-q> {
  599         exit
  600     }
  601     }
  602     bind Console <<Cut>> { ::tk::console::Cut %W }
  603     bind Console <<Copy>> { ::tk::console::Copy %W }
  604     bind Console <<Paste>> { ::tk::console::Paste %W }
  605 
  606     bind Console <<Console_FontSizeIncr>> {
  607         set size [font configure TkConsoleFont -size]
  608         if {$size < 0} {set sign -1} else {set sign 1}
  609         set size [expr {(abs($size) + 1) * $sign}]
  610         font configure TkConsoleFont -size $size
  611     if {$::tk::console::useFontchooser} {
  612         tk fontchooser configure -font TkConsoleFont
  613     }
  614     }
  615     bind Console <<Console_FontSizeDecr>> {
  616         set size [font configure TkConsoleFont -size]
  617         if {abs($size) < 2} { return }
  618         if {$size < 0} {set sign -1} else {set sign 1}
  619         set size [expr {(abs($size) - 1) * $sign}]
  620         font configure TkConsoleFont -size $size
  621     if {$::tk::console::useFontchooser} {
  622         tk fontchooser configure -font TkConsoleFont
  623     }
  624     }
  625     bind Console <<Console_FitScreenWidth>> {
  626     ::tk::console::FitScreenWidth %W
  627     }
  628 
  629     ##
  630     ## Bindings for doing special things based on certain keys
  631     ##
  632     bind PostConsole <Key-parenright> {
  633     if {"\\" ne [%W get insert-2c]} {
  634         ::tk::console::MatchPair %W \( \) promptEnd
  635     }
  636     }
  637     bind PostConsole <Key-bracketright> {
  638     if {"\\" ne [%W get insert-2c]} {
  639         ::tk::console::MatchPair %W \[ \] promptEnd
  640     }
  641     }
  642     bind PostConsole <Key-braceright> {
  643     if {"\\" ne [%W get insert-2c]} {
  644         ::tk::console::MatchPair %W \{ \} promptEnd
  645     }
  646     }
  647     bind PostConsole <Key-quotedbl> {
  648     if {"\\" ne [%W get insert-2c]} {
  649         ::tk::console::MatchQuote %W promptEnd
  650     }
  651     }
  652 
  653     bind PostConsole <KeyPress> {
  654     if {"%A" ne ""} {
  655         ::tk::console::TagProc %W
  656     }
  657     }
  658 }
  659 
  660 # ::tk::ConsoleInsert --
  661 # Insert a string into a text at the point of the insertion cursor.
  662 # If there is a selection in the text, and it covers the point of the
  663 # insertion cursor, then delete the selection before inserting.  Insertion
  664 # is restricted to the prompt area.
  665 #
  666 # Arguments:
  667 # w -       The text window in which to insert the string
  668 # s -       The string to insert (usually just a single character)
  669 
  670 proc ::tk::ConsoleInsert {w s} {
  671     if {$s eq ""} {
  672     return
  673     }
  674     catch {
  675     if {[$w compare sel.first <= insert] \
  676         && [$w compare sel.last >= insert]} {
  677         $w tag remove sel sel.first promptEnd
  678         $w delete sel.first sel.last
  679     }
  680     }
  681     if {[$w compare insert < promptEnd]} {
  682     $w mark set insert end
  683     }
  684     $w insert insert $s {input stdin}
  685     $w see insert
  686 }
  687 
  688 # ::tk::ConsoleOutput --
  689 #
  690 # This routine is called directly by ConsolePutsCmd to cause a string
  691 # to be displayed in the console.
  692 #
  693 # Arguments:
  694 # dest -    The output tag to be used: either "stderr" or "stdout".
  695 # string -  The string to be displayed.
  696 
  697 proc ::tk::ConsoleOutput {dest string} {
  698     set w .console
  699     $w insert output $string $dest
  700     ::tk::console::ConstrainBuffer $w $::tk::console::maxLines
  701     $w see insert
  702 }
  703 
  704 # ::tk::ConsoleExit --
  705 #
  706 # This routine is called by ConsoleEventProc when the main window of
  707 # the application is destroyed.  Don't call exit - that probably already
  708 # happened.  Just delete our window.
  709 #
  710 # Arguments:
  711 # None.
  712 
  713 proc ::tk::ConsoleExit {} {
  714     destroy .
  715 }
  716 
  717 # ::tk::ConsoleAbout --
  718 #
  719 # This routine displays an About box to show Tcl/Tk version info.
  720 #
  721 # Arguments:
  722 # None.
  723 
  724 proc ::tk::ConsoleAbout {} {
  725     tk_messageBox -type ok -message "[mc {Tcl for Windows}]
  726 
  727 Tcl $::tcl_patchLevel
  728 Tk $::tk_patchLevel"
  729 }
  730 
  731 # ::tk::console::Fontchooser* --
  732 #   Let the user select the console font (TIP 324).
  733 
  734 proc ::tk::console::FontchooserToggle {} {
  735     if {[tk fontchooser configure -visible]} {
  736     tk fontchooser hide
  737     } else {
  738     tk fontchooser show
  739     }
  740 }
  741 proc ::tk::console::FontchooserVisibility {index} {
  742     if {[tk fontchooser configure -visible]} {
  743     .menubar.edit entryconfigure $index -label [msgcat::mc "Hide Fonts"]
  744     } else {
  745     .menubar.edit entryconfigure $index -label [msgcat::mc "Show Fonts"]
  746     }
  747 }
  748 proc ::tk::console::FontchooserFocus {w isFocusIn} {
  749     if {$isFocusIn} {
  750     tk fontchooser configure -parent $w -font TkConsoleFont \
  751         -command [namespace code [list FontchooserApply]]
  752     } else {
  753     tk fontchooser configure -parent $w -font {} -command {}
  754     }
  755 }
  756 proc ::tk::console::FontchooserApply {font args} {
  757     catch {font configure TkConsoleFont {*}[font actual $font]}
  758 }
  759 
  760 # ::tk::console::TagProc --
  761 #
  762 # Tags a procedure in the console if it's recognized
  763 # This procedure is not perfect.  However, making it perfect wastes
  764 # too much CPU time...
  765 #
  766 # Arguments:
  767 #   w   - console text widget
  768 
  769 proc ::tk::console::TagProc w {
  770     if {!$::tk::console::magicKeys} {
  771     return
  772     }
  773     set exp "\[^\\\\\]\[\[ \t\n\r\;{}\"\$\]"
  774     set i [$w search -backwards -regexp $exp insert-1c promptEnd-1c]
  775     if {$i eq ""} {
  776     set i promptEnd
  777     } else {
  778     append i +2c
  779     }
  780     regsub -all "\[\[\\\\\\?\\*\]" [$w get $i "insert-1c wordend"] {\\\0} c
  781     if {[llength [EvalAttached [list info commands $c]]]} {
  782     $w tag add proc $i "insert-1c wordend"
  783     } else {
  784     $w tag remove proc $i "insert-1c wordend"
  785     }
  786     if {[llength [EvalAttached [list info vars $c]]]} {
  787     $w tag add var $i "insert-1c wordend"
  788     } else {
  789     $w tag remove var $i "insert-1c wordend"
  790     }
  791 }
  792 
  793 # ::tk::console::MatchPair --
  794 #
  795 # Blinks a matching pair of characters
  796 # c2 is assumed to be at the text index 'insert'.
  797 # This proc is really loopy and took me an hour to figure out given
  798 # all possible combinations with escaping except for escaped \'s.
  799 # It doesn't take into account possible commenting... Oh well.  If
  800 # anyone has something better, I'd like to see/use it.  This is really
  801 # only efficient for small contexts.
  802 #
  803 # Arguments:
  804 #   w   - console text widget
  805 #   c1  - first char of pair
  806 #   c2  - second char of pair
  807 #
  808 # Calls:    ::tk::console::Blink
  809 
  810 proc ::tk::console::MatchPair {w c1 c2 {lim 1.0}} {
  811     if {!$::tk::console::magicKeys} {
  812     return
  813     }
  814     if {{} ne [set ix [$w search -back $c1 insert $lim]]} {
  815     while {
  816         [string match {\\} [$w get $ix-1c]] &&
  817         [set ix [$w search -back $c1 $ix-1c $lim]] ne {}
  818     } {}
  819     set i1 insert-1c
  820     while {$ix ne {}} {
  821         set i0 $ix
  822         set j 0
  823         while {[set i0 [$w search $c2 $i0 $i1]] ne {}} {
  824         append i0 +1c
  825         if {[string match {\\} [$w get $i0-2c]]} {
  826             continue
  827         }
  828         incr j
  829         }
  830         if {!$j} {
  831         break
  832         }
  833         set i1 $ix
  834         while {$j && [set ix [$w search -back $c1 $ix $lim]] ne {}} {
  835         if {[string match {\\} [$w get $ix-1c]]} {
  836             continue
  837         }
  838         incr j -1
  839         }
  840     }
  841     if {[string match {} $ix]} {
  842         set ix [$w index $lim]
  843     }
  844     } else {
  845     set ix [$w index $lim]
  846     }
  847     if {$::tk::console::blinkRange} {
  848     Blink $w $ix [$w index insert]
  849     } else {
  850     Blink $w $ix $ix+1c [$w index insert-1c] [$w index insert]
  851     }
  852 }
  853 
  854 # ::tk::console::MatchQuote --
  855 #
  856 # Blinks between matching quotes.
  857 # Blinks just the quote if it's unmatched, otherwise blinks quoted string
  858 # The quote to match is assumed to be at the text index 'insert'.
  859 #
  860 # Arguments:
  861 #   w   - console text widget
  862 #
  863 # Calls:    ::tk::console::Blink
  864 
  865 proc ::tk::console::MatchQuote {w {lim 1.0}} {
  866     if {!$::tk::console::magicKeys} {
  867     return
  868     }
  869     set i insert-1c
  870     set j 0
  871     while {[set i [$w search -back \" $i $lim]] ne {}} {
  872     if {[string match {\\} [$w get $i-1c]]} {
  873         continue
  874     }
  875     if {!$j} {
  876         set i0 $i
  877     }
  878     incr j
  879     }
  880     if {$j&1} {
  881     if {$::tk::console::blinkRange} {
  882         Blink $w $i0 [$w index insert]
  883     } else {
  884         Blink $w $i0 $i0+1c [$w index insert-1c] [$w index insert]
  885     }
  886     } else {
  887     Blink $w [$w index insert-1c] [$w index insert]
  888     }
  889 }
  890 
  891 # ::tk::console::Blink --
  892 #
  893 # Blinks between n index pairs for a specified duration.
  894 #
  895 # Arguments:
  896 #   w   - console text widget
  897 #   i1  - start index to blink region
  898 #   i2  - end index of blink region
  899 #   dur - duration in usecs to blink for
  900 #
  901 # Outputs:
  902 #   blinks selected characters in $w
  903 
  904 proc ::tk::console::Blink {w args} {
  905     eval [list $w tag add blink] $args
  906     after $::tk::console::blinkTime [list $w] tag remove blink $args
  907 }
  908 
  909 # ::tk::console::ConstrainBuffer --
  910 #
  911 # This limits the amount of data in the text widget
  912 # Called by Prompt and ConsoleOutput
  913 #
  914 # Arguments:
  915 #   w   - console text widget
  916 #   size    - # of lines to constrain to
  917 #
  918 # Outputs:
  919 #   may delete data in console widget
  920 
  921 proc ::tk::console::ConstrainBuffer {w size} {
  922     if {[$w index end] > $size} {
  923     $w delete 1.0 [expr {int([$w index end])-$size}].0
  924     }
  925 }
  926 
  927 # ::tk::console::Expand --
  928 #
  929 # Arguments:
  930 # ARGS: w   - text widget in which to expand str
  931 #   type    - type of expansion (path / proc / variable)
  932 #
  933 # Calls:    ::tk::console::Expand(Pathname|Procname|Variable)
  934 #
  935 # Outputs:  The string to match is expanded to the longest possible match.
  936 #       If ::tk::console::showMatches is non-zero and the longest match
  937 #       equaled the string to expand, then all possible matches are
  938 #       output to stdout.  Triggers bell if no matches are found.
  939 #
  940 # Returns:  number of matches found
  941 
  942 proc ::tk::console::Expand {w {type ""}} {
  943     set exp "\[^\\\\\]\[\[ \t\n\r\\\{\"\\\\\$\]"
  944     set tmp [$w search -backwards -regexp $exp insert-1c promptEnd-1c]
  945     if {$tmp eq ""} {
  946     set tmp promptEnd
  947     } else {
  948     append tmp +2c
  949     }
  950     if {[$w compare $tmp >= insert]} {
  951     return
  952     }
  953     set str [$w get $tmp insert]
  954     switch -glob $type {
  955     path* {
  956         set res [ExpandPathname $str]
  957     }
  958     proc* {
  959         set res [ExpandProcname $str]
  960     }
  961     var* {
  962         set res [ExpandVariable $str]
  963     }
  964     default {
  965         set res {}
  966         foreach t {Pathname Procname Variable} {
  967         if {![catch {Expand$t $str} res] && ($res ne "")} {
  968             break
  969         }
  970         }
  971     }
  972     }
  973     set len [llength $res]
  974     if {$len} {
  975     set repl [lindex $res 0]
  976     $w delete $tmp insert
  977     $w insert $tmp $repl {input stdin}
  978     if {($len > 1) && ($::tk::console::showMatches) && ($repl eq $str)} {
  979         puts stdout [lsort [lreplace $res 0 0]]
  980     }
  981     } else {
  982     bell
  983     }
  984     return [incr len -1]
  985 }
  986 
  987 # ::tk::console::ExpandPathname --
  988 #
  989 # Expand a file pathname based on $str
  990 # This is based on UNIX file name conventions
  991 #
  992 # Arguments:
  993 #   str - partial file pathname to expand
  994 #
  995 # Calls:    ::tk::console::ExpandBestMatch
  996 #
  997 # Returns:  list containing longest unique match followed by all the
  998 #       possible further matches
  999 
 1000 proc ::tk::console::ExpandPathname str {
 1001     set pwd [EvalAttached pwd]
 1002     if {[catch {EvalAttached [list cd [file dirname $str]]} err opt]} {
 1003     return -options $opt $err
 1004     }
 1005     set dir [file tail $str]
 1006     ## Check to see if it was known to be a directory and keep the trailing
 1007     ## slash if so (file tail cuts it off)
 1008     if {[string match */ $str]} {
 1009     append dir /
 1010     }
 1011     if {[catch {lsort [EvalAttached [list glob $dir*]]} m]} {
 1012     set match {}
 1013     } else {
 1014     if {[llength $m] > 1} {
 1015         if { $::tcl_platform(platform) eq "windows" } {
 1016         ## Windows is screwy because it's case insensitive
 1017         set tmp [ExpandBestMatch [string tolower $m] \
 1018             [string tolower $dir]]
 1019         ## Don't change case if we haven't changed the word
 1020         if {[string length $dir]==[string length $tmp]} {
 1021             set tmp $dir
 1022         }
 1023         } else {
 1024         set tmp [ExpandBestMatch $m $dir]
 1025         }
 1026         if {[string match ?*/* $str]} {
 1027         set tmp [file dirname $str]/$tmp
 1028         } elseif {[string match /* $str]} {
 1029         set tmp /$tmp
 1030         }
 1031         regsub -all { } $tmp {\\ } tmp
 1032         set match [linsert $m 0 $tmp]
 1033     } else {
 1034         ## This may look goofy, but it handles spaces in path names
 1035         eval append match $m
 1036         if {[file isdir $match]} {
 1037         append match /
 1038         }
 1039         if {[string match ?*/* $str]} {
 1040         set match [file dirname $str]/$match
 1041         } elseif {[string match /* $str]} {
 1042         set match /$match
 1043         }
 1044         regsub -all { } $match {\\ } match
 1045         ## Why is this one needed and the ones below aren't!!
 1046         set match [list $match]
 1047     }
 1048     }
 1049     EvalAttached [list cd $pwd]
 1050     return $match
 1051 }
 1052 
 1053 # ::tk::console::ExpandProcname --
 1054 #
 1055 # Expand a tcl proc name based on $str
 1056 #
 1057 # Arguments:
 1058 #   str - partial proc name to expand
 1059 #
 1060 # Calls:    ::tk::console::ExpandBestMatch
 1061 #
 1062 # Returns:  list containing longest unique match followed by all the
 1063 #       possible further matches
 1064 
 1065 proc ::tk::console::ExpandProcname str {
 1066     set match [EvalAttached [list info commands $str*]]
 1067     if {[llength $match] == 0} {
 1068     set ns [EvalAttached \
 1069         "namespace children \[namespace current\] [list $str*]"]
 1070     if {[llength $ns]==1} {
 1071         set match [EvalAttached [list info commands ${ns}::*]]
 1072     } else {
 1073         set match $ns
 1074     }
 1075     }
 1076     if {[llength $match] > 1} {
 1077     regsub -all { } [ExpandBestMatch $match $str] {\\ } str
 1078     set match [linsert $match 0 $str]
 1079     } else {
 1080     regsub -all { } $match {\\ } match
 1081     }
 1082     return $match
 1083 }
 1084 
 1085 # ::tk::console::ExpandVariable --
 1086 #
 1087 # Expand a tcl variable name based on $str
 1088 #
 1089 # Arguments:
 1090 #   str - partial tcl var name to expand
 1091 #
 1092 # Calls:    ::tk::console::ExpandBestMatch
 1093 #
 1094 # Returns:  list containing longest unique match followed by all the
 1095 #       possible further matches
 1096 
 1097 proc ::tk::console::ExpandVariable str {
 1098     if {[regexp {([^\(]*)\((.*)} $str -> ary str]} {
 1099     ## Looks like they're trying to expand an array.
 1100     set match [EvalAttached [list array names $ary $str*]]
 1101     if {[llength $match] > 1} {
 1102         set vars $ary\([ExpandBestMatch $match $str]
 1103         foreach var $match {
 1104         lappend vars $ary\($var\)
 1105         }
 1106         return $vars
 1107     } elseif {[llength $match] == 1} {
 1108         set match $ary\($match\)
 1109     }
 1110     ## Space transformation avoided for array names.
 1111     } else {
 1112     set match [EvalAttached [list info vars $str*]]
 1113     if {[llength $match] > 1} {
 1114         regsub -all { } [ExpandBestMatch $match $str] {\\ } str
 1115         set match [linsert $match 0 $str]
 1116     } else {
 1117         regsub -all { } $match {\\ } match
 1118     }
 1119     }
 1120     return $match
 1121 }
 1122 
 1123 # ::tk::console::ExpandBestMatch --
 1124 #
 1125 # Finds the best unique match in a list of names.
 1126 # The extra $e in this argument allows us to limit the innermost loop a little
 1127 # further.  This improves speed as $l becomes large or $e becomes long.
 1128 #
 1129 # Arguments:
 1130 #   l   - list to find best unique match in
 1131 #   e   - currently best known unique match
 1132 #
 1133 # Returns:  longest unique match in the list
 1134 
 1135 proc ::tk::console::ExpandBestMatch {l {e {}}} {
 1136     set ec [lindex $l 0]
 1137     if {[llength $l]>1} {
 1138     set e [expr {[string length $e] - 1}]
 1139     set ei [expr {[string length $ec] - 1}]
 1140     foreach l $l {
 1141         while {$ei>=$e && [string first $ec $l]} {
 1142         set ec [string range $ec 0 [incr ei -1]]
 1143         }
 1144     }
 1145     }
 1146     return $ec
 1147 }
 1148 
 1149 # now initialize the console
 1150 ::tk::ConsoleInit