| 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.3 2005/05/31 04:58:00 hobbs Exp $ |
| 8 | # |
| 9 | # Copyright (c) 1995-1997 Sun Microsystems, Inc. |
| 10 | # Copyright (c) 1998-2000 Ajuba Solutions. |
| 11 | # |
| 12 | # See the file "license.terms" for information on usage and redistribution |
| 13 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
| 14 | # |
| 15 | |
| 16 | # TODO: history - remember partially written command |
| 17 | |
| 18 | namespace eval ::tk::console { |
| 19 | variable blinkTime 500 ; # msecs to blink braced range for |
| 20 | variable blinkRange 1 ; # enable blinking of the entire braced range |
| 21 | variable magicKeys 1 ; # enable brace matching and proc/var recognition |
| 22 | variable maxLines 600 ; # maximum # of lines buffered in console |
| 23 | variable showMatches 1 ; # show multiple expand matches |
| 24 | |
| 25 | variable inPlugin [info exists embed_args] |
| 26 | variable defaultPrompt ; # default prompt if tcl_prompt1 isn't used |
| 27 | |
| 28 | |
| 29 | if {$inPlugin} { |
| 30 | set defaultPrompt {subst {[history nextid] % }} |
| 31 | } else { |
| 32 | set defaultPrompt {subst {([file tail [pwd]]) [history nextid] % }} |
| 33 | } |
| 34 | } |
| 35 | |
| 36 | # simple compat function for tkcon code added for this console |
| 37 | interp alias {} EvalAttached {} consoleinterp eval |
| 38 | |
| 39 | # ::tk::ConsoleInit -- |
| 40 | # This procedure constructs and configures the console windows. |
| 41 | # |
| 42 | # Arguments: |
| 43 | # None. |
| 44 | |
| 45 | proc ::tk::ConsoleInit {} { |
| 46 | global tcl_platform |
| 47 | |
| 48 | if {![consoleinterp eval {set tcl_interactive}]} { |
| 49 | wm withdraw . |
| 50 | } |
| 51 | |
| 52 | if {[string equal $tcl_platform(platform) "macintosh"] |
| 53 | || [string equal [tk windowingsystem] "aqua"]} { |
| 54 | set mod "Cmd" |
| 55 | } else { |
| 56 | set mod "Ctrl" |
| 57 | } |
| 58 | |
| 59 | if {[catch {menu .menubar} err]} { bgerror "INIT: $err" } |
| 60 | .menubar add cascade -label File -menu .menubar.file -underline 0 |
| 61 | .menubar add cascade -label Edit -menu .menubar.edit -underline 0 |
| 62 | |
| 63 | menu .menubar.file -tearoff 0 |
| 64 | .menubar.file add command -label [mc "Source..."] \ |
| 65 | -underline 0 -command tk::ConsoleSource |
| 66 | .menubar.file add command -label [mc "Hide Console"] \ |
| 67 | -underline 0 -command {wm withdraw .} |
| 68 | .menubar.file add command -label [mc "Clear Console"] \ |
| 69 | -underline 0 -command {.console delete 1.0 "promptEnd linestart"} |
| 70 | if {[string equal $tcl_platform(platform) "macintosh"] |
| 71 | || [string equal [tk windowingsystem] "aqua"]} { |
| 72 | .menubar.file add command -label [mc "Quit"] \ |
| 73 | -command exit -accel Cmd-Q |
| 74 | } else { |
| 75 | .menubar.file add command -label [mc "Exit"] \ |
| 76 | -underline 1 -command exit |
| 77 | } |
| 78 | |
| 79 | menu .menubar.edit -tearoff 0 |
| 80 | .menubar.edit add command -label [mc "Cut"] -underline 2 \ |
| 81 | -command { event generate .console <<Cut>> } -accel "$mod+X" |
| 82 | .menubar.edit add command -label [mc "Copy"] -underline 0 \ |
| 83 | -command { event generate .console <<Copy>> } -accel "$mod+C" |
| 84 | .menubar.edit add command -label [mc "Paste"] -underline 1 \ |
| 85 | -command { event generate .console <<Paste>> } -accel "$mod+V" |
| 86 | |
| 87 | if {[string compare $tcl_platform(platform) "windows"]} { |
| 88 | .menubar.edit add command -label [mc "Clear"] -underline 2 \ |
| 89 | -command { event generate .console <<Clear>> } |
| 90 | } else { |
| 91 | .menubar.edit add command -label [mc "Delete"] -underline 0 \ |
| 92 | -command { event generate .console <<Clear>> } -accel "Del" |
| 93 | |
| 94 | .menubar add cascade -label Help -menu .menubar.help -underline 0 |
| 95 | menu .menubar.help -tearoff 0 |
| 96 | .menubar.help add command -label [mc "About..."] \ |
| 97 | -underline 0 -command tk::ConsoleAbout |
| 98 | } |
| 99 | |
| 100 | . configure -menu .menubar |
| 101 | |
| 102 | set con [text .console -yscrollcommand [list .sb set] -setgrid true] |
| 103 | scrollbar .sb -command [list $con yview] |
| 104 | pack .sb -side right -fill both |
| 105 | pack $con -fill both -expand 1 -side left |
| 106 | switch -exact $tcl_platform(platform) { |
| 107 | "macintosh" { |
| 108 | $con configure -font {Monaco 9 normal} -highlightthickness 0 |
| 109 | } |
| 110 | "windows" { |
| 111 | $con configure -font systemfixed |
| 112 | } |
| 113 | "unix" { |
| 114 | if {[string equal [tk windowingsystem] "aqua"]} { |
| 115 | $con configure -font {Monaco 9 normal} -highlightthickness 0 |
| 116 | } |
| 117 | } |
| 118 | } |
| 119 | |
| 120 | ConsoleBind $con |
| 121 | |
| 122 | $con tag configure stderr -foreground red |
| 123 | $con tag configure stdin -foreground blue |
| 124 | $con tag configure prompt -foreground \#8F4433 |
| 125 | $con tag configure proc -foreground \#008800 |
| 126 | $con tag configure var -background \#FFC0D0 |
| 127 | $con tag raise sel |
| 128 | $con tag configure blink -background \#FFFF00 |
| 129 | $con tag configure find -background \#FFFF00 |
| 130 | |
| 131 | focus $con |
| 132 | |
| 133 | wm protocol . WM_DELETE_WINDOW { wm withdraw . } |
| 134 | wm title . [mc "Console"] |
| 135 | flush stdout |
| 136 | $con mark set output [$con index "end - 1 char"] |
| 137 | tk::TextSetCursor $con end |
| 138 | $con mark set promptEnd insert |
| 139 | $con mark gravity promptEnd left |
| 140 | |
| 141 | # A variant of ConsolePrompt to avoid a 'puts' call |
| 142 | set w $con |
| 143 | set temp [$w index "end - 1 char"] |
| 144 | $w mark set output end |
| 145 | if {![consoleinterp eval "info exists tcl_prompt1"]} { |
| 146 | set string [EvalAttached $::tk::console::defaultPrompt] |
| 147 | $w insert output $string stdout |
| 148 | } |
| 149 | $w mark set output $temp |
| 150 | ::tk::TextSetCursor $w end |
| 151 | $w mark set promptEnd insert |
| 152 | $w mark gravity promptEnd left |
| 153 | |
| 154 | if {$tcl_platform(platform) eq "windows"} { |
| 155 | # Subtle work-around to erase the '% ' that tclMain.c prints out |
| 156 | after idle [list $con delete 1.0 output] |
| 157 | } |
| 158 | } |
| 159 | |
| 160 | # ::tk::ConsoleSource -- |
| 161 | # |
| 162 | # Prompts the user for a file to source in the main interpreter. |
| 163 | # |
| 164 | # Arguments: |
| 165 | # None. |
| 166 | |
| 167 | proc ::tk::ConsoleSource {} { |
| 168 | set filename [tk_getOpenFile -defaultextension .tcl -parent . \ |
| 169 | -title [mc "Select a file to source"] \ |
| 170 | -filetypes [list \ |
| 171 | [list [mc "Tcl Scripts"] .tcl] \ |
| 172 | [list [mc "All Files"] *]]] |
| 173 | if {[string compare $filename ""]} { |
| 174 | set cmd [list source $filename] |
| 175 | if {[catch {consoleinterp eval $cmd} result]} { |
| 176 | ConsoleOutput stderr "$result\n" |
| 177 | } |
| 178 | } |
| 179 | } |
| 180 | |
| 181 | # ::tk::ConsoleInvoke -- |
| 182 | # Processes the command line input. If the command is complete it |
| 183 | # is evaled in the main interpreter. Otherwise, the continuation |
| 184 | # prompt is added and more input may be added. |
| 185 | # |
| 186 | # Arguments: |
| 187 | # None. |
| 188 | |
| 189 | proc ::tk::ConsoleInvoke {args} { |
| 190 | set ranges [.console tag ranges input] |
| 191 | set cmd "" |
| 192 | if {[llength $ranges]} { |
| 193 | set pos 0 |
| 194 | while {[string compare [lindex $ranges $pos] ""]} { |
| 195 | set start [lindex $ranges $pos] |
| 196 | set end [lindex $ranges [incr pos]] |
| 197 | append cmd [.console get $start $end] |
| 198 | incr pos |
| 199 | } |
| 200 | } |
| 201 | if {[string equal $cmd ""]} { |
| 202 | ConsolePrompt |
| 203 | } elseif {[info complete $cmd]} { |
| 204 | .console mark set output end |
| 205 | .console tag delete input |
| 206 | set result [consoleinterp record $cmd] |
| 207 | if {[string compare $result ""]} { |
| 208 | puts $result |
| 209 | } |
| 210 | ConsoleHistory reset |
| 211 | ConsolePrompt |
| 212 | } else { |
| 213 | ConsolePrompt partial |
| 214 | } |
| 215 | .console yview -pickplace insert |
| 216 | } |
| 217 | |
| 218 | # ::tk::ConsoleHistory -- |
| 219 | # This procedure implements command line history for the |
| 220 | # console. In general is evals the history command in the |
| 221 | # main interpreter to obtain the history. The variable |
| 222 | # ::tk::HistNum is used to store the current location in the history. |
| 223 | # |
| 224 | # Arguments: |
| 225 | # cmd - Which action to take: prev, next, reset. |
| 226 | |
| 227 | set ::tk::HistNum 1 |
| 228 | proc ::tk::ConsoleHistory {cmd} { |
| 229 | variable HistNum |
| 230 | |
| 231 | switch $cmd { |
| 232 | prev { |
| 233 | incr HistNum -1 |
| 234 | if {$HistNum == 0} { |
| 235 | set cmd {history event [expr {[history nextid] -1}]} |
| 236 | } else { |
| 237 | set cmd "history event $HistNum" |
| 238 | } |
| 239 | if {[catch {consoleinterp eval $cmd} cmd]} { |
| 240 | incr HistNum |
| 241 | return |
| 242 | } |
| 243 | .console delete promptEnd end |
| 244 | .console insert promptEnd $cmd {input stdin} |
| 245 | } |
| 246 | next { |
| 247 | incr HistNum |
| 248 | if {$HistNum == 0} { |
| 249 | set cmd {history event [expr {[history nextid] -1}]} |
| 250 | } elseif {$HistNum > 0} { |
| 251 | set cmd "" |
| 252 | set HistNum 1 |
| 253 | } else { |
| 254 | set cmd "history event $HistNum" |
| 255 | } |
| 256 | if {[string compare $cmd ""]} { |
| 257 | catch {consoleinterp eval $cmd} cmd |
| 258 | } |
| 259 | .console delete promptEnd end |
| 260 | .console insert promptEnd $cmd {input stdin} |
| 261 | } |
| 262 | reset { |
| 263 | set HistNum 1 |
| 264 | } |
| 265 | } |
| 266 | } |
| 267 | |
| 268 | # ::tk::ConsolePrompt -- |
| 269 | # This procedure draws the prompt. If tcl_prompt1 or tcl_prompt2 |
| 270 | # exists in the main interpreter it will be called to generate the |
| 271 | # prompt. Otherwise, a hard coded default prompt is printed. |
| 272 | # |
| 273 | # Arguments: |
| 274 | # partial - Flag to specify which prompt to print. |
| 275 | |
| 276 | proc ::tk::ConsolePrompt {{partial normal}} { |
| 277 | set w .console |
| 278 | if {[string equal $partial "normal"]} { |
| 279 | set temp [$w index "end - 1 char"] |
| 280 | $w mark set output end |
| 281 | if {[consoleinterp eval "info exists tcl_prompt1"]} { |
| 282 | consoleinterp eval "eval \[set tcl_prompt1\]" |
| 283 | } else { |
| 284 | puts -nonewline [EvalAttached $::tk::console::defaultPrompt] |
| 285 | } |
| 286 | } else { |
| 287 | set temp [$w index output] |
| 288 | $w mark set output end |
| 289 | if {[consoleinterp eval "info exists tcl_prompt2"]} { |
| 290 | consoleinterp eval "eval \[set tcl_prompt2\]" |
| 291 | } else { |
| 292 | puts -nonewline "> " |
| 293 | } |
| 294 | } |
| 295 | flush stdout |
| 296 | $w mark set output $temp |
| 297 | ::tk::TextSetCursor $w end |
| 298 | $w mark set promptEnd insert |
| 299 | $w mark gravity promptEnd left |
| 300 | ::tk::console::ConstrainBuffer $w $::tk::console::maxLines |
| 301 | $w see end |
| 302 | } |
| 303 | |
| 304 | # ::tk::ConsoleBind -- |
| 305 | # This procedure first ensures that the default bindings for the Text |
| 306 | # class have been defined. Then certain bindings are overridden for |
| 307 | # the class. |
| 308 | # |
| 309 | # Arguments: |
| 310 | # None. |
| 311 | |
| 312 | proc ::tk::ConsoleBind {w} { |
| 313 | bindtags $w [list $w Console PostConsole [winfo toplevel $w] all] |
| 314 | |
| 315 | ## Get all Text bindings into Console |
| 316 | foreach ev [bind Text] { bind Console $ev [bind Text $ev] } |
| 317 | ## We really didn't want the newline insertion... |
| 318 | bind Console <Control-Key-o> {} |
| 319 | ## ...or any Control-v binding (would block <<Paste>>) |
| 320 | bind Console <Control-Key-v> {} |
| 321 | |
| 322 | # For the moment, transpose isn't enabled until the console |
| 323 | # gets and overhaul of how it handles input -- hobbs |
| 324 | bind Console <Control-Key-t> {} |
| 325 | |
| 326 | # Ignore all Alt, Meta, and Control keypresses unless explicitly bound. |
| 327 | # Otherwise, if a widget binding for one of these is defined, the |
| 328 | |
| 329 | bind Console <Alt-KeyPress> {# nothing } |
| 330 | bind Console <Meta-KeyPress> {# nothing} |
| 331 | bind Console <Control-KeyPress> {# nothing} |
| 332 | |
| 333 | foreach {ev key} { |
| 334 | <<Console_Prev>> <Key-Up> |
| 335 | <<Console_Next>> <Key-Down> |
| 336 | <<Console_NextImmediate>> <Control-Key-n> |
| 337 | <<Console_PrevImmediate>> <Control-Key-p> |
| 338 | <<Console_PrevSearch>> <Control-Key-r> |
| 339 | <<Console_NextSearch>> <Control-Key-s> |
| 340 | |
| 341 | <<Console_Expand>> <Key-Tab> |
| 342 | <<Console_Expand>> <Key-Escape> |
| 343 | <<Console_ExpandFile>> <Control-Shift-Key-F> |
| 344 | <<Console_ExpandProc>> <Control-Shift-Key-P> |
| 345 | <<Console_ExpandVar>> <Control-Shift-Key-V> |
| 346 | <<Console_Tab>> <Control-Key-i> |
| 347 | <<Console_Tab>> <Meta-Key-i> |
| 348 | <<Console_Eval>> <Key-Return> |
| 349 | <<Console_Eval>> <Key-KP_Enter> |
| 350 | |
| 351 | <<Console_Clear>> <Control-Key-l> |
| 352 | <<Console_KillLine>> <Control-Key-k> |
| 353 | <<Console_Transpose>> <Control-Key-t> |
| 354 | <<Console_ClearLine>> <Control-Key-u> |
| 355 | <<Console_SaveCommand>> <Control-Key-z> |
| 356 | } { |
| 357 | event add $ev $key |
| 358 | bind Console $key {} |
| 359 | } |
| 360 | |
| 361 | bind Console <<Console_Expand>> { |
| 362 | if {[%W compare insert > promptEnd]} {::tk::console::Expand %W} |
| 363 | } |
| 364 | bind Console <<Console_ExpandFile>> { |
| 365 | if {[%W compare insert > promptEnd]} {::tk::console::Expand %W path} |
| 366 | } |
| 367 | bind Console <<Console_ExpandProc>> { |
| 368 | if {[%W compare insert > promptEnd]} {::tk::console::Expand %W proc} |
| 369 | } |
| 370 | bind Console <<Console_ExpandVar>> { |
| 371 | if {[%W compare insert > promptEnd]} {::tk::console::Expand %W var} |
| 372 | } |
| 373 | bind Console <<Console_Eval>> { |
| 374 | %W mark set insert {end - 1c} |
| 375 | tk::ConsoleInsert %W "\n" |
| 376 | tk::ConsoleInvoke |
| 377 | break |
| 378 | } |
| 379 | bind Console <Delete> { |
| 380 | if {[string compare {} [%W tag nextrange sel 1.0 end]] \ |
| 381 | && [%W compare sel.first >= promptEnd]} { |
| 382 | %W delete sel.first sel.last |
| 383 | } elseif {[%W compare insert >= promptEnd]} { |
| 384 | %W delete insert |
| 385 | %W see insert |
| 386 | } |
| 387 | } |
| 388 | bind Console <BackSpace> { |
| 389 | if {[string compare {} [%W tag nextrange sel 1.0 end]] \ |
| 390 | && [%W compare sel.first >= promptEnd]} { |
| 391 | %W delete sel.first sel.last |
| 392 | } elseif {[%W compare insert != 1.0] && \ |
| 393 | [%W compare insert > promptEnd]} { |
| 394 | %W delete insert-1c |
| 395 | %W see insert |
| 396 | } |
| 397 | } |
| 398 | bind Console <Control-h> [bind Console <BackSpace>] |
| 399 | |
| 400 | bind Console <Home> { |
| 401 | if {[%W compare insert < promptEnd]} { |
| 402 | tk::TextSetCursor %W {insert linestart} |
| 403 | } else { |
| 404 | tk::TextSetCursor %W promptEnd |
| 405 | } |
| 406 | } |
| 407 | bind Console <Control-a> [bind Console <Home>] |
| 408 | bind Console <End> { |
| 409 | tk::TextSetCursor %W {insert lineend} |
| 410 | } |
| 411 | bind Console <Control-e> [bind Console <End>] |
| 412 | bind Console <Control-d> { |
| 413 | if {[%W compare insert < promptEnd]} break |
| 414 | %W delete insert |
| 415 | } |
| 416 | bind Console <<Console_KillLine>> { |
| 417 | if {[%W compare insert < promptEnd]} break |
| 418 | if {[%W compare insert == {insert lineend}]} { |
| 419 | %W delete insert |
| 420 | } else { |
| 421 | %W delete insert {insert lineend} |
| 422 | } |
| 423 | } |
| 424 | bind Console <<Console_Clear>> { |
| 425 | ## Clear console display |
| 426 | %W delete 1.0 "promptEnd linestart" |
| 427 | } |
| 428 | bind Console <<Console_ClearLine>> { |
| 429 | ## Clear command line (Unix shell staple) |
| 430 | %W delete promptEnd end |
| 431 | } |
| 432 | bind Console <Meta-d> { |
| 433 | if {[%W compare insert >= promptEnd]} { |
| 434 | %W delete insert {insert wordend} |
| 435 | } |
| 436 | } |
| 437 | bind Console <Meta-BackSpace> { |
| 438 | if {[%W compare {insert -1c wordstart} >= promptEnd]} { |
| 439 | %W delete {insert -1c wordstart} insert |
| 440 | } |
| 441 | } |
| 442 | bind Console <Meta-d> { |
| 443 | if {[%W compare insert >= promptEnd]} { |
| 444 | %W delete insert {insert wordend} |
| 445 | } |
| 446 | } |
| 447 | bind Console <Meta-BackSpace> { |
| 448 | if {[%W compare {insert -1c wordstart} >= promptEnd]} { |
| 449 | %W delete {insert -1c wordstart} insert |
| 450 | } |
| 451 | } |
| 452 | bind Console <Meta-Delete> { |
| 453 | if {[%W compare insert >= promptEnd]} { |
| 454 | %W delete insert {insert wordend} |
| 455 | } |
| 456 | } |
| 457 | bind Console <<Console_Prev>> { |
| 458 | tk::ConsoleHistory prev |
| 459 | } |
| 460 | bind Console <<Console_Next>> { |
| 461 | tk::ConsoleHistory next |
| 462 | } |
| 463 | bind Console <Insert> { |
| 464 | catch {tk::ConsoleInsert %W [::tk::GetSelection %W PRIMARY]} |
| 465 | } |
| 466 | bind Console <KeyPress> { |
| 467 | tk::ConsoleInsert %W %A |
| 468 | } |
| 469 | bind Console <F9> { |
| 470 | eval destroy [winfo child .] |
| 471 | if {[string equal $tcl_platform(platform) "macintosh"]} { |
| 472 | if {[catch {source [file join $tk_library console.tcl]}]} {source -rsrc console} |
| 473 | } else { |
| 474 | source [file join $tk_library console.tcl] |
| 475 | } |
| 476 | } |
| 477 | if {[string equal $::tcl_platform(platform) "macintosh"] |
| 478 | || [string equal [tk windowingsystem] "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 {[string compare \\ [%W get insert-2c]]} { |
| 515 | ::tk::console::MatchPair %W \( \) promptEnd |
| 516 | } |
| 517 | } |
| 518 | bind PostConsole <Key-bracketright> { |
| 519 | if {[string compare \\ [%W get insert-2c]]} { |
| 520 | ::tk::console::MatchPair %W \[ \] promptEnd |
| 521 | } |
| 522 | } |
| 523 | bind PostConsole <Key-braceright> { |
| 524 | if {[string compare \\ [%W get insert-2c]]} { |
| 525 | ::tk::console::MatchPair %W \{ \} promptEnd |
| 526 | } |
| 527 | } |
| 528 | bind PostConsole <Key-quotedbl> { |
| 529 | if {[string compare \\ [%W get insert-2c]]} { |
| 530 | ::tk::console::MatchQuote %W promptEnd |
| 531 | } |
| 532 | } |
| 533 | |
| 534 | bind PostConsole <KeyPress> { |
| 535 | if {"%A" != ""} { |
| 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 | |
| 552 | proc ::tk::ConsoleInsert {w s} { |
| 553 | if {[string equal $s ""]} { |
| 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 | |
| 579 | proc ::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 | |
| 595 | proc ::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 | |
| 606 | proc ::tk::ConsoleAbout {} { |
| 607 | tk_messageBox -type ok -message "[mc {Tcl for Windows}] |
| 608 | |
| 609 | Tcl $::tcl_patchLevel |
| 610 | Tk $::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 | |
| 622 | proc ::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 == ""} {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 | |
| 657 | proc ::tk::console::MatchPair {w c1 c2 {lim 1.0}} { |
| 658 | if {!$::tk::console::magicKeys} { return } |
| 659 | if {[string compare {} [set ix [$w search -back $c1 insert $lim]]]} { |
| 660 | while { |
| 661 | [string match {\\} [$w get $ix-1c]] && |
| 662 | [string compare {} [set ix [$w search -back $c1 $ix-1c $lim]]] |
| 663 | } {} |
| 664 | set i1 insert-1c |
| 665 | while {[string compare {} $ix]} { |
| 666 | set i0 $ix |
| 667 | set j 0 |
| 668 | while {[string compare {} [set i0 [$w search $c2 $i0 $i1]]]} { |
| 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 && [string compare {} \ |
| 676 | [set ix [$w search -back $c1 $ix $lim]]]} { |
| 677 | if {[string match {\\} [$w get $ix-1c]]} continue |
| 678 | incr j -1 |
| 679 | } |
| 680 | } |
| 681 | if {[string match {} $ix]} { set ix [$w index $lim] } |
| 682 | } else { set ix [$w index $lim] } |
| 683 | if {$::tk::console::blinkRange} { |
| 684 | Blink $w $ix [$w index insert] |
| 685 | } else { |
| 686 | Blink $w $ix $ix+1c [$w index insert-1c] [$w index insert] |
| 687 | } |
| 688 | } |
| 689 | |
| 690 | # ::tk::console::MatchQuote -- |
| 691 | # |
| 692 | # Blinks between matching quotes. |
| 693 | # Blinks just the quote if it's unmatched, otherwise blinks quoted string |
| 694 | # The quote to match is assumed to be at the text index 'insert'. |
| 695 | # |
| 696 | # Arguments: |
| 697 | # w - console text widget |
| 698 | # |
| 699 | # Calls: ::tk::console::Blink |
| 700 | |
| 701 | proc ::tk::console::MatchQuote {w {lim 1.0}} { |
| 702 | if {!$::tk::console::magicKeys} { return } |
| 703 | set i insert-1c |
| 704 | set j 0 |
| 705 | while {[string compare [set i [$w search -back \" $i $lim]] {}]} { |
| 706 | if {[string match {\\} [$w get $i-1c]]} continue |
| 707 | if {!$j} {set i0 $i} |
| 708 | incr j |
| 709 | } |
| 710 | if {$j&1} { |
| 711 | if {$::tk::console::blinkRange} { |
| 712 | Blink $w $i0 [$w index insert] |
| 713 | } else { |
| 714 | Blink $w $i0 $i0+1c [$w index insert-1c] [$w index insert] |
| 715 | } |
| 716 | } else { |
| 717 | Blink $w [$w index insert-1c] [$w index insert] |
| 718 | } |
| 719 | } |
| 720 | |
| 721 | # ::tk::console::Blink -- |
| 722 | # |
| 723 | # Blinks between n index pairs for a specified duration. |
| 724 | # |
| 725 | # Arguments: |
| 726 | # w - console text widget |
| 727 | # i1 - start index to blink region |
| 728 | # i2 - end index of blink region |
| 729 | # dur - duration in usecs to blink for |
| 730 | # |
| 731 | # Outputs: |
| 732 | # blinks selected characters in $w |
| 733 | |
| 734 | proc ::tk::console::Blink {w args} { |
| 735 | eval [list $w tag add blink] $args |
| 736 | after $::tk::console::blinkTime [list $w] tag remove blink $args |
| 737 | } |
| 738 | |
| 739 | # ::tk::console::ConstrainBuffer -- |
| 740 | # |
| 741 | # This limits the amount of data in the text widget |
| 742 | # Called by Prompt and ConsoleOutput |
| 743 | # |
| 744 | # Arguments: |
| 745 | # w - console text widget |
| 746 | # size - # of lines to constrain to |
| 747 | # |
| 748 | # Outputs: |
| 749 | # may delete data in console widget |
| 750 | |
| 751 | proc ::tk::console::ConstrainBuffer {w size} { |
| 752 | if {[$w index end] > $size} { |
| 753 | $w delete 1.0 [expr {int([$w index end])-$size}].0 |
| 754 | } |
| 755 | } |
| 756 | |
| 757 | # ::tk::console::Expand -- |
| 758 | # |
| 759 | # Arguments: |
| 760 | # ARGS: w - text widget in which to expand str |
| 761 | # type - type of expansion (path / proc / variable) |
| 762 | # |
| 763 | # Calls: ::tk::console::Expand(Pathname|Procname|Variable) |
| 764 | # |
| 765 | # Outputs: The string to match is expanded to the longest possible match. |
| 766 | # If ::tk::console::showMatches is non-zero and the longest match |
| 767 | # equaled the string to expand, then all possible matches are |
| 768 | # output to stdout. Triggers bell if no matches are found. |
| 769 | # |
| 770 | # Returns: number of matches found |
| 771 | |
| 772 | proc ::tk::console::Expand {w {type ""}} { |
| 773 | set exp "\[^\\\\\]\[\[ \t\n\r\\\{\"\\\\\$\]" |
| 774 | set tmp [$w search -backwards -regexp $exp insert-1c promptEnd-1c] |
| 775 | if {$tmp == ""} {set tmp promptEnd} else {append tmp +2c} |
| 776 | if {[$w compare $tmp >= insert]} { return } |
| 777 | set str [$w get $tmp insert] |
| 778 | switch -glob $type { |
| 779 | path* { set res [ExpandPathname $str] } |
| 780 | proc* { set res [ExpandProcname $str] } |
| 781 | var* { set res [ExpandVariable $str] } |
| 782 | default { |
| 783 | set res {} |
| 784 | foreach t {Pathname Procname Variable} { |
| 785 | if {![catch {Expand$t $str} res] && ($res != "")} { break } |
| 786 | } |
| 787 | } |
| 788 | } |
| 789 | set len [llength $res] |
| 790 | if {$len} { |
| 791 | set repl [lindex $res 0] |
| 792 | $w delete $tmp insert |
| 793 | $w insert $tmp $repl {input stdin} |
| 794 | if {($len > 1) && $::tk::console::showMatches \ |
| 795 | && [string equal $repl $str]} { |
| 796 | puts stdout [lsort [lreplace $res 0 0]] |
| 797 | } |
| 798 | } else { bell } |
| 799 | return [incr len -1] |
| 800 | } |
| 801 | |
| 802 | # ::tk::console::ExpandPathname -- |
| 803 | # |
| 804 | # Expand a file pathname based on $str |
| 805 | # This is based on UNIX file name conventions |
| 806 | # |
| 807 | # Arguments: |
| 808 | # str - partial file pathname to expand |
| 809 | # |
| 810 | # Calls: ::tk::console::ExpandBestMatch |
| 811 | # |
| 812 | # Returns: list containing longest unique match followed by all the |
| 813 | # possible further matches |
| 814 | |
| 815 | proc ::tk::console::ExpandPathname str { |
| 816 | set pwd [EvalAttached pwd] |
| 817 | if {[catch {EvalAttached [list cd [file dirname $str]]} err]} { |
| 818 | return -code error $err |
| 819 | } |
| 820 | set dir [file tail $str] |
| 821 | ## Check to see if it was known to be a directory and keep the trailing |
| 822 | ## slash if so (file tail cuts it off) |
| 823 | if {[string match */ $str]} { append dir / } |
| 824 | if {[catch {lsort [EvalAttached [list glob $dir*]]} m]} { |
| 825 | set match {} |
| 826 | } else { |
| 827 | if {[llength $m] > 1} { |
| 828 | global tcl_platform |
| 829 | if {[string match windows $tcl_platform(platform)]} { |
| 830 | ## Windows is screwy because it's case insensitive |
| 831 | set tmp [ExpandBestMatch [string tolower $m] \ |
| 832 | [string tolower $dir]] |
| 833 | ## Don't change case if we haven't changed the word |
| 834 | if {[string length $dir]==[string length $tmp]} { |
| 835 | set tmp $dir |
| 836 | } |
| 837 | } else { |
| 838 | set tmp [ExpandBestMatch $m $dir] |
| 839 | } |
| 840 | if {[string match ?*/* $str]} { |
| 841 | set tmp [file dirname $str]/$tmp |
| 842 | } elseif {[string match /* $str]} { |
| 843 | set tmp /$tmp |
| 844 | } |
| 845 | regsub -all { } $tmp {\\ } tmp |
| 846 | set match [linsert $m 0 $tmp] |
| 847 | } else { |
| 848 | ## This may look goofy, but it handles spaces in path names |
| 849 | eval append match $m |
| 850 | if {[file isdir $match]} {append match /} |
| 851 | if {[string match ?*/* $str]} { |
| 852 | set match [file dirname $str]/$match |
| 853 | } elseif {[string match /* $str]} { |
| 854 | set match /$match |
| 855 | } |
| 856 | regsub -all { } $match {\\ } match |
| 857 | ## Why is this one needed and the ones below aren't!! |
| 858 | set match [list $match] |
| 859 | } |
| 860 | } |
| 861 | EvalAttached [list cd $pwd] |
| 862 | return $match |
| 863 | } |
| 864 | |
| 865 | # ::tk::console::ExpandProcname -- |
| 866 | # |
| 867 | # Expand a tcl proc name based on $str |
| 868 | # |
| 869 | # Arguments: |
| 870 | # str - partial proc name to expand |
| 871 | # |
| 872 | # Calls: ::tk::console::ExpandBestMatch |
| 873 | # |
| 874 | # Returns: list containing longest unique match followed by all the |
| 875 | # possible further matches |
| 876 | |
| 877 | proc ::tk::console::ExpandProcname str { |
| 878 | set match [EvalAttached [list info commands $str*]] |
| 879 | if {[llength $match] == 0} { |
| 880 | set ns [EvalAttached \ |
| 881 | "namespace children \[namespace current\] [list $str*]"] |
| 882 | if {[llength $ns]==1} { |
| 883 | set match [EvalAttached [list info commands ${ns}::*]] |
| 884 | } else { |
| 885 | set match $ns |
| 886 | } |
| 887 | } |
| 888 | if {[llength $match] > 1} { |
| 889 | regsub -all { } [ExpandBestMatch $match $str] {\\ } str |
| 890 | set match [linsert $match 0 $str] |
| 891 | } else { |
| 892 | regsub -all { } $match {\\ } match |
| 893 | } |
| 894 | return $match |
| 895 | } |
| 896 | |
| 897 | # ::tk::console::ExpandVariable -- |
| 898 | # |
| 899 | # Expand a tcl variable name based on $str |
| 900 | # |
| 901 | # Arguments: |
| 902 | # str - partial tcl var name to expand |
| 903 | # |
| 904 | # Calls: ::tk::console::ExpandBestMatch |
| 905 | # |
| 906 | # Returns: list containing longest unique match followed by all the |
| 907 | # possible further matches |
| 908 | |
| 909 | proc ::tk::console::ExpandVariable str { |
| 910 | if {[regexp {([^\(]*)\((.*)} $str junk ary str]} { |
| 911 | ## Looks like they're trying to expand an array. |
| 912 | set match [EvalAttached [list array names $ary $str*]] |
| 913 | if {[llength $match] > 1} { |
| 914 | set vars $ary\([ExpandBestMatch $match $str] |
| 915 | foreach var $match {lappend vars $ary\($var\)} |
| 916 | return $vars |
| 917 | } elseif {[llength $match] == 1} { |
| 918 | set match $ary\($match\) |
| 919 | } |
| 920 | ## Space transformation avoided for array names. |
| 921 | } else { |
| 922 | set match [EvalAttached [list info vars $str*]] |
| 923 | if {[llength $match] > 1} { |
| 924 | regsub -all { } [ExpandBestMatch $match $str] {\\ } str |
| 925 | set match [linsert $match 0 $str] |
| 926 | } else { |
| 927 | regsub -all { } $match {\\ } match |
| 928 | } |
| 929 | } |
| 930 | return $match |
| 931 | } |
| 932 | |
| 933 | # ::tk::console::ExpandBestMatch -- |
| 934 | # |
| 935 | # Finds the best unique match in a list of names. |
| 936 | # The extra $e in this argument allows us to limit the innermost loop a little |
| 937 | # further. This improves speed as $l becomes large or $e becomes long. |
| 938 | # |
| 939 | # Arguments: |
| 940 | # l - list to find best unique match in |
| 941 | # e - currently best known unique match |
| 942 | # |
| 943 | # Returns: longest unique match in the list |
| 944 | |
| 945 | proc ::tk::console::ExpandBestMatch {l {e {}}} { |
| 946 | set ec [lindex $l 0] |
| 947 | if {[llength $l]>1} { |
| 948 | set e [string length $e]; incr e -1 |
| 949 | set ei [string length $ec]; incr ei -1 |
| 950 | foreach l $l { |
| 951 | while {$ei>=$e && [string first $ec $l]} { |
| 952 | set ec [string range $ec 0 [incr ei -1]] |
| 953 | } |
| 954 | } |
| 955 | } |
| 956 | return $ec |
| 957 | } |
| 958 | |
| 959 | # now initialize the console |
| 960 | ::tk::ConsoleInit |