home *** CD-ROM | disk | FTP | other *** search
/ Freelog Special Freeware 31 / FreelogHS31.iso / Texte / scribus / scribus-1.3.3.9-win32-install.exe / tcl / tk8.4 / console.tcl < prev    next >
Text File  |  2003-02-20  |  27KB  |  941 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.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
  941.