console.tcl (32784B)
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