home *** CD-ROM | disk | FTP | other *** search
/ Practical Programming in Tcl & Tk (4th Edition) / TCLBOOK4.BIN / mac / exsource.old / 23_4.tcl < prev    next >
Text File  |  2003-04-15  |  3KB  |  135 lines
  1. #
  2. # Example 23-4
  3. # A Tcl shell in a text widget.
  4. #
  5.  
  6. #!/usr/local/bin/wish
  7. # Simple evaluator. It executes Tcl in a slave interpreter
  8.  
  9. set t [Scrolled_Text .eval -width 80 -height 10]
  10. pack .eval -fill both -expand true
  11.  
  12. # Text tags give script output, command errors, command
  13. # results, and the prompt a different appearance
  14.  
  15. $t tag configure prompt -underline true
  16. $t tag configure result -foreground purple
  17. $t tag configure error -foreground red
  18. $t tag configure output -foreground blue
  19.  
  20. # Insert the prompt and initialize the limit mark
  21.  
  22. set eval(prompt) "tcl> "
  23. $t insert insert $eval(prompt) prompt
  24. $t mark set limit insert
  25. $t mark gravity limit left
  26. focus $t
  27. set eval(text) $t
  28.  
  29. # Key bindings that limit input and eval things. The break in
  30. # the bindings skips the default Text binding for the event.
  31.  
  32. bind $t <Return> {EvalTypein ; break}
  33. bind $t <BackSpace> {
  34.     if {[%W tag nextrange sel 1.0 end] != ""} {
  35.         %W delete sel.first sel.last
  36.     } elseif {[%W compare insert > limit]} {
  37.         %W delete insert-1c
  38.         %W see insert
  39.     }
  40.     break
  41. }
  42. bind $t <Key> {
  43.     if [%W compare insert < limit] {
  44.         %W mark set insert end
  45.     }
  46. }
  47.  
  48. # Evaluate everything between limit and end as a Tcl command
  49.  
  50. proc EvalTypein {} {
  51.     global eval
  52.     $eval(text) insert insert \n
  53.     set command [$eval(text) get limit end]
  54.     if [info complete $command] {
  55.         $eval(text) mark set limit insert
  56.         Eval $command
  57.     }
  58. }
  59.  
  60. # Echo the command and evaluate it
  61.  
  62. proc EvalEcho {command} {
  63.     global eval
  64.     $eval(text) mark set insert end
  65.     $eval(text) insert insert $command\n
  66.     Eval $command
  67. }
  68.  
  69. # Evaluate a command and display its result
  70.  
  71. proc Eval {command} {
  72.     global eval
  73.     $eval(text) mark set insert end
  74.     if [catch {$eval(slave) eval $command} result] {
  75.         $eval(text) insert insert $result error
  76.     } else {
  77.         $eval(text) insert insert $result result
  78.     }
  79.     if {[$eval(text) compare insert != "insert linestart"]} {
  80.         $eval(text) insert insert \n
  81.     }
  82.     $eval(text) insert insert $eval(prompt) prompt
  83.     $eval(text) see insert
  84.     $eval(text) mark set limit insert
  85.     return
  86. }
  87. # Create and initialize the slave interpreter
  88.  
  89. proc SlaveInit {slave} {
  90.     interp create $slave
  91.     load {} Tk $slave
  92.     interp alias $slave reset {} ResetAlias $slave
  93.     interp alias $slave puts {} PutsAlias $slave
  94.     return $slave
  95. }
  96.  
  97. # The reset alias deletes the slave and starts a new one
  98.  
  99. proc ResetAlias {slave} {
  100.     interp delete $slave
  101.     SlaveInit $slave
  102. }
  103.  
  104. # The puts alias puts stdout and stderr into the text widget
  105.  
  106. proc PutsAlias {slave args} {
  107.     if {[llength $args] > 3} {
  108.         error "invalid arguments"
  109.     }
  110.     set newline "\n"
  111.     if {[string match "-nonewline" [lindex $args 0]]} {
  112.         set newline ""
  113.         set args [lreplace $args 0 0]
  114.     }
  115.     if {[llength $args] == 1} {
  116.         set chan stdout
  117.         set string [lindex $args 0]$newline
  118.     } else {
  119.         set chan [lindex $args 0]
  120.         set string [lindex $args 1]$newline
  121.     }
  122.     if [regexp (stdout|stderr) $chan] {
  123.         global eval
  124.         $eval(text) mark gravity limit right
  125.         $eval(text) insert limit $string output
  126.         $eval(text) see limit
  127.         $eval(text) mark gravity limit left
  128.     } else {
  129.         puts -nonewline $chan $string
  130.     }
  131. }
  132. set eval(slave) [SlaveInit shell]
  133.  
  134.  
  135.