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