CELLLINUX64/util/CELLLINUX64/lib/tk8.4/console.tcl

   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