home *** CD-ROM | disk | FTP | other *** search
/ PC World 2005 June / PCWorld_2005-06_cd.bin / software / vyzkuste / firewally / firewally.exe / framework-2.3.exe / console.tcl < prev    next >
Text File  |  2003-09-01  |  27KB  |  935 lines
  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.21 2002/08/31 06:12:28 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.     bind Console <<Cut>> {
  460.         # Same as the copy event
  461.      if {![catch {set data [%W get sel.first sel.last]}]} {
  462.         clipboard clear -displayof %W
  463.         clipboard append -displayof %W $data
  464.     }
  465.     }
  466.     bind Console <<Copy>> {
  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 <<Paste>> {
  473.     catch {
  474.         set clip [::tk::GetSelection %W CLIPBOARD]
  475.         set list [split $clip \n\r]
  476.         tk::ConsoleInsert %W [lindex $list 0]
  477.         foreach x [lrange $list 1 end] {
  478.         %W mark set insert {end - 1c}
  479.         tk::ConsoleInsert %W "\n"
  480.         tk::ConsoleInvoke
  481.         tk::ConsoleInsert %W $x
  482.         }
  483.     }
  484.     }
  485.  
  486.     ##
  487.     ## Bindings for doing special things based on certain keys
  488.     ##
  489.     bind PostConsole <Key-parenright> {
  490.     if {[string compare \\ [%W get insert-2c]]} {
  491.         ::tk::console::MatchPair %W \( \) promptEnd
  492.     }
  493.     }
  494.     bind PostConsole <Key-bracketright> {
  495.     if {[string compare \\ [%W get insert-2c]]} {
  496.         ::tk::console::MatchPair %W \[ \] promptEnd
  497.     }
  498.     }
  499.     bind PostConsole <Key-braceright> {
  500.     if {[string compare \\ [%W get insert-2c]]} {
  501.         ::tk::console::MatchPair %W \{ \} promptEnd
  502.     }
  503.     }
  504.     bind PostConsole <Key-quotedbl> {
  505.     if {[string compare \\ [%W get insert-2c]]} {
  506.         ::tk::console::MatchQuote %W promptEnd
  507.     }
  508.     }
  509.  
  510.     bind PostConsole <KeyPress> {
  511.     if {"%A" != ""} {
  512.         ::tk::console::TagProc %W
  513.     }
  514.     break
  515.     }
  516. }
  517.  
  518. # ::tk::ConsoleInsert --
  519. # Insert a string into a text at the point of the insertion cursor.
  520. # If there is a selection in the text, and it covers the point of the
  521. # insertion cursor, then delete the selection before inserting.  Insertion
  522. # is restricted to the prompt area.
  523. #
  524. # Arguments:
  525. # w -        The text window in which to insert the string
  526. # s -        The string to insert (usually just a single character)
  527.  
  528. proc ::tk::ConsoleInsert {w s} {
  529.     if {[string equal $s ""]} {
  530.     return
  531.     }
  532.     catch {
  533.     if {[$w compare sel.first <= insert]
  534.         && [$w compare sel.last >= insert]} {
  535.         $w tag remove sel sel.first promptEnd
  536.         $w delete sel.first sel.last
  537.     }
  538.     }
  539.     if {[$w compare insert < promptEnd]} {
  540.     $w mark set insert end
  541.     }
  542.     $w insert insert $s {input stdin}
  543.     $w see insert
  544. }
  545.  
  546. # ::tk::ConsoleOutput --
  547. #
  548. # This routine is called directly by ConsolePutsCmd to cause a string
  549. # to be displayed in the console.
  550. #
  551. # Arguments:
  552. # dest -    The output tag to be used: either "stderr" or "stdout".
  553. # string -    The string to be displayed.
  554.  
  555. proc ::tk::ConsoleOutput {dest string} {
  556.     set w .console
  557.     $w insert output $string $dest
  558.     ::tk::console::ConstrainBuffer $w $::tk::console::maxLines
  559.     $w see insert
  560. }
  561.  
  562. # ::tk::ConsoleExit --
  563. #
  564. # This routine is called by ConsoleEventProc when the main window of
  565. # the application is destroyed.  Don't call exit - that probably already
  566. # happened.  Just delete our window.
  567. #
  568. # Arguments:
  569. # None.
  570.  
  571. proc ::tk::ConsoleExit {} {
  572.     destroy .
  573. }
  574.  
  575. # ::tk::ConsoleAbout --
  576. #
  577. # This routine displays an About box to show Tcl/Tk version info.
  578. #
  579. # Arguments:
  580. # None.
  581.  
  582. proc ::tk::ConsoleAbout {} {
  583.     tk_messageBox -type ok -message "[mc {Tcl for Windows}]
  584.  
  585. Tcl $::tcl_patchLevel
  586. Tk $::tk_patchLevel"
  587. }
  588.  
  589. # ::tk::console::TagProc --
  590. #
  591. # Tags a procedure in the console if it's recognized
  592. # This procedure is not perfect.  However, making it perfect wastes
  593. # too much CPU time...
  594. #
  595. # Arguments:
  596. #    w    - console text widget
  597.  
  598. proc ::tk::console::TagProc w {
  599.     if {!$::tk::console::magicKeys} { return }
  600.     set exp "\[^\\\\\]\[\[ \t\n\r\;{}\"\$\]"
  601.     set i [$w search -backwards -regexp $exp insert-1c promptEnd-1c]
  602.     if {$i == ""} {set i promptEnd} else {append i +2c}
  603.     regsub -all "\[\[\\\\\\?\\*\]" [$w get $i "insert-1c wordend"] {\\\0} c
  604.     if {[llength [EvalAttached [list info commands $c]]]} {
  605.     $w tag add proc $i "insert-1c wordend"
  606.     } else {
  607.     $w tag remove proc $i "insert-1c wordend"
  608.     }
  609.     if {[llength [EvalAttached [list info vars $c]]]} {
  610.     $w tag add var $i "insert-1c wordend"
  611.     } else {
  612.     $w tag remove var $i "insert-1c wordend"
  613.     }
  614. }
  615.  
  616. # ::tk::console::MatchPair --
  617. #
  618. # Blinks a matching pair of characters
  619. # c2 is assumed to be at the text index 'insert'.
  620. # This proc is really loopy and took me an hour to figure out given
  621. # all possible combinations with escaping except for escaped \'s.
  622. # It doesn't take into account possible commenting... Oh well.  If
  623. # anyone has something better, I'd like to see/use it.  This is really
  624. # only efficient for small contexts.
  625. #
  626. # Arguments:
  627. #    w    - console text widget
  628. #     c1    - first char of pair
  629. #     c2    - second char of pair
  630. #
  631. # Calls:    ::tk::console::Blink
  632.  
  633. proc ::tk::console::MatchPair {w c1 c2 {lim 1.0}} {
  634.     if {!$::tk::console::magicKeys} { return }
  635.     if {[string compare {} [set ix [$w search -back $c1 insert $lim]]]} {
  636.     while {
  637.         [string match {\\} [$w get $ix-1c]] &&
  638.         [string compare {} [set ix [$w search -back $c1 $ix-1c $lim]]]
  639.     } {}
  640.     set i1 insert-1c
  641.     while {[string compare {} $ix]} {
  642.         set i0 $ix
  643.         set j 0
  644.         while {[string compare {} [set i0 [$w search $c2 $i0 $i1]]]} {
  645.         append i0 +1c
  646.         if {[string match {\\} [$w get $i0-2c]]} continue
  647.         incr j
  648.         }
  649.         if {!$j} break
  650.         set i1 $ix
  651.         while {$j && [string compare {} \
  652.             [set ix [$w search -back $c1 $ix $lim]]]} {
  653.         if {[string match {\\} [$w get $ix-1c]]} continue
  654.         incr j -1
  655.         }
  656.     }
  657.     if {[string match {} $ix]} { set ix [$w index $lim] }
  658.     } else { set ix [$w index $lim] }
  659.     if {$::tk::console::blinkRange} {
  660.     Blink $w $ix [$w index insert]
  661.     } else {
  662.     Blink $w $ix $ix+1c [$w index insert-1c] [$w index insert]
  663.     }
  664. }
  665.  
  666. # ::tk::console::MatchQuote --
  667. #
  668. # Blinks between matching quotes.
  669. # Blinks just the quote if it's unmatched, otherwise blinks quoted string
  670. # The quote to match is assumed to be at the text index 'insert'.
  671. #
  672. # Arguments:
  673. #    w    - console text widget
  674. #
  675. # Calls:    ::tk::console::Blink
  676.  
  677. proc ::tk::console::MatchQuote {w {lim 1.0}} {
  678.     if {!$::tk::console::magicKeys} { return }
  679.     set i insert-1c
  680.     set j 0
  681.     while {[string compare [set i [$w search -back \" $i $lim]] {}]} {
  682.     if {[string match {\\} [$w get $i-1c]]} continue
  683.     if {!$j} {set i0 $i}
  684.     incr j
  685.     }
  686.     if {$j&1} {
  687.     if {$::tk::console::blinkRange} {
  688.         Blink $w $i0 [$w index insert]
  689.     } else {
  690.         Blink $w $i0 $i0+1c [$w index insert-1c] [$w index insert]
  691.     }
  692.     } else {
  693.     Blink $w [$w index insert-1c] [$w index insert]
  694.     }
  695. }
  696.  
  697. # ::tk::console::Blink --
  698. #
  699. # Blinks between n index pairs for a specified duration.
  700. #
  701. # Arguments:
  702. #    w    - console text widget
  703. #     i1    - start index to blink region
  704. #     i2    - end index of blink region
  705. #     dur    - duration in usecs to blink for
  706. #
  707. # Outputs:
  708. #    blinks selected characters in $w
  709.  
  710. proc ::tk::console::Blink {w args} {
  711.     eval [list $w tag add blink] $args
  712.     after $::tk::console::blinkTime [list $w] tag remove blink $args
  713. }
  714.  
  715. # ::tk::console::ConstrainBuffer --
  716. #
  717. # This limits the amount of data in the text widget
  718. # Called by Prompt and ConsoleOutput
  719. #
  720. # Arguments:
  721. #    w    - console text widget
  722. #    size    - # of lines to constrain to
  723. #
  724. # Outputs:
  725. #    may delete data in console widget
  726.  
  727. proc ::tk::console::ConstrainBuffer {w size} {
  728.     if {[$w index end] > $size} {
  729.     $w delete 1.0 [expr {int([$w index end])-$size}].0
  730.     }
  731. }
  732.  
  733. # ::tk::console::Expand --
  734. #
  735. # Arguments:
  736. # ARGS:    w    - text widget in which to expand str
  737. #     type    - type of expansion (path / proc / variable)
  738. #
  739. # Calls:    ::tk::console::Expand(Pathname|Procname|Variable)
  740. #
  741. # Outputs:    The string to match is expanded to the longest possible match.
  742. #        If ::tk::console::showMatches is non-zero and the longest match
  743. #        equaled the string to expand, then all possible matches are
  744. #        output to stdout.  Triggers bell if no matches are found.
  745. #
  746. # Returns:    number of matches found
  747.  
  748. proc ::tk::console::Expand {w {type ""}} {
  749.     set exp "\[^\\\\\]\[\[ \t\n\r\\\{\"\\\\\$\]"
  750.     set tmp [$w search -backwards -regexp $exp insert-1c promptEnd-1c]
  751.     if {$tmp == ""} {set tmp promptEnd} else {append tmp +2c}
  752.     if {[$w compare $tmp >= insert]} { return }
  753.     set str [$w get $tmp insert]
  754.     switch -glob $type {
  755.     path* { set res [ExpandPathname $str] }
  756.     proc* { set res [ExpandProcname $str] }
  757.     var*  { set res [ExpandVariable $str] }
  758.     default {
  759.         set res {}
  760.         foreach t {Pathname Procname Variable} {
  761.         if {![catch {Expand$t $str} res] && ($res != "")} { break }
  762.         }
  763.     }
  764.     }
  765.     set len [llength $res]
  766.     if {$len} {
  767.     set repl [lindex $res 0]
  768.     $w delete $tmp insert
  769.     $w insert $tmp $repl {input stdin}
  770.     if {($len > 1) && $::tk::console::showMatches \
  771.         && [string equal $repl $str]} {
  772.         puts stdout [lsort [lreplace $res 0 0]]
  773.     }
  774.     } else { bell }
  775.     return [incr len -1]
  776. }
  777.  
  778. # ::tk::console::ExpandPathname --
  779. #
  780. # Expand a file pathname based on $str
  781. # This is based on UNIX file name conventions
  782. #
  783. # Arguments:
  784. #    str    - partial file pathname to expand
  785. #
  786. # Calls:    ::tk::console::ExpandBestMatch
  787. #
  788. # Returns:    list containing longest unique match followed by all the
  789. #        possible further matches
  790.  
  791. proc ::tk::console::ExpandPathname str {
  792.     set pwd [EvalAttached pwd]
  793.     if {[catch {EvalAttached [list cd [file dirname $str]]} err]} {
  794.     return -code error $err
  795.     }
  796.     set dir [file tail $str]
  797.     ## Check to see if it was known to be a directory and keep the trailing
  798.     ## slash if so (file tail cuts it off)
  799.     if {[string match */ $str]} { append dir / }
  800.     if {[catch {lsort [EvalAttached [list glob $dir*]]} m]} {
  801.     set match {}
  802.     } else {
  803.     if {[llength $m] > 1} {
  804.         global tcl_platform
  805.         if {[string match windows $tcl_platform(platform)]} {
  806.         ## Windows is screwy because it's case insensitive
  807.         set tmp [ExpandBestMatch [string tolower $m] \
  808.             [string tolower $dir]]
  809.         ## Don't change case if we haven't changed the word
  810.         if {[string length $dir]==[string length $tmp]} {
  811.             set tmp $dir
  812.         }
  813.         } else {
  814.         set tmp [ExpandBestMatch $m $dir]
  815.         }
  816.         if {[string match ?*/* $str]} {
  817.         set tmp [file dirname $str]/$tmp
  818.         } elseif {[string match /* $str]} {
  819.         set tmp /$tmp
  820.         }
  821.         regsub -all { } $tmp {\\ } tmp
  822.         set match [linsert $m 0 $tmp]
  823.     } else {
  824.         ## This may look goofy, but it handles spaces in path names
  825.         eval append match $m
  826.         if {[file isdir $match]} {append match /}
  827.         if {[string match ?*/* $str]} {
  828.         set match [file dirname $str]/$match
  829.         } elseif {[string match /* $str]} {
  830.         set match /$match
  831.         }
  832.         regsub -all { } $match {\\ } match
  833.         ## Why is this one needed and the ones below aren't!!
  834.         set match [list $match]
  835.     }
  836.     }
  837.     EvalAttached [list cd $pwd]
  838.     return $match
  839. }
  840.  
  841. # ::tk::console::ExpandProcname --
  842. #
  843. # Expand a tcl proc name based on $str
  844. #
  845. # Arguments:
  846. #    str    - partial proc name to expand
  847. #
  848. # Calls:    ::tk::console::ExpandBestMatch
  849. #
  850. # Returns:    list containing longest unique match followed by all the
  851. #        possible further matches
  852.  
  853. proc ::tk::console::ExpandProcname str {
  854.     set match [EvalAttached [list info commands $str*]]
  855.     if {[llength $match] == 0} {
  856.     set ns [EvalAttached \
  857.         "namespace children \[namespace current\] [list $str*]"]
  858.     if {[llength $ns]==1} {
  859.         set match [EvalAttached [list info commands ${ns}::*]]
  860.     } else {
  861.         set match $ns
  862.     }
  863.     }
  864.     if {[llength $match] > 1} {
  865.     regsub -all { } [ExpandBestMatch $match $str] {\\ } str
  866.     set match [linsert $match 0 $str]
  867.     } else {
  868.     regsub -all { } $match {\\ } match
  869.     }
  870.     return $match
  871. }
  872.  
  873. # ::tk::console::ExpandVariable --
  874. #
  875. # Expand a tcl variable name based on $str
  876. #
  877. # Arguments:
  878. #    str    - partial tcl var name to expand
  879. #
  880. # Calls:    ::tk::console::ExpandBestMatch
  881. #
  882. # Returns:    list containing longest unique match followed by all the
  883. #        possible further matches
  884.  
  885. proc ::tk::console::ExpandVariable str {
  886.     if {[regexp {([^\(]*)\((.*)} $str junk ary str]} {
  887.     ## Looks like they're trying to expand an array.
  888.     set match [EvalAttached [list array names $ary $str*]]
  889.     if {[llength $match] > 1} {
  890.         set vars $ary\([ExpandBestMatch $match $str]
  891.         foreach var $match {lappend vars $ary\($var\)}
  892.         return $vars
  893.     } else {set match $ary\($match\)}
  894.     ## Space transformation avoided for array names.
  895.     } else {
  896.     set match [EvalAttached [list info vars $str*]]
  897.     if {[llength $match] > 1} {
  898.         regsub -all { } [ExpandBestMatch $match $str] {\\ } str
  899.         set match [linsert $match 0 $str]
  900.     } else {
  901.         regsub -all { } $match {\\ } match
  902.     }
  903.     }
  904.     return $match
  905. }
  906.  
  907. # ::tk::console::ExpandBestMatch --
  908. #
  909. # Finds the best unique match in a list of names.
  910. # The extra $e in this argument allows us to limit the innermost loop a little
  911. # further.  This improves speed as $l becomes large or $e becomes long.
  912. #
  913. # Arguments:
  914. #    l    - list to find best unique match in
  915. #     e    - currently best known unique match
  916. #
  917. # Returns:    longest unique match in the list
  918.  
  919. proc ::tk::console::ExpandBestMatch {l {e {}}} {
  920.     set ec [lindex $l 0]
  921.     if {[llength $l]>1} {
  922.     set e  [string length $e]; incr e -1
  923.     set ei [string length $ec]; incr ei -1
  924.     foreach l $l {
  925.         while {$ei>=$e && [string first $ec $l]} {
  926.         set ec [string range $ec 0 [incr ei -1]]
  927.         }
  928.     }
  929.     }
  930.     return $ec
  931. }
  932.  
  933. # now initialize the console
  934. ::tk::ConsoleInit
  935.