home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tk42r2x.zip / TclTk / lib / tk4.2 / console.tcl < prev    next >
Text File  |  1999-07-27  |  10KB  |  418 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. # SCCS: @(#) console.tcl 1.34 96/08/26 20:14:30
  8. #
  9. # Copyright (c) 1995-1996 Sun Microsystems, Inc.
  10. #
  11. # See the file "license.terms" for information on usage and redistribution
  12. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13. #
  14.  
  15. # TODO: history - remember partially written command
  16.  
  17. # tkConsoleInit --
  18. # This procedure constructs and configures the console windows.
  19. #
  20. # Arguments:
  21. #     None.
  22.  
  23. proc tkConsoleInit {} {
  24.     global tcl_platform
  25.  
  26.     if {[info commands macscrollbar] == "macscrollbar"} {
  27.     # Use the native scrollbar for the console
  28.     rename scrollbar ""
  29.     rename macscrollbar scrollbar
  30.     }
  31.     text .console  -yscrollcommand ".sb set" -setgrid true
  32.     scrollbar .sb -command ".console yview"
  33.     pack .sb -side right -fill both
  34.     pack .console -fill both -expand 1 -side left
  35.     if {$tcl_platform(platform) == "macintosh"} {
  36.         after idle {.console configure -font {Monaco 9 normal}}
  37.     .sb configure -bg white
  38.         .console configure -bg white -bd 0 -highlightthickness 0 \
  39.       -selectbackground black -selectforeground white \
  40.       -selectborderwidth 0 -insertwidth 1
  41.     .console tag configure sel -relief ridge
  42.     bind .console <FocusIn> {  .console tag configure sel -borderwidth 0
  43.       .console configure -selectbackground black -selectforeground white }
  44.     bind .console <FocusOut> { .console tag configure sel -borderwidth 2
  45.       .console configure -selectbackground white -selectforeground black }
  46.     }
  47.  
  48.     tkConsoleBind .console
  49.  
  50.     .console tag configure stderr -foreground red
  51.     .console tag configure stdin -foreground blue
  52.  
  53.     focus .console
  54.     
  55.     wm protocol . WM_DELETE_WINDOW { wm withdraw . }
  56.     wm title . "Console"
  57.     flush stdout
  58.     .console mark set output [.console index "end - 1 char"]
  59.     tkTextSetCursor .console end
  60.     .console mark set promptEnd insert
  61.     .console mark gravity promptEnd left
  62. }
  63.  
  64. # tkConsoleInvoke --
  65. # Processes the command line input.  If the command is complete it
  66. # is evaled in the main interpreter.  Otherwise, the continuation
  67. # prompt is added and more input may be added.
  68. #
  69. # Arguments:
  70. # None.
  71.  
  72. proc tkConsoleInvoke {args} {
  73.     set ranges [.console tag ranges input]
  74.     set cmd ""
  75.     if {$ranges != ""} {
  76.     set pos 0
  77.     while {[lindex $ranges $pos] != ""} {
  78.         set start [lindex $ranges $pos]
  79.         set end [lindex $ranges [incr pos]]
  80.         append cmd [.console get $start $end]
  81.         incr pos
  82.     }
  83.     }
  84.     if {$cmd == ""} {
  85.     tkConsolePrompt
  86.     } elseif [info complete $cmd] {
  87.     .console mark set output end
  88.     .console tag delete input
  89.     set result [interp record $cmd]
  90.     if {$result != ""} {
  91.         .console insert insert "$result\n"
  92.     }
  93.     tkConsoleHistory reset
  94.     tkConsolePrompt
  95.     } else {
  96.     tkConsolePrompt partial
  97.     }
  98.     .console yview -pickplace insert
  99. }
  100.  
  101. # tkConsoleHistory --
  102. # This procedure implements command line history for the
  103. # console.  In general is evals the history command in the
  104. # main interpreter to obtain the history.  The global variable
  105. # histNum is used to store the current location in the history.
  106. #
  107. # Arguments:
  108. # cmd -    Which action to take: prev, next, reset.
  109.  
  110. set histNum 1
  111. proc tkConsoleHistory {cmd} {
  112.     global histNum
  113.     
  114.     switch $cmd {
  115.         prev {
  116.         incr histNum -1
  117.         if {$histNum == 0} {
  118.         set cmd {history event [expr [history nextid] -1]}
  119.         } else {
  120.         set cmd "history event $histNum"
  121.         }
  122.             if {[catch {interp eval $cmd} cmd]} {
  123.                 incr histNum
  124.                 return
  125.             }
  126.         .console delete promptEnd end
  127.             .console insert promptEnd $cmd {input stdin}
  128.         }
  129.         next {
  130.         incr histNum
  131.         if {$histNum == 0} {
  132.         set cmd {history event [expr [history nextid] -1]}
  133.         } elseif {$histNum > 0} {
  134.         set cmd ""
  135.         set histNum 1
  136.         } else {
  137.         set cmd "history event $histNum"
  138.         }
  139.         if {$cmd != ""} {
  140.         catch {interp eval $cmd} cmd
  141.         }
  142.         .console delete promptEnd end
  143.         .console insert promptEnd $cmd {input stdin}
  144.         }
  145.         reset {
  146.             set histNum 1
  147.         }
  148.     }
  149. }
  150.  
  151. # tkConsolePrompt --
  152. # This procedure draws the prompt.  If tcl_prompt1 or tcl_prompt2
  153. # exists in the main interpreter it will be called to generate the 
  154. # prompt.  Otherwise, a hard coded default prompt is printed.
  155. #
  156. # Arguments:
  157. # partial -    Flag to specify which prompt to print.
  158.  
  159. proc tkConsolePrompt {{partial normal}} {
  160.     if {$partial == "normal"} {
  161.     set temp [.console index "end - 1 char"]
  162.     .console mark set output end
  163.         if [interp eval "info exists tcl_prompt1"] {
  164.             interp eval "eval \[set tcl_prompt1\]"
  165.         } else {
  166.             puts -nonewline "% "
  167.         }
  168.     } else {
  169.     set temp [.console index output]
  170.     .console mark set output end
  171.         if [interp eval "info exists tcl_prompt2"] {
  172.             interp eval "eval \[set tcl_prompt2\]"
  173.         } else {
  174.         puts -nonewline "> "
  175.         }
  176.     }
  177.     flush stdout
  178.     .console mark set output $temp
  179.     tkTextSetCursor .console end
  180.     .console mark set promptEnd insert
  181.     .console mark gravity promptEnd left
  182. }
  183.  
  184. # tkConsoleBind --
  185. # This procedure first ensures that the default bindings for the Text
  186. # class have been defined.  Then certain bindings are overridden for
  187. # the class.
  188. #
  189. # Arguments:
  190. # None.
  191.  
  192. proc tkConsoleBind {win} {
  193.     bindtags $win "$win Text . all"
  194.  
  195.     # Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
  196.     # Otherwise, if a widget binding for one of these is defined, the
  197.     # <KeyPress> class binding will also fire and insert the character,
  198.     # which is wrong.  Ditto for <Escape>.
  199.  
  200.     bind $win <Alt-KeyPress> {# nothing }
  201.     bind $win <Meta-KeyPress> {# nothing}
  202.     bind $win <Control-KeyPress> {# nothing}
  203.     bind $win <Escape> {# nothing}
  204.     bind $win <KP_Enter> {# nothing}
  205.  
  206.     bind $win <Tab> {
  207.     tkConsoleInsert %W \t
  208.     focus %W
  209.     break
  210.     }
  211.     bind $win <Return> {
  212.     %W mark set insert {end - 1c}
  213.     tkConsoleInsert %W "\n"
  214.     tkConsoleInvoke
  215.     break
  216.     }
  217.     bind $win <Delete> {
  218.     if {[%W tag nextrange sel 1.0 end] != ""} {
  219.         %W tag remove sel sel.first promptEnd
  220.     } else {
  221.         if [%W compare insert < promptEnd] {
  222.         break
  223.         }
  224.     }
  225.     }
  226.     bind $win <BackSpace> {
  227.     if {[%W tag nextrange sel 1.0 end] != ""} {
  228.         %W tag remove sel sel.first promptEnd
  229.     } else {
  230.         if [%W compare insert <= promptEnd] {
  231.         break
  232.         }
  233.     }
  234.     }
  235.     foreach left {Control-a Home} {
  236.     bind $win <$left> {
  237.         if [%W compare insert < promptEnd] {
  238.         tkTextSetCursor %W {insert linestart}
  239.         } else {
  240.         tkTextSetCursor %W promptEnd
  241.             }
  242.         break
  243.     }
  244.     }
  245.     foreach right {Control-e End} {
  246.     bind $win <$right> {
  247.         tkTextSetCursor %W {insert lineend}
  248.         break
  249.     }
  250.     }
  251.     bind $win <Control-d> {
  252.     if [%W compare insert < promptEnd] {
  253.         break
  254.     }
  255.     }
  256.     bind $win <Control-k> {
  257.     if [%W compare insert < promptEnd] {
  258.         %W mark set insert promptEnd
  259.     }
  260.     }
  261.     bind $win <Control-t> {
  262.     if [%W compare insert < promptEnd] {
  263.         break
  264.     }
  265.     }
  266.     bind $win <Meta-d> {
  267.     if [%W compare insert < promptEnd] {
  268.         break
  269.     }
  270.     }
  271.     bind $win <Meta-BackSpace> {
  272.     if [%W compare insert <= promptEnd] {
  273.         break
  274.     }
  275.     }
  276.     bind $win <Control-h> {
  277.     if [%W compare insert <= promptEnd] {
  278.         break
  279.     }
  280.     }
  281.     foreach prev {Control-p Up} {
  282.     bind $win <$prev> {
  283.         tkConsoleHistory prev
  284.         break
  285.     }
  286.     }
  287.     foreach prev {Control-n Down} {
  288.     bind $win <$prev> {
  289.         tkConsoleHistory next
  290.         break
  291.     }
  292.     }
  293.     bind $win <Control-v> {
  294.     if [%W compare insert > promptEnd] {
  295.         catch {
  296.         %W insert insert [selection get -displayof %W] {input stdin}
  297.         %W see insert
  298.         }
  299.     }
  300.     break
  301.     }
  302.     bind $win <Insert> {
  303.     catch {tkConsoleInsert %W [selection get -displayof %W]}
  304.     break
  305.     }
  306.     bind $win <KeyPress> {
  307.     tkConsoleInsert %W %A
  308.     break
  309.     }
  310.     foreach left {Control-b Left} {
  311.     bind $win <$left> {
  312.         if [%W compare insert == promptEnd] {
  313.         break
  314.         }
  315.         tkTextSetCursor %W insert-1c
  316.         break
  317.     }
  318.     }
  319.     foreach right {Control-f Right} {
  320.     bind $win <$right> {
  321.         tkTextSetCursor %W insert+1c
  322.         break
  323.     }
  324.     }
  325.     bind $win <F9> {
  326.     eval destroy [winfo child .]
  327.     if {$tcl_platform(platform) == "macintosh"} {
  328.         source -rsrc Console
  329.     } else {
  330.         source [file join $tk_library console.tcl]
  331.     }
  332.     }
  333.     bind $win <<Cut>> {
  334.         continue
  335.     }
  336.     bind $win <<Copy>> {
  337.     if {[selection own -displayof %W] == "%W"} {
  338.         clipboard clear -displayof %W
  339.         catch {
  340.         clipboard append -displayof %W [selection get -displayof %W]
  341.         }
  342.     }
  343.     break
  344.     }
  345.     bind $win <<Paste>> {
  346.     catch {
  347.         set clip [selection get -displayof %W -selection CLIPBOARD]
  348.         set list [split $clip \n\r]
  349.         tkConsoleInsert %W [lindex $list 0]
  350.         foreach x [lrange $list 1 end] {
  351.         %W mark set insert {end - 1c}
  352.         tkConsoleInsert %W "\n"
  353.         tkConsoleInvoke
  354.         tkConsoleInsert %W $x
  355.         }
  356.     }
  357.     break
  358.     }
  359. }
  360.  
  361. # tkConsoleInsert --
  362. # Insert a string into a text at the point of the insertion cursor.
  363. # If there is a selection in the text, and it covers the point of the
  364. # insertion cursor, then delete the selection before inserting.  Insertion
  365. # is restricted to the prompt area.
  366. #
  367. # Arguments:
  368. # w -        The text window in which to insert the string
  369. # s -        The string to insert (usually just a single character)
  370.  
  371. proc tkConsoleInsert {w s} {
  372.     if {$s == ""} {
  373.     return
  374.     }
  375.     catch {
  376.     if {[$w compare sel.first <= insert]
  377.         && [$w compare sel.last >= insert]} {
  378.         $w tag remove sel sel.first promptEnd
  379.         $w delete sel.first sel.last
  380.     }
  381.     }
  382.     if {[$w compare insert < promptEnd]} {
  383.     $w mark set insert end    
  384.     }
  385.     $w insert insert $s {input stdin}
  386.     $w see insert
  387. }
  388.  
  389. # tkConsoleOutput --
  390. #
  391. # This routine is called directly by ConsolePutsCmd to cause a string
  392. # to be displayed in the console.
  393. #
  394. # Arguments:
  395. # dest -    The output tag to be used: either "stderr" or "stdout".
  396. # string -    The string to be displayed.
  397.  
  398. proc tkConsoleOutput {dest string} {
  399.     .console insert output $string $dest
  400.     .console see insert
  401. }
  402.  
  403. # tkConsoleExit --
  404. #
  405. # This routine is called by ConsoleEventProc when the main window of
  406. # the application is destroyed.
  407. #
  408. # Arguments:
  409. # None.
  410.  
  411. proc tkConsoleExit {} {
  412.     exit
  413. }
  414.  
  415. # now initialize the console
  416.  
  417. tkConsoleInit
  418.