mingw/lib/tk8.5/demos/rmt

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