home *** CD-ROM | disk | FTP | other *** search
/ PC World 2001 April / PCWorld_2001-04_cd.bin / Software / TemaCD / webclean / !!!python!!! / BeOpen-Python-2.0.exe / CONSOLE.TCL < prev    next >
Encoding:
Text File  |  2000-04-20  |  12.1 KB  |  484 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.8 2000/04/21 04:06:37 hobbs Exp $
  8. #
  9. # Copyright (c) 1998-1999 Scriptics Corp.
  10. # Copyright (c) 1995-1997 Sun Microsystems, Inc.
  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. # tkConsoleInit --
  19. # This procedure constructs and configures the console windows.
  20. #
  21. # Arguments:
  22. #     None.
  23.  
  24. proc tkConsoleInit {} {
  25.     global tcl_platform
  26.  
  27.     if {![consoleinterp eval {set tcl_interactive}]} {
  28.     wm withdraw .
  29.     }
  30.  
  31.     if {[string compare $tcl_platform(platform) "macintosh"]} {
  32.     set mod "Ctrl"
  33.     } else {
  34.     set mod "Cmd"
  35.     }
  36.  
  37.     menu .menubar
  38.     .menubar add cascade -label File -menu .menubar.file -underline 0
  39.     .menubar add cascade -label Edit -menu .menubar.edit -underline 0
  40.  
  41.     menu .menubar.file -tearoff 0
  42.     .menubar.file add command -label "Source..." -underline 0 \
  43.         -command tkConsoleSource
  44.     .menubar.file add command -label "Hide Console" -underline 0 \
  45.         -command {wm withdraw .}
  46.     if {[string compare $tcl_platform(platform) "macintosh"]} {
  47.     .menubar.file add command -label "Exit" -underline 1 -command exit
  48.     } else {
  49.     .menubar.file add command -label "Quit" -command exit -accel Cmd-Q
  50.     }
  51.  
  52.     menu .menubar.edit -tearoff 0
  53.     .menubar.edit add command -label "Cut" -underline 2 \
  54.         -command { event generate .console <<Cut>> } -accel "$mod+X"
  55.     .menubar.edit add command -label "Copy" -underline 0 \
  56.         -command { event generate .console <<Copy>> } -accel "$mod+C"
  57.     .menubar.edit add command -label "Paste" -underline 1 \
  58.         -command { event generate .console <<Paste>> } -accel "$mod+V"
  59.  
  60.     if {[string compare $tcl_platform(platform) "windows"]} {
  61.     .menubar.edit add command -label "Clear" -underline 2 \
  62.         -command { event generate .console <<Clear>> }
  63.     } else {
  64.     .menubar.edit add command -label "Delete" -underline 0 \
  65.         -command { event generate .console <<Clear>> } -accel "Del"
  66.  
  67.     .menubar add cascade -label Help -menu .menubar.help -underline 0
  68.     menu .menubar.help -tearoff 0
  69.     .menubar.help add command -label "About..." -underline 0 \
  70.         -command tkConsoleAbout
  71.     }
  72.  
  73.     . configure -menu .menubar
  74.  
  75.     text .console  -yscrollcommand ".sb set" -setgrid true 
  76.     scrollbar .sb -command ".console yview"
  77.     pack .sb -side right -fill both
  78.     pack .console -fill both -expand 1 -side left
  79.     switch -exact $tcl_platform(platform) {
  80.     "macintosh" {
  81.         .console configure -font {Monaco 9 normal} -highlightthickness 0
  82.     }
  83.     "windows" {
  84.         .console configure -font systemfixed
  85.     }
  86.     }
  87.  
  88.     tkConsoleBind .console
  89.  
  90.     .console tag configure stderr -foreground red
  91.     .console tag configure stdin -foreground blue
  92.  
  93.     focus .console
  94.     
  95.     wm protocol . WM_DELETE_WINDOW { wm withdraw . }
  96.     wm title . "Console"
  97.     flush stdout
  98.     .console mark set output [.console index "end - 1 char"]
  99.     tkTextSetCursor .console end
  100.     .console mark set promptEnd insert
  101.     .console mark gravity promptEnd left
  102. }
  103.  
  104. # tkConsoleSource --
  105. #
  106. # Prompts the user for a file to source in the main interpreter.
  107. #
  108. # Arguments:
  109. # None.
  110.  
  111. proc tkConsoleSource {} {
  112.     set filename [tk_getOpenFile -defaultextension .tcl -parent . \
  113.               -title "Select a file to source" \
  114.               -filetypes {{"Tcl Scripts" .tcl} {"All Files" *}}]
  115.     if {[string compare $filename ""]} {
  116.         set cmd [list source $filename]
  117.     if {[catch {consoleinterp eval $cmd} result]} {
  118.         tkConsoleOutput stderr "$result\n"
  119.     }
  120.     }
  121. }
  122.  
  123. # tkConsoleInvoke --
  124. # Processes the command line input.  If the command is complete it
  125. # is evaled in the main interpreter.  Otherwise, the continuation
  126. # prompt is added and more input may be added.
  127. #
  128. # Arguments:
  129. # None.
  130.  
  131. proc tkConsoleInvoke {args} {
  132.     set ranges [.console tag ranges input]
  133.     set cmd ""
  134.     if {[llength $ranges]} {
  135.     set pos 0
  136.     while {[string compare [lindex $ranges $pos] ""]} {
  137.         set start [lindex $ranges $pos]
  138.         set end [lindex $ranges [incr pos]]
  139.         append cmd [.console get $start $end]
  140.         incr pos
  141.     }
  142.     }
  143.     if {[string equal $cmd ""]} {
  144.     tkConsolePrompt
  145.     } elseif {[info complete $cmd]} {
  146.     .console mark set output end
  147.     .console tag delete input
  148.     set result [consoleinterp record $cmd]
  149.     if {[string compare $result ""]} {
  150.         puts $result
  151.     }
  152.     tkConsoleHistory reset
  153.     tkConsolePrompt
  154.     } else {
  155.     tkConsolePrompt partial
  156.     }
  157.     .console yview -pickplace insert
  158. }
  159.  
  160. # tkConsoleHistory --
  161. # This procedure implements command line history for the
  162. # console.  In general is evals the history command in the
  163. # main interpreter to obtain the history.  The global variable
  164. # histNum is used to store the current location in the history.
  165. #
  166. # Arguments:
  167. # cmd -    Which action to take: prev, next, reset.
  168.  
  169. set histNum 1
  170. proc tkConsoleHistory {cmd} {
  171.     global histNum
  172.     
  173.     switch $cmd {
  174.         prev {
  175.         incr histNum -1
  176.         if {$histNum == 0} {
  177.         set cmd {history event [expr {[history nextid] -1}]}
  178.         } else {
  179.         set cmd "history event $histNum"
  180.         }
  181.             if {[catch {consoleinterp eval $cmd} cmd]} {
  182.                 incr histNum
  183.                 return
  184.             }
  185.         .console delete promptEnd end
  186.             .console insert promptEnd $cmd {input stdin}
  187.         }
  188.         next {
  189.         incr histNum
  190.         if {$histNum == 0} {
  191.         set cmd {history event [expr {[history nextid] -1}]}
  192.         } elseif {$histNum > 0} {
  193.         set cmd ""
  194.         set histNum 1
  195.         } else {
  196.         set cmd "history event $histNum"
  197.         }
  198.         if {[string compare $cmd ""]} {
  199.         catch {consoleinterp eval $cmd} cmd
  200.         }
  201.         .console delete promptEnd end
  202.         .console insert promptEnd $cmd {input stdin}
  203.         }
  204.         reset {
  205.             set histNum 1
  206.         }
  207.     }
  208. }
  209.  
  210. # tkConsolePrompt --
  211. # This procedure draws the prompt.  If tcl_prompt1 or tcl_prompt2
  212. # exists in the main interpreter it will be called to generate the 
  213. # prompt.  Otherwise, a hard coded default prompt is printed.
  214. #
  215. # Arguments:
  216. # partial -    Flag to specify which prompt to print.
  217.  
  218. proc tkConsolePrompt {{partial normal}} {
  219.     if {[string equal $partial "normal"]} {
  220.     set temp [.console index "end - 1 char"]
  221.     .console mark set output end
  222.         if {[consoleinterp eval "info exists tcl_prompt1"]} {
  223.             consoleinterp eval "eval \[set tcl_prompt1\]"
  224.         } else {
  225.             puts -nonewline "% "
  226.         }
  227.     } else {
  228.     set temp [.console index output]
  229.     .console mark set output end
  230.         if {[consoleinterp eval "info exists tcl_prompt2"]} {
  231.             consoleinterp eval "eval \[set tcl_prompt2\]"
  232.         } else {
  233.         puts -nonewline "> "
  234.         }
  235.     }
  236.     flush stdout
  237.     .console mark set output $temp
  238.     tkTextSetCursor .console end
  239.     .console mark set promptEnd insert
  240.     .console mark gravity promptEnd left
  241. }
  242.  
  243. # tkConsoleBind --
  244. # This procedure first ensures that the default bindings for the Text
  245. # class have been defined.  Then certain bindings are overridden for
  246. # the class.
  247. #
  248. # Arguments:
  249. # None.
  250.  
  251. proc tkConsoleBind {win} {
  252.     bindtags $win "$win Text . all"
  253.  
  254.     # Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
  255.     # Otherwise, if a widget binding for one of these is defined, the
  256.     # <KeyPress> class binding will also fire and insert the character,
  257.     # which is wrong.  Ditto for <Escape>.
  258.  
  259.     bind $win <Alt-KeyPress> {# nothing }
  260.     bind $win <Meta-KeyPress> {# nothing}
  261.     bind $win <Control-KeyPress> {# nothing}
  262.     bind $win <Escape> {# nothing}
  263.     bind $win <KP_Enter> {# nothing}
  264.  
  265.     bind $win <Tab> {
  266.     tkConsoleInsert %W \t
  267.     focus %W
  268.     break
  269.     }
  270.     bind $win <Return> {
  271.     %W mark set insert {end - 1c}
  272.     tkConsoleInsert %W "\n"
  273.     tkConsoleInvoke
  274.     break
  275.     }
  276.     bind $win <Delete> {
  277.     if {[string compare [%W tag nextrange sel 1.0 end] ""]} {
  278.         %W tag remove sel sel.first promptEnd
  279.     } elseif {[%W compare insert < promptEnd]} {
  280.         break
  281.     }
  282.     }
  283.     bind $win <BackSpace> {
  284.     if {[string compare [%W tag nextrange sel 1.0 end] ""]} {
  285.         %W tag remove sel sel.first promptEnd
  286.     } elseif {[%W compare insert <= promptEnd]} {
  287.         break
  288.     }
  289.     }
  290.     foreach left {Control-a Home} {
  291.     bind $win <$left> {
  292.         if {[%W compare insert < promptEnd]} {
  293.         tkTextSetCursor %W {insert linestart}
  294.         } else {
  295.         tkTextSetCursor %W promptEnd
  296.             }
  297.         break
  298.     }
  299.     }
  300.     foreach right {Control-e End} {
  301.     bind $win <$right> {
  302.         tkTextSetCursor %W {insert lineend}
  303.         break
  304.     }
  305.     }
  306.     bind $win <Control-d> {
  307.     if {[%W compare insert < promptEnd]} {
  308.         break
  309.     }
  310.     }
  311.     bind $win <Control-k> {
  312.     if {[%W compare insert < promptEnd]} {
  313.         %W mark set insert promptEnd
  314.     }
  315.     }
  316.     bind $win <Control-t> {
  317.     if {[%W compare insert < promptEnd]} {
  318.         break
  319.     }
  320.     }
  321.     bind $win <Meta-d> {
  322.     if {[%W compare insert < promptEnd]} {
  323.         break
  324.     }
  325.     }
  326.     bind $win <Meta-BackSpace> {
  327.     if {[%W compare insert <= promptEnd]} {
  328.         break
  329.     }
  330.     }
  331.     bind $win <Control-h> {
  332.     if {[%W compare insert <= promptEnd]} {
  333.         break
  334.     }
  335.     }
  336.     foreach prev {Control-p Up} {
  337.     bind $win <$prev> {
  338.         tkConsoleHistory prev
  339.         break
  340.     }
  341.     }
  342.     foreach prev {Control-n Down} {
  343.     bind $win <$prev> {
  344.         tkConsoleHistory next
  345.         break
  346.     }
  347.     }
  348.     bind $win <Insert> {
  349.     catch {tkConsoleInsert %W [selection get -displayof %W]}
  350.     break
  351.     }
  352.     bind $win <KeyPress> {
  353.     tkConsoleInsert %W %A
  354.     break
  355.     }
  356.     foreach left {Control-b Left} {
  357.     bind $win <$left> {
  358.         if {[%W compare insert == promptEnd]} {
  359.         break
  360.         }
  361.         tkTextSetCursor %W insert-1c
  362.         break
  363.     }
  364.     }
  365.     foreach right {Control-f Right} {
  366.     bind $win <$right> {
  367.         tkTextSetCursor %W insert+1c
  368.         break
  369.     }
  370.     }
  371.     bind $win <F9> {
  372.     eval destroy [winfo child .]
  373.     if {[string equal $tcl_platform(platform) "macintosh"]} {
  374.         source -rsrc Console
  375.     } else {
  376.         source [file join $tk_library console.tcl]
  377.     }
  378.     }
  379.     bind $win <<Cut>> {
  380.         # Same as the copy event
  381.      if {![catch {set data [%W get sel.first sel.last]}]} {
  382.         clipboard clear -displayof %W
  383.         clipboard append -displayof %W $data
  384.     }
  385.     break
  386.     }
  387.     bind $win <<Copy>> {
  388.      if {![catch {set data [%W get sel.first sel.last]}]} {
  389.         clipboard clear -displayof %W
  390.         clipboard append -displayof %W $data
  391.     }
  392.     break
  393.     }
  394.     bind $win <<Paste>> {
  395.     catch {
  396.         set clip [selection get -displayof %W -selection CLIPBOARD]
  397.         set list [split $clip \n\r]
  398.         tkConsoleInsert %W [lindex $list 0]
  399.         foreach x [lrange $list 1 end] {
  400.         %W mark set insert {end - 1c}
  401.         tkConsoleInsert %W "\n"
  402.         tkConsoleInvoke
  403.         tkConsoleInsert %W $x
  404.         }
  405.     }
  406.     break
  407.     }
  408. }
  409.  
  410. # tkConsoleInsert --
  411. # Insert a string into a text at the point of the insertion cursor.
  412. # If there is a selection in the text, and it covers the point of the
  413. # insertion cursor, then delete the selection before inserting.  Insertion
  414. # is restricted to the prompt area.
  415. #
  416. # Arguments:
  417. # w -        The text window in which to insert the string
  418. # s -        The string to insert (usually just a single character)
  419.  
  420. proc tkConsoleInsert {w s} {
  421.     if {[string equal $s ""]} {
  422.     return
  423.     }
  424.     catch {
  425.     if {[$w compare sel.first <= insert]
  426.         && [$w compare sel.last >= insert]} {
  427.         $w tag remove sel sel.first promptEnd
  428.         $w delete sel.first sel.last
  429.     }
  430.     }
  431.     if {[$w compare insert < promptEnd]} {
  432.     $w mark set insert end    
  433.     }
  434.     $w insert insert $s {input stdin}
  435.     $w see insert
  436. }
  437.  
  438. # tkConsoleOutput --
  439. #
  440. # This routine is called directly by ConsolePutsCmd to cause a string
  441. # to be displayed in the console.
  442. #
  443. # Arguments:
  444. # dest -    The output tag to be used: either "stderr" or "stdout".
  445. # string -    The string to be displayed.
  446.  
  447. proc tkConsoleOutput {dest string} {
  448.     .console insert output $string $dest
  449.     .console see insert
  450. }
  451.  
  452. # tkConsoleExit --
  453. #
  454. # This routine is called by ConsoleEventProc when the main window of
  455. # the application is destroyed.  Don't call exit - that probably already
  456. # happened.  Just delete our window.
  457. #
  458. # Arguments:
  459. # None.
  460.  
  461. proc tkConsoleExit {} {
  462.     destroy .
  463. }
  464.  
  465. # tkConsoleAbout --
  466. #
  467. # This routine displays an About box to show Tcl/Tk version info.
  468. #
  469. # Arguments:
  470. # None.
  471.  
  472. proc tkConsoleAbout {} {
  473.     global tk_patchLevel
  474.     tk_messageBox -type ok -message "Tcl for Windows
  475. Copyright \251 2000 Scriptics Corporation
  476.  
  477. Tcl [info patchlevel]
  478. Tk $tk_patchLevel"
  479. }
  480.  
  481. # now initialize the console
  482.  
  483. tkConsoleInit
  484.