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