util/X86LINUX64/lib/tk8.6/demos/rmt

   1 #!/bin/sh
   2 # the next line restarts using wish \
   3 exec wish8.6 "$0" ${1+"$@"}
   4
   5 # rmt --
   6 # This script implements a simple remote-control mechanism for
   7 # Tk applications.  It allows you to select an application and
   8 # then type commands to that application.
   9
  10 package require Tcl 8.4
  11 package require Tk
  12
  13 wm title . "Tk Remote Controller"
  14 wm iconname . "Tk Remote"
  15 wm minsize . 1 1
  16
  17 # The global variable below keeps track of the remote application
  18 # that we're sending to.  If it's an empty string then we execute
  19 # the commands locally.
  20
  21 set app "local"
  22
  23 # The global variable below keeps track of whether we're in the
  24 # middle of executing a command entered via the text.
  25
  26 set executing 0
  27
  28 # The global variable below keeps track of the last command executed,
  29 # so it can be re-executed in response to !! commands.
  30
  31 set lastCommand ""
  32
  33 # Create menu bar.  Arrange to recreate all the information in the
  34 # applications sub-menu whenever it is cascaded to.
  35
  36 . configure -menu [menu .menu]
  37 menu .menu.file
  38 menu .menu.file.apps  -postcommand fillAppsMenu
  39 .menu add cascade  -label "File"  -underline 0  -menu .menu.file
  40 .menu.file add cascade  -label "Select Application"  -underline 0 \
  41         -menu .menu.file.apps
  42 .menu.file add command  -label "Quit"  -command "destroy ."  -underline 0
  43
  44 # Create text window and scrollbar.
  45
  46 text .t -yscrollcommand ".s set" -setgrid true
  47 scrollbar .s -command ".t yview"
  48 grid .t .s -sticky nsew
  49 grid rowconfigure . 0 -weight 1
  50 grid columnconfigure . 0 -weight 1
  51
  52 # Create a binding to forward commands to the target application,
  53 # plus modify many of the built-in bindings so that only information
  54 # in the current command can be deleted (can still set the cursor
  55 # earlier in the text and select and insert;  just can't delete).
  56
  57 bindtags .t {.t Text . all}
  58 bind .t <Return> {
  59     .t mark set insert {end - 1c}
  60     .t insert insert \n
  61     invoke
  62     break
  63 }
  64 bind .t <Delete> {
  65     catch {.t tag remove sel sel.first promptEnd}
  66     if {[.t tag nextrange sel 1.0 end] eq ""} {
  67         if {[.t compare insert < promptEnd]} {
  68             break
  69         }
  70     }
  71 }
  72 bind .t <BackSpace> {
  73     catch {.t tag remove sel sel.first promptEnd}
  74     if {[.t tag nextrange sel 1.0 end] eq ""} {
  75         if {[.t compare insert <= promptEnd]} {
  76             break
  77         }
  78     }
  79 }
  80 bind .t <Control-d> {
  81     if {[.t compare insert < promptEnd]} {
  82         break
  83     }
  84 }
  85 bind .t <Control-k> {
  86     if {[.t compare insert < promptEnd]} {
  87         .t mark set insert promptEnd
  88     }
  89 }
  90 bind .t <Control-t> {
  91     if {[.t compare insert < promptEnd]} {
  92         break
  93     }
  94 }
  95 bind .t <Meta-d> {
  96     if {[.t compare insert < promptEnd]} {
  97         break
  98     }
  99 }
 100 bind .t <Meta-BackSpace> {
 101     if {[.t compare insert <= promptEnd]} {
 102         break
 103     }
 104 }
 105 bind .t <Control-h> {
 106     if {[.t compare insert <= promptEnd]} {
 107         break
 108     }
 109 }
 110 ### This next bit *isn't* nice - DKF ###
 111 auto_load tk::TextInsert
 112 proc tk::TextInsert {w s} {
 113     if {$s eq ""} {
 114         return
 115     }
 116     catch {
 117         if {
 118             [$w compare sel.first <= insert] && [$w compare sel.last >= insert]
 119         } then {
 120             $w tag remove sel sel.first promptEnd
 121             $w delete sel.first sel.last
 122         }
 123     }
 124     $w insert insert $s
 125     $w see insert
 126 }
 127
 128 .t configure -font {Courier 12}
 129 .t tag configure bold -font {Courier 12 bold}
 130
 131 # The procedure below is used to print out a prompt at the
 132 # insertion point (which should be at the beginning of a line
 133 # right now).
 134
 135 proc prompt {} {
 136     global app
 137     .t insert insert "$app: "
 138     .t mark set promptEnd {insert}
 139     .t mark gravity promptEnd left
 140     .t tag add bold {promptEnd linestart} promptEnd
 141 }
 142
 143 # The procedure below executes a command (it takes everything on the
 144 # current line after the prompt and either sends it to the remote
 145 # application or executes it locally, depending on "app".
 146
 147 proc invoke {} {
 148     global app executing lastCommand
 149     set cmd [.t get promptEnd insert]
 150     incr executing 1
 151     if {[info complete $cmd]} {
 152         if {$cmd eq "!!\n"} {
 153             set cmd $lastCommand
 154         } else {
 155             set lastCommand $cmd
 156         }
 157         if {$app eq "local"} {
 158             set result [catch [list uplevel #0 $cmd] msg]
 159         } else {
 160             set result [catch [list send $app $cmd] msg]
 161         }
 162         if {$result != 0} {
 163             .t insert insert "Error: $msg\n"
 164         } elseif {$msg ne ""} {
 165             .t insert insert $msg\n
 166         }
 167         prompt
 168         .t mark set promptEnd insert
 169     }
 170     incr executing -1
 171     .t yview -pickplace insert
 172 }
 173
 174 # The following procedure is invoked to change the application that
 175 # we're talking to.  It also updates the prompt for the current
 176 # command, unless we're in the middle of executing a command from
 177 # the text item (in which case a new prompt is about to be output
 178 # so there's no need to change the old one).
 179
 180 proc newApp appName {
 181     global app executing
 182     set app $appName
 183     if {!$executing} {
 184         .t mark gravity promptEnd right
 185         .t delete "promptEnd linestart" promptEnd
 186         .t insert promptEnd "$appName: "
 187         .t tag add bold "promptEnd linestart" promptEnd
 188         .t mark gravity promptEnd left
 189     }
 190     return
 191 }
 192
 193 # The procedure below will fill in the applications sub-menu with a list
 194 # of all the applications that currently exist.
 195
 196 proc fillAppsMenu {} {
 197     set m .menu.file.apps
 198     catch {$m delete 0 last}
 199     foreach i [lsort [winfo interps]] {
 200         $m add command -label $i -command [list newApp $i]
 201     }
 202     $m add command -label local -command {newApp local}
 203 }
 204
 205 set app [winfo name .]
 206 prompt
 207 focus .t
 208
 209 # Local Variables:
 210 # mode: tcl
 211 # End: