util/X86LINUX64/lib/tk8.6/console.tcl

   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     global tcl_platform
  45
  46     if {![consoleinterp eval {set tcl_interactive}]} {
  47         wm withdraw .
  48     }
  49
  50     if {[tk windowingsystem] eq "aqua"} {
  51         set mod "Cmd"
  52     } else {
  53         set mod "Ctrl"
  54     }
  55
  56     if {[catch {menu .menubar} err]} {
  57         bgerror "INIT: $err"
  58     }
  59     AmpMenuArgs .menubar add cascade -label [mc &File] -menu .menubar.file
  60     AmpMenuArgs .menubar add cascade -label [mc &Edit] -menu .menubar.edit
  61
  62     menu .menubar.file -tearoff 0
  63     AmpMenuArgs .menubar.file add command -label [mc "&Source..."] \
  64             -command {tk::ConsoleSource}
  65     AmpMenuArgs .menubar.file add command -label [mc "&Hide Console"] \
  66             -command {wm withdraw .}
  67     AmpMenuArgs .menubar.file add command -label [mc "&Clear Console"] \
  68             -command {.console delete 1.0 "promptEnd linestart"}
  69     if {[tk windowingsystem] ne "aqua"} {
  70         AmpMenuArgs .menubar.file add command -label [mc E&xit] -command {exit}
  71     }
  72
  73     menu .menubar.edit -tearoff 0
  74     AmpMenuArgs .menubar.edit add command -label [mc Cu&t]   -accel "$mod+X"\
  75             -command {event generate .console <<Cut>>}
  76     AmpMenuArgs .menubar.edit add command -label [mc &Copy]  -accel "$mod+C"\
  77             -command {event generate .console <<Copy>>}
  78     AmpMenuArgs .menubar.edit add command -label [mc P&aste] -accel "$mod+V"\
  79             -command {event generate .console <<Paste>>}
  80
  81     if {$tcl_platform(platform) ne "windows"} {
  82         AmpMenuArgs .menubar.edit add command -label [mc Cl&ear] \
  83                 -command {event generate .console <<Clear>>}
  84     } else {
  85         AmpMenuArgs .menubar.edit add command -label [mc &Delete] \
  86                 -command {event generate .console <<Clear>>} -accel "Del"
  87
  88         AmpMenuArgs .menubar add cascade -label [mc &Help] -menu .menubar.help
  89         menu .menubar.help -tearoff 0
  90         AmpMenuArgs .menubar.help add command -label [mc &About...] \
  91                 -command tk::ConsoleAbout
  92     }
  93
  94     AmpMenuArgs .menubar.edit add separator
  95     if {$::tk::console::useFontchooser} {
  96         if {[tk windowingsystem] eq "aqua"} {
  97             .menubar.edit add command -label tk_choose_font_marker
  98             set index [.menubar.edit index tk_choose_font_marker]
  99             .menubar.edit entryconfigure $index \
 100                 -label [mc "Show Fonts"]\
 101                 -accelerator "$mod-T"\
 102                 -command [list ::tk::console::FontchooserToggle]
 103             bind Console <<TkFontchooserVisibility>> \
 104                 [list ::tk::console::FontchooserVisibility $index]
 105             ::tk::console::FontchooserVisibility $index
 106         } else {
 107             AmpMenuArgs .menubar.edit add command -label [mc "&Font..."] \
 108                 -command [list ::tk::console::FontchooserToggle]
 109         }
 110         bind Console <FocusIn>  [list ::tk::console::FontchooserFocus %W 1]
 111         bind Console <FocusOut> [list ::tk::console::FontchooserFocus %W 0]
 112     }
 113     AmpMenuArgs .menubar.edit add command -label [mc "&Increase Font Size"] \
 114         -accel "$mod++" -command {event generate .console <<Console_FontSizeIncr>>}
 115     AmpMenuArgs .menubar.edit add command -label [mc "&Decrease Font Size"] \
 116         -accel "$mod+-" -command {event generate .console <<Console_FontSizeDecr>>}
 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 {$tcl_platform(platform) eq "windows"} {
 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         }
 290         next {
 291             incr HistNum
 292             if {$HistNum == 0} {
 293                 set cmd {history event [expr {[history nextid] -1}]}
 294             } elseif {$HistNum > 0} {
 295                 set cmd ""
 296                 set HistNum 1
 297             } else {
 298                 set cmd "history event $HistNum"
 299             }
 300             if {$cmd ne ""} {
 301                 catch {consoleinterp eval $cmd} cmd
 302             }
 303             .console delete promptEnd end
 304             .console insert promptEnd $cmd {input stdin}
 305         }
 306         reset {
 307             set HistNum 1
 308         }
 309     }
 310 }
 311
 312 # ::tk::ConsolePrompt --
 313 # This procedure draws the prompt.  If tcl_prompt1 or tcl_prompt2
 314 # exists in the main interpreter it will be called to generate the
 315 # prompt.  Otherwise, a hard coded default prompt is printed.
 316 #
 317 # Arguments:
 318 # partial -     Flag to specify which prompt to print.
 319
 320 proc ::tk::ConsolePrompt {{partial normal}} {
 321     set w .console
 322     if {$partial eq "normal"} {
 323         set temp [$w index "end - 1 char"]
 324         $w mark set output end
 325         if {[consoleinterp eval "info exists tcl_prompt1"]} {
 326             consoleinterp eval "eval \[set tcl_prompt1\]"
 327         } else {
 328             puts -nonewline [EvalAttached $::tk::console::defaultPrompt]
 329         }
 330     } else {
 331         set temp [$w index output]
 332         $w mark set output end
 333         if {[consoleinterp eval "info exists tcl_prompt2"]} {
 334             consoleinterp eval "eval \[set tcl_prompt2\]"
 335         } else {
 336             puts -nonewline "> "
 337         }
 338     }
 339     flush stdout
 340     $w mark set output $temp
 341     ::tk::TextSetCursor $w end
 342     $w mark set promptEnd insert
 343     $w mark gravity promptEnd left
 344     ::tk::console::ConstrainBuffer $w $::tk::console::maxLines
 345     $w see end
 346 }
 347
 348 # Copy selected text from the console
 349 proc ::tk::console::Copy {w} {
 350     if {![catch {set data [$w get sel.first sel.last]}]} {
 351         clipboard clear -displayof $w
 352         clipboard append -displayof $w $data
 353     }
 354 }
 355 # Copies selected text. If the selection is within the current active edit
 356 # region then it will be cut, if not it is only copied.
 357 proc ::tk::console::Cut {w} {
 358     if {![catch {set data [$w get sel.first sel.last]}]} {
 359         clipboard clear -displayof $w
 360         clipboard append -displayof $w $data
 361         if {[$w compare sel.first >= output]} {
 362             $w delete sel.first sel.last
 363         }
 364     }
 365 }
 366 # Paste text from the clipboard
 367 proc ::tk::console::Paste {w} {
 368     catch {
 369         set clip [::tk::GetSelection $w CLIPBOARD]
 370         set list [split $clip \n\r]
 371         tk::ConsoleInsert $w [lindex $list 0]
 372         foreach x [lrange $list 1 end] {
 373             $w mark set insert {end - 1c}
 374             tk::ConsoleInsert $w "\n"
 375             tk::ConsoleInvoke
 376             tk::ConsoleInsert $w $x
 377         }
 378     }
 379 }
 380
 381 # ::tk::ConsoleBind --
 382 # This procedure first ensures that the default bindings for the Text
 383 # class have been defined.  Then certain bindings are overridden for
 384 # the class.
 385 #
 386 # Arguments:
 387 # None.
 388
 389 proc ::tk::ConsoleBind {w} {
 390     bindtags $w [list $w Console PostConsole [winfo toplevel $w] all]
 391
 392     ## Get all Text bindings into Console
 393     foreach ev [bind Text] {
 394         bind Console $ev [bind Text $ev]
 395     }
 396     ## We really didn't want the newline insertion...
 397     bind Console <Control-Key-o> {}
 398     ## ...or any Control-v binding (would block <<Paste>>)
 399     bind Console <Control-Key-v> {}
 400
 401     # For the moment, transpose isn't enabled until the console
 402     # gets and overhaul of how it handles input -- hobbs
 403     bind Console <Control-Key-t> {}
 404
 405     # Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
 406     # Otherwise, if a widget binding for one of these is defined, the
 407     # <Keypress> class binding will also fire and insert the character
 408     # which is wrong.
 409
 410     bind Console <Alt-KeyPress> {# nothing }
 411     bind Console <Meta-KeyPress> {# nothing}
 412     bind Console <Control-KeyPress> {# nothing}
 413
 414     foreach {ev key} {
 415         <<Console_NextImmediate>>       <Control-Key-n>
 416         <<Console_PrevImmediate>>       <Control-Key-p>
 417         <<Console_PrevSearch>>          <Control-Key-r>
 418         <<Console_NextSearch>>          <Control-Key-s>
 419
 420         <<Console_Expand>>              <Key-Tab>
 421         <<Console_Expand>>              <Key-Escape>
 422         <<Console_ExpandFile>>          <Control-Shift-Key-F>
 423         <<Console_ExpandProc>>          <Control-Shift-Key-P>
 424         <<Console_ExpandVar>>           <Control-Shift-Key-V>
 425         <<Console_Tab>>                 <Control-Key-i>
 426         <<Console_Tab>>                 <Meta-Key-i>
 427         <<Console_Eval>>                <Key-Return>
 428         <<Console_Eval>>                <Key-KP_Enter>
 429
 430         <<Console_Clear>>               <Control-Key-l>
 431         <<Console_KillLine>>            <Control-Key-k>
 432         <<Console_Transpose>>           <Control-Key-t>
 433         <<Console_ClearLine>>           <Control-Key-u>
 434         <<Console_SaveCommand>>         <Control-Key-z>
 435         <<Console_FontSizeIncr>>        <Control-Key-plus>
 436         <<Console_FontSizeDecr>>        <Control-Key-minus>
 437     } {
 438         event add $ev $key
 439         bind Console $key {}
 440     }
 441     if {[tk windowingsystem] eq "aqua"} {
 442         foreach {ev key} {
 443             <<Console_FontSizeIncr>>    <Command-Key-plus>
 444             <<Console_FontSizeDecr>>    <Command-Key-minus>
 445         } {
 446             event add $ev $key
 447             bind Console $key {}
 448         }
 449         if {$::tk::console::useFontchooser} {
 450             bind Console <Command-Key-t> [list ::tk::console::FontchooserToggle]
 451         }
 452     }
 453     bind Console <<Console_Expand>> {
 454         if {[%W compare insert > promptEnd]} {
 455             ::tk::console::Expand %W
 456         }
 457     }
 458     bind Console <<Console_ExpandFile>> {
 459         if {[%W compare insert > promptEnd]} {
 460             ::tk::console::Expand %W path
 461         }
 462     }
 463     bind Console <<Console_ExpandProc>> {
 464         if {[%W compare insert > promptEnd]} {
 465             ::tk::console::Expand %W proc
 466         }
 467     }
 468     bind Console <<Console_ExpandVar>> {
 469         if {[%W compare insert > promptEnd]} {
 470             ::tk::console::Expand %W var
 471         }
 472     }
 473     bind Console <<Console_Eval>> {
 474         %W mark set insert {end - 1c}
 475         tk::ConsoleInsert %W "\n"
 476         tk::ConsoleInvoke
 477         break
 478     }
 479     bind Console <Delete> {
 480         if {{} ne [%W tag nextrange sel 1.0 end] \
 481                 && [%W compare sel.first >= promptEnd]} {
 482             %W delete sel.first sel.last
 483         } elseif {[%W compare insert >= promptEnd]} {
 484             %W delete insert
 485             %W see insert
 486         }
 487     }
 488     bind Console <BackSpace> {
 489         if {{} ne [%W tag nextrange sel 1.0 end] \
 490                 && [%W compare sel.first >= promptEnd]} {
 491             %W delete sel.first sel.last
 492         } elseif {[%W compare insert != 1.0] && \
 493                 [%W compare insert > promptEnd]} {
 494             %W delete insert-1c
 495             %W see insert
 496         }
 497     }
 498     bind Console <Control-h> [bind Console <BackSpace>]
 499
 500     bind Console <<LineStart>> {
 501         if {[%W compare insert < promptEnd]} {
 502             tk::TextSetCursor %W {insert linestart}
 503         } else {
 504             tk::TextSetCursor %W promptEnd
 505         }
 506     }
 507     bind Console <<LineEnd>> {
 508         tk::TextSetCursor %W {insert lineend}
 509     }
 510     bind Console <Control-d> {
 511         if {[%W compare insert < promptEnd]} {
 512             break
 513         }
 514         %W delete insert
 515     }
 516     bind Console <<Console_KillLine>> {
 517         if {[%W compare insert < promptEnd]} {
 518             break
 519         }
 520         if {[%W compare insert == {insert lineend}]} {
 521             %W delete insert
 522         } else {
 523             %W delete insert {insert lineend}
 524         }
 525     }
 526     bind Console <<Console_Clear>> {
 527         ## Clear console display
 528         %W delete 1.0 "promptEnd linestart"
 529     }
 530     bind Console <<Console_ClearLine>> {
 531         ## Clear command line (Unix shell staple)
 532         %W delete promptEnd end
 533     }
 534     bind Console <Meta-d> {
 535         if {[%W compare insert >= promptEnd]} {
 536             %W delete insert {insert wordend}
 537         }
 538     }
 539     bind Console <Meta-BackSpace> {
 540         if {[%W compare {insert -1c wordstart} >= promptEnd]} {
 541             %W delete {insert -1c wordstart} insert
 542         }
 543     }
 544     bind Console <Meta-d> {
 545         if {[%W compare insert >= promptEnd]} {
 546             %W delete insert {insert wordend}
 547         }
 548     }
 549     bind Console <Meta-BackSpace> {
 550         if {[%W compare {insert -1c wordstart} >= promptEnd]} {
 551             %W delete {insert -1c wordstart} insert
 552         }
 553     }
 554     bind Console <Meta-Delete> {
 555         if {[%W compare insert >= promptEnd]} {
 556             %W delete insert {insert wordend}
 557         }
 558     }
 559     bind Console <<PrevLine>> {
 560         tk::ConsoleHistory prev
 561     }
 562     bind Console <<NextLine>> {
 563         tk::ConsoleHistory next
 564     }
 565     bind Console <Insert> {
 566         catch {tk::ConsoleInsert %W [::tk::GetSelection %W PRIMARY]}
 567     }
 568     bind Console <KeyPress> {
 569         tk::ConsoleInsert %W %A
 570     }
 571     bind Console <F9> {
 572         eval destroy [winfo child .]
 573         source [file join $tk_library console.tcl]
 574     }
 575     if {[tk windowingsystem] eq "aqua"} {
 576         bind Console <Command-q> {
 577             exit
 578         }
 579     }
 580     bind Console <<Cut>> { ::tk::console::Cut %W }
 581     bind Console <<Copy>> { ::tk::console::Copy %W }
 582     bind Console <<Paste>> { ::tk::console::Paste %W }
 583
 584     bind Console <<Console_FontSizeIncr>> {
 585         set size [font configure TkConsoleFont -size]
 586         if {$size < 0} {set sign -1} else {set sign 1}
 587         set size [expr {(abs($size) + 1) * $sign}]
 588         font configure TkConsoleFont -size $size
 589         if {$::tk::console::useFontchooser} {
 590             tk fontchooser configure -font TkConsoleFont
 591         }
 592     }
 593     bind Console <<Console_FontSizeDecr>> {
 594         set size [font configure TkConsoleFont -size]
 595         if {abs($size) < 2} { return }
 596         if {$size < 0} {set sign -1} else {set sign 1}
 597         set size [expr {(abs($size) - 1) * $sign}]
 598         font configure TkConsoleFont -size $size
 599         if {$::tk::console::useFontchooser} {
 600             tk fontchooser configure -font TkConsoleFont
 601         }
 602     }
 603
 604     ##
 605     ## Bindings for doing special things based on certain keys
 606     ##
 607     bind PostConsole <Key-parenright> {
 608         if {"\\" ne [%W get insert-2c]} {
 609             ::tk::console::MatchPair %W \( \) promptEnd
 610         }
 611     }
 612     bind PostConsole <Key-bracketright> {
 613         if {"\\" ne [%W get insert-2c]} {
 614             ::tk::console::MatchPair %W \[ \] promptEnd
 615         }
 616     }
 617     bind PostConsole <Key-braceright> {
 618         if {"\\" ne [%W get insert-2c]} {
 619             ::tk::console::MatchPair %W \{ \} promptEnd
 620         }
 621     }
 622     bind PostConsole <Key-quotedbl> {
 623         if {"\\" ne [%W get insert-2c]} {
 624             ::tk::console::MatchQuote %W promptEnd
 625         }
 626     }
 627
 628     bind PostConsole <KeyPress> {
 629         if {"%A" ne ""} {
 630             ::tk::console::TagProc %W
 631         }
 632     }
 633 }
 634
 635 # ::tk::ConsoleInsert --
 636 # Insert a string into a text at the point of the insertion cursor.
 637 # If there is a selection in the text, and it covers the point of the
 638 # insertion cursor, then delete the selection before inserting.  Insertion
 639 # is restricted to the prompt area.
 640 #
 641 # Arguments:
 642 # w -           The text window in which to insert the string
 643 # s -           The string to insert (usually just a single character)
 644
 645 proc ::tk::ConsoleInsert {w s} {
 646     if {$s eq ""} {
 647         return
 648     }
 649     catch {
 650         if {[$w compare sel.first <= insert] \
 651                 && [$w compare sel.last >= insert]} {
 652             $w tag remove sel sel.first promptEnd
 653             $w delete sel.first sel.last
 654         }
 655     }
 656     if {[$w compare insert < promptEnd]} {
 657         $w mark set insert end
 658     }
 659     $w insert insert $s {input stdin}
 660     $w see insert
 661 }
 662
 663 # ::tk::ConsoleOutput --
 664 #
 665 # This routine is called directly by ConsolePutsCmd to cause a string
 666 # to be displayed in the console.
 667 #
 668 # Arguments:
 669 # dest -        The output tag to be used: either "stderr" or "stdout".
 670 # string -      The string to be displayed.
 671
 672 proc ::tk::ConsoleOutput {dest string} {
 673     set w .console
 674     $w insert output $string $dest
 675     ::tk::console::ConstrainBuffer $w $::tk::console::maxLines
 676     $w see insert
 677 }
 678
 679 # ::tk::ConsoleExit --
 680 #
 681 # This routine is called by ConsoleEventProc when the main window of
 682 # the application is destroyed.  Don't call exit - that probably already
 683 # happened.  Just delete our window.
 684 #
 685 # Arguments:
 686 # None.
 687
 688 proc ::tk::ConsoleExit {} {
 689     destroy .
 690 }
 691
 692 # ::tk::ConsoleAbout --
 693 #
 694 # This routine displays an About box to show Tcl/Tk version info.
 695 #
 696 # Arguments:
 697 # None.
 698
 699 proc ::tk::ConsoleAbout {} {
 700     tk_messageBox -type ok -message "[mc {Tcl for Windows}]
 701
 702 Tcl $::tcl_patchLevel
 703 Tk $::tk_patchLevel"
 704 }
 705
 706 # ::tk::console::Fontchooser* --
 707 #       Let the user select the console font (TIP 324).
 708
 709 proc ::tk::console::FontchooserToggle {} {
 710     if {[tk fontchooser configure -visible]} {
 711         tk fontchooser hide
 712     } else {
 713         tk fontchooser show
 714     }
 715 }
 716 proc ::tk::console::FontchooserVisibility {index} {
 717     if {[tk fontchooser configure -visible]} {
 718         .menubar.edit entryconfigure $index -label [msgcat::mc "Hide Fonts"]
 719     } else {
 720         .menubar.edit entryconfigure $index -label [msgcat::mc "Show Fonts"]
 721     }
 722 }
 723 proc ::tk::console::FontchooserFocus {w isFocusIn} {
 724     if {$isFocusIn} {
 725         tk fontchooser configure -parent $w -font TkConsoleFont \
 726                 -command [namespace code [list FontchooserApply]]
 727     } else {
 728         tk fontchooser configure -parent $w -font {} -command {}
 729     }
 730 }
 731 proc ::tk::console::FontchooserApply {font args} {
 732     catch {font configure TkConsoleFont {*}[font actual $font]}
 733 }
 734
 735 # ::tk::console::TagProc --
 736 #
 737 # Tags a procedure in the console if it's recognized
 738 # This procedure is not perfect.  However, making it perfect wastes
 739 # too much CPU time...
 740 #
 741 # Arguments:
 742 #       w       - console text widget
 743
 744 proc ::tk::console::TagProc w {
 745     if {!$::tk::console::magicKeys} {
 746         return
 747     }
 748     set exp "\[^\\\\\]\[\[ \t\n\r\;{}\"\$\]"
 749     set i [$w search -backwards -regexp $exp insert-1c promptEnd-1c]
 750     if {$i eq ""} {
 751         set i promptEnd
 752     } else {
 753         append i +2c
 754     }
 755     regsub -all "\[\[\\\\\\?\\*\]" [$w get $i "insert-1c wordend"] {\\\0} c
 756     if {[llength [EvalAttached [list info commands $c]]]} {
 757         $w tag add proc $i "insert-1c wordend"
 758     } else {
 759         $w tag remove proc $i "insert-1c wordend"
 760     }
 761     if {[llength [EvalAttached [list info vars $c]]]} {
 762         $w tag add var $i "insert-1c wordend"
 763     } else {
 764         $w tag remove var $i "insert-1c wordend"
 765     }
 766 }
 767
 768 # ::tk::console::MatchPair --
 769 #
 770 # Blinks a matching pair of characters
 771 # c2 is assumed to be at the text index 'insert'.
 772 # This proc is really loopy and took me an hour to figure out given
 773 # all possible combinations with escaping except for escaped \'s.
 774 # It doesn't take into account possible commenting... Oh well.  If
 775 # anyone has something better, I'd like to see/use it.  This is really
 776 # only efficient for small contexts.
 777 #
 778 # Arguments:
 779 #       w       - console text widget
 780 #       c1      - first char of pair
 781 #       c2      - second char of pair
 782 #
 783 # Calls:        ::tk::console::Blink
 784
 785 proc ::tk::console::MatchPair {w c1 c2 {lim 1.0}} {
 786     if {!$::tk::console::magicKeys} {
 787         return
 788     }
 789     if {{} ne [set ix [$w search -back $c1 insert $lim]]} {
 790         while {
 791             [string match {\\} [$w get $ix-1c]] &&
 792             [set ix [$w search -back $c1 $ix-1c $lim]] ne {}
 793         } {}
 794         set i1 insert-1c
 795         while {$ix ne {}} {
 796             set i0 $ix
 797             set j 0
 798             while {[set i0 [$w search $c2 $i0 $i1]] ne {}} {
 799                 append i0 +1c
 800                 if {[string match {\\} [$w get $i0-2c]]} {
 801                     continue
 802                 }
 803                 incr j
 804             }
 805             if {!$j} {
 806                 break
 807             }
 808             set i1 $ix
 809             while {$j && [set ix [$w search -back $c1 $ix $lim]] ne {}} {
 810                 if {[string match {\\} [$w get $ix-1c]]} {
 811                     continue
 812                 }
 813                 incr j -1
 814             }
 815         }
 816         if {[string match {} $ix]} {
 817             set ix [$w index $lim]
 818         }
 819     } else {
 820         set ix [$w index $lim]
 821     }
 822     if {$::tk::console::blinkRange} {
 823         Blink $w $ix [$w index insert]
 824     } else {
 825         Blink $w $ix $ix+1c [$w index insert-1c] [$w index insert]
 826     }
 827 }
 828
 829 # ::tk::console::MatchQuote --
 830 #
 831 # Blinks between matching quotes.
 832 # Blinks just the quote if it's unmatched, otherwise blinks quoted string
 833 # The quote to match is assumed to be at the text index 'insert'.
 834 #
 835 # Arguments:
 836 #       w       - console text widget
 837 #
 838 # Calls:        ::tk::console::Blink
 839
 840 proc ::tk::console::MatchQuote {w {lim 1.0}} {
 841     if {!$::tk::console::magicKeys} {
 842         return
 843     }
 844     set i insert-1c
 845     set j 0
 846     while {[set i [$w search -back \" $i $lim]] ne {}} {
 847         if {[string match {\\} [$w get $i-1c]]} {
 848             continue
 849         }
 850         if {!$j} {
 851             set i0 $i
 852         }
 853         incr j
 854     }
 855     if {$j&1} {
 856         if {$::tk::console::blinkRange} {
 857             Blink $w $i0 [$w index insert]
 858         } else {
 859             Blink $w $i0 $i0+1c [$w index insert-1c] [$w index insert]
 860         }
 861     } else {
 862         Blink $w [$w index insert-1c] [$w index insert]
 863     }
 864 }
 865
 866 # ::tk::console::Blink --
 867 #
 868 # Blinks between n index pairs for a specified duration.
 869 #
 870 # Arguments:
 871 #       w       - console text widget
 872 #       i1      - start index to blink region
 873 #       i2      - end index of blink region
 874 #       dur     - duration in usecs to blink for
 875 #
 876 # Outputs:
 877 #       blinks selected characters in $w
 878
 879 proc ::tk::console::Blink {w args} {
 880     eval [list $w tag add blink] $args
 881     after $::tk::console::blinkTime [list $w] tag remove blink $args
 882 }
 883
 884 # ::tk::console::ConstrainBuffer --
 885 #
 886 # This limits the amount of data in the text widget
 887 # Called by Prompt and ConsoleOutput
 888 #
 889 # Arguments:
 890 #       w       - console text widget
 891 #       size    - # of lines to constrain to
 892 #
 893 # Outputs:
 894 #       may delete data in console widget
 895
 896 proc ::tk::console::ConstrainBuffer {w size} {
 897     if {[$w index end] > $size} {
 898         $w delete 1.0 [expr {int([$w index end])-$size}].0
 899     }
 900 }
 901
 902 # ::tk::console::Expand --
 903 #
 904 # Arguments:
 905 # ARGS: w       - text widget in which to expand str
 906 #       type    - type of expansion (path / proc / variable)
 907 #
 908 # Calls:        ::tk::console::Expand(Pathname|Procname|Variable)
 909 #
 910 # Outputs:      The string to match is expanded to the longest possible match.
 911 #               If ::tk::console::showMatches is non-zero and the longest match
 912 #               equaled the string to expand, then all possible matches are
 913 #               output to stdout.  Triggers bell if no matches are found.
 914 #
 915 # Returns:      number of matches found
 916
 917 proc ::tk::console::Expand {w {type ""}} {
 918     set exp "\[^\\\\\]\[\[ \t\n\r\\\{\"\\\\\$\]"
 919     set tmp [$w search -backwards -regexp $exp insert-1c promptEnd-1c]
 920     if {$tmp eq ""} {
 921         set tmp promptEnd
 922     } else {
 923         append tmp +2c
 924     }
 925     if {[$w compare $tmp >= insert]} {
 926         return
 927     }
 928     set str [$w get $tmp insert]
 929     switch -glob $type {
 930         path* {
 931             set res [ExpandPathname $str]
 932         }
 933         proc* {
 934             set res [ExpandProcname $str]
 935         }
 936         var* {
 937             set res [ExpandVariable $str]
 938         }
 939         default {
 940             set res {}
 941             foreach t {Pathname Procname Variable} {
 942                 if {![catch {Expand$t $str} res] && ($res ne "")} {
 943                     break
 944                 }
 945             }
 946         }
 947     }
 948     set len [llength $res]
 949     if {$len} {
 950         set repl [lindex $res 0]
 951         $w delete $tmp insert
 952         $w insert $tmp $repl {input stdin}
 953         if {($len > 1) && ($::tk::console::showMatches) && ($repl eq $str)} {
 954             puts stdout [lsort [lreplace $res 0 0]]
 955         }
 956     } else {
 957         bell
 958     }
 959     return [incr len -1]
 960 }
 961
 962 # ::tk::console::ExpandPathname --
 963 #
 964 # Expand a file pathname based on $str
 965 # This is based on UNIX file name conventions
 966 #
 967 # Arguments:
 968 #       str     - partial file pathname to expand
 969 #
 970 # Calls:        ::tk::console::ExpandBestMatch
 971 #
 972 # Returns:      list containing longest unique match followed by all the
 973 #               possible further matches
 974
 975 proc ::tk::console::ExpandPathname str {
 976     set pwd [EvalAttached pwd]
 977     if {[catch {EvalAttached [list cd [file dirname $str]]} err opt]} {
 978         return -options $opt $err
 979     }
 980     set dir [file tail $str]
 981     ## Check to see if it was known to be a directory and keep the trailing
 982     ## slash if so (file tail cuts it off)
 983     if {[string match */ $str]} {
 984         append dir /
 985     }
 986     if {[catch {lsort [EvalAttached [list glob $dir*]]} m]} {
 987         set match {}
 988     } else {
 989         if {[llength $m] > 1} {
 990             global tcl_platform
 991             if {[string match windows $tcl_platform(platform)]} {
 992                 ## Windows is screwy because it's case insensitive
 993                 set tmp [ExpandBestMatch [string tolower $m] \
 994                         [string tolower $dir]]
 995                 ## Don't change case if we haven't changed the word
 996                 if {[string length $dir]==[string length $tmp]} {
 997                     set tmp $dir
 998                 }
 999             } else {
1000                 set tmp [ExpandBestMatch $m $dir]
1001             }
1002             if {[string match ?*/* $str]} {
1003                 set tmp [file dirname $str]/$tmp
1004             } elseif {[string match /* $str]} {
1005                 set tmp /$tmp
1006             }
1007             regsub -all { } $tmp {\\ } tmp
1008             set match [linsert $m 0 $tmp]
1009         } else {
1010             ## This may look goofy, but it handles spaces in path names
1011             eval append match $m
1012             if {[file isdir $match]} {
1013                 append match /
1014             }
1015             if {[string match ?*/* $str]} {
1016                 set match [file dirname $str]/$match
1017             } elseif {[string match /* $str]} {
1018                 set match /$match
1019             }
1020             regsub -all { } $match {\\ } match
1021             ## Why is this one needed and the ones below aren't!!
1022             set match [list $match]
1023         }
1024     }
1025     EvalAttached [list cd $pwd]
1026     return $match
1027 }
1028
1029 # ::tk::console::ExpandProcname --
1030 #
1031 # Expand a tcl proc name based on $str
1032 #
1033 # Arguments:
1034 #       str     - partial proc name to expand
1035 #
1036 # Calls:        ::tk::console::ExpandBestMatch
1037 #
1038 # Returns:      list containing longest unique match followed by all the
1039 #               possible further matches
1040
1041 proc ::tk::console::ExpandProcname str {
1042     set match [EvalAttached [list info commands $str*]]
1043     if {[llength $match] == 0} {
1044         set ns [EvalAttached \
1045                 "namespace children \[namespace current\] [list $str*]"]
1046         if {[llength $ns]==1} {
1047             set match [EvalAttached [list info commands ${ns}::*]]
1048         } else {
1049             set match $ns
1050         }
1051     }
1052     if {[llength $match] > 1} {
1053         regsub -all { } [ExpandBestMatch $match $str] {\\ } str
1054         set match [linsert $match 0 $str]
1055     } else {
1056         regsub -all { } $match {\\ } match
1057     }
1058     return $match
1059 }
1060
1061 # ::tk::console::ExpandVariable --
1062 #
1063 # Expand a tcl variable name based on $str
1064 #
1065 # Arguments:
1066 #       str     - partial tcl var name to expand
1067 #
1068 # Calls:        ::tk::console::ExpandBestMatch
1069 #
1070 # Returns:      list containing longest unique match followed by all the
1071 #               possible further matches
1072
1073 proc ::tk::console::ExpandVariable str {
1074     if {[regexp {([^\(]*)\((.*)} $str -> ary str]} {
1075         ## Looks like they're trying to expand an array.
1076         set match [EvalAttached [list array names $ary $str*]]
1077         if {[llength $match] > 1} {
1078             set vars $ary\([ExpandBestMatch $match $str]
1079             foreach var $match {
1080                 lappend vars $ary\($var\)
1081             }
1082             return $vars
1083         } elseif {[llength $match] == 1} {
1084             set match $ary\($match\)
1085         }
1086         ## Space transformation avoided for array names.
1087     } else {
1088         set match [EvalAttached [list info vars $str*]]
1089         if {[llength $match] > 1} {
1090             regsub -all { } [ExpandBestMatch $match $str] {\\ } str
1091             set match [linsert $match 0 $str]
1092         } else {
1093             regsub -all { } $match {\\ } match
1094         }
1095     }
1096     return $match
1097 }
1098
1099 # ::tk::console::ExpandBestMatch --
1100 #
1101 # Finds the best unique match in a list of names.
1102 # The extra $e in this argument allows us to limit the innermost loop a little
1103 # further.  This improves speed as $l becomes large or $e becomes long.
1104 #
1105 # Arguments:
1106 #       l       - list to find best unique match in
1107 #       e       - currently best known unique match
1108 #
1109 # Returns:      longest unique match in the list
1110
1111 proc ::tk::console::ExpandBestMatch {l {e {}}} {
1112     set ec [lindex $l 0]
1113     if {[llength $l]>1} {
1114         set e [expr {[string length $e] - 1}]
1115         set ei [expr {[string length $ec] - 1}]
1116         foreach l $l {
1117             while {$ei>=$e && [string first $ec $l]} {
1118                 set ec [string range $ec 0 [incr ei -1]]
1119             }
1120         }
1121     }
1122     return $ec
1123 }
1124
1125 # now initialize the console
1126 ::tk::ConsoleInit