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