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