Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | #!/bin/sh |
2 | # \ | |
3 | exec expect -- "$0" ${1+"$@"} | |
4 | # dislocate - allow disconnection and reconnection to a background program | |
5 | # Author: Don Libes, NIST | |
6 | ||
7 | exp_version -exit 5.1 | |
8 | ||
9 | # The following code attempts to intuit whether cat buffers by default. | |
10 | # The -u flag is required on HPUX (8 and 9) and IBM AIX (3.2) systems. | |
11 | if {[file exists $exp_exec_library/cat-buffers]} { | |
12 | set catflags "-u" | |
13 | } else { | |
14 | set catflags "" | |
15 | } | |
16 | # If this fails, you can also force it by commenting in one of the following. | |
17 | # Or, you can use the -catu flag to the script. | |
18 | #set catflags "" | |
19 | #set catflags "-u" | |
20 | ||
21 | set escape \035 ;# control-right-bracket | |
22 | set escape_printable "^\]" | |
23 | ||
24 | set pidfile "~/.dislocate" | |
25 | set prefix "disc" | |
26 | set timeout -1 | |
27 | set debug_flag 0 | |
28 | ||
29 | while {$argc} { | |
30 | set flag [lindex $argv 0] | |
31 | switch -- $flag \ | |
32 | "-catu" { | |
33 | set catflags "-u" | |
34 | set argv [lrange $argv 1 end] | |
35 | incr argc -1 | |
36 | } "-escape" { | |
37 | set escape [lindex $argv 1] | |
38 | set escape_printable $escape | |
39 | set argv [lrange $argv 2 end] | |
40 | incr argc -2 | |
41 | } "-debug" { | |
42 | log_file [lindex $argv 1] | |
43 | set debug_flag 1 | |
44 | set argv [lrange $argv 2 end] | |
45 | incr argc -2 | |
46 | } default { | |
47 | break | |
48 | } | |
49 | } | |
50 | ||
51 | # These are correct from parent's point of view. | |
52 | # In child, we will reset these so that they appear backwards | |
53 | # thus allowing following two routines to be used by both parent and child | |
54 | set infifosuffix ".i" | |
55 | set outfifosuffix ".o" | |
56 | ||
57 | proc infifoname {pid} { | |
58 | return "/tmp/$::prefix$pid$::infifosuffix" | |
59 | } | |
60 | ||
61 | proc outfifoname {pid} { | |
62 | return "/tmp/$::prefix$pid$::outfifosuffix" | |
63 | } | |
64 | ||
65 | proc pid_remove {pid} { | |
66 | say "removing $pid $::proc($pid)" | |
67 | ||
68 | unset ::date($pid) | |
69 | unset ::proc($pid) | |
70 | } | |
71 | ||
72 | # lines in data file look like this: | |
73 | # pid#date-started#argv | |
74 | ||
75 | # allow element lookups on empty arrays | |
76 | set date(dummy) dummy; unset date(dummy) | |
77 | set proc(dummy) dummy; unset proc(dummy) | |
78 | ||
79 | proc say {msg} { | |
80 | if {!$::debug_flag} return | |
81 | ||
82 | if {[catch {puts "parent: $msg"}]} { | |
83 | send_log "child: $msg\n" | |
84 | } | |
85 | } | |
86 | ||
87 | # load pidfile into memory | |
88 | proc pidfile_read {} { | |
89 | global date proc pidfile | |
90 | ||
91 | say "opening $pidfile" | |
92 | if {[catch {open $pidfile} fp]} return | |
93 | ||
94 | # | |
95 | # read info from file | |
96 | # | |
97 | ||
98 | say "reading pidfile" | |
99 | set line 0 | |
100 | while {[gets $fp buf]!=-1} { | |
101 | # while pid and date can't have # in it, proc can | |
102 | if {[regexp "(\[^#]*)#(\[^#]*)#(.*)" $buf junk pid xdate xproc]} { | |
103 | set date($pid) $xdate | |
104 | set proc($pid) $xproc | |
105 | } else { | |
106 | puts "warning: inconsistency in $pidfile line $line" | |
107 | } | |
108 | incr line | |
109 | } | |
110 | close $fp | |
111 | say "read $line entries" | |
112 | ||
113 | # | |
114 | # see if pids and fifos are still around | |
115 | # | |
116 | ||
117 | foreach pid [array names date] { | |
118 | if {$pid && [catch {exec /bin/kill -0 $pid}]} { | |
119 | say "$pid no longer exists, removing" | |
120 | pid_remove $pid | |
121 | continue | |
122 | } | |
123 | ||
124 | # pid still there, see if fifos are | |
125 | if {![file exists [infifoname $pid]] || ![file exists [outfifoname $pid]]} { | |
126 | say "$pid fifos no longer exists, removing" | |
127 | pid_remove $pid | |
128 | continue | |
129 | } | |
130 | } | |
131 | } | |
132 | ||
133 | proc pidfile_write {} { | |
134 | global pidfile date proc | |
135 | ||
136 | say "writing pidfile" | |
137 | ||
138 | set fp [open $pidfile w] | |
139 | foreach pid [array names date] { | |
140 | puts $fp "$pid#$date($pid)#$proc($pid)" | |
141 | say "wrote $pid#$date($pid)#$proc($pid)" | |
142 | } | |
143 | close $fp | |
144 | } | |
145 | ||
146 | proc fifo_pair_remove {pid} { | |
147 | global date proc prefix | |
148 | ||
149 | pidfile_read | |
150 | pid_remove $pid | |
151 | pidfile_write | |
152 | ||
153 | file delete -force [infifoname $pid] [outfifoname $pid] | |
154 | } | |
155 | ||
156 | proc fifo_pair_create {pid argdate argv} { | |
157 | global prefix date proc | |
158 | ||
159 | pidfile_read | |
160 | set date($pid) $argdate | |
161 | set proc($pid) $argv | |
162 | pidfile_write | |
163 | ||
164 | mkfifo [infifoname $pid] | |
165 | mkfifo [outfifoname $pid] | |
166 | } | |
167 | ||
168 | proc mkfifo {f} { | |
169 | if {[file exists $f]} { | |
170 | say "uh, fifo already exists?" | |
171 | return | |
172 | } | |
173 | ||
174 | if {0==[catch {exec mkfifo $f}]} return ;# POSIX | |
175 | if {0==[catch {exec mknod $f p}]} return | |
176 | # some systems put mknod in wierd places | |
177 | if {0==[catch {exec /usr/etc/mknod $f p}]} return ;# Sun | |
178 | if {0==[catch {exec /etc/mknod $f p}]} return ;# AIX, Cray | |
179 | puts "Couldn't figure out how to make a fifo - where is mknod?" | |
180 | exit | |
181 | } | |
182 | ||
183 | proc child {argdate argv} { | |
184 | global infifosuffix outfifosuffix | |
185 | ||
186 | disconnect | |
187 | # these are backwards from the child's point of view so that | |
188 | # we can make everything else look "right" | |
189 | set infifosuffix ".o" | |
190 | set outfifosuffix ".i" | |
191 | set pid 0 | |
192 | ||
193 | eval spawn $argv | |
194 | set proc_spawn_id $spawn_id | |
195 | ||
196 | while {1} { | |
197 | say "opening [infifoname $pid] for read" | |
198 | ||
199 | set catfid [open "|cat $::catflags < [infifoname $pid]" "r"] | |
200 | set ::catpid $catfid | |
201 | spawn -open $catfid | |
202 | set in $spawn_id | |
203 | ||
204 | say "opening [outfifoname $pid] for write" | |
205 | spawn -open [open [outfifoname $pid] w] | |
206 | set out $spawn_id | |
207 | ||
208 | fifo_pair_remove $pid | |
209 | ||
210 | say "interacting" | |
211 | interact { | |
212 | -u $proc_spawn_id eof exit | |
213 | -output $out | |
214 | -input $in | |
215 | } | |
216 | ||
217 | # parent has closed connection | |
218 | say "parent closed connection" | |
219 | catch {close -i $in} | |
220 | catch {wait -i $in} | |
221 | catch {close -i $out} | |
222 | catch {wait -i $out} | |
223 | ||
224 | # switch to using real pid | |
225 | set pid [pid] | |
226 | # put entry back | |
227 | fifo_pair_create $pid $argdate $argv | |
228 | } | |
229 | } | |
230 | ||
231 | proc escape {} { | |
232 | # export process handles so that user can get at them | |
233 | global in out | |
234 | ||
235 | puts "\nto disconnect, enter: exit (or ^D)" | |
236 | puts "to suspend, press appropriate job control sequence" | |
237 | puts "to return to process, enter: return" | |
238 | interpreter -eof exit | |
239 | puts "returning ..." | |
240 | } | |
241 | ||
242 | # interactively query user to choose process, return pid | |
243 | proc choose {} { | |
244 | while {1} { | |
245 | send_user "enter # or pid: " | |
246 | expect_user -re "(.*)\n" {set buf $expect_out(1,string)} | |
247 | if {[info exists ::index($buf)]} { | |
248 | set pid $::index($buf) | |
249 | } elseif {[info exists ::date($buf)]} { | |
250 | set pid $buf | |
251 | } else { | |
252 | puts "no such # or pid" | |
253 | continue | |
254 | } | |
255 | return $pid | |
256 | } | |
257 | } | |
258 | ||
259 | if {$argc} { | |
260 | # initial creation occurs before fork because if we do it after | |
261 | # then either the child or the parent may have to spin retrying | |
262 | # the fifo open. Unfortunately, we cannot know the pid ahead of | |
263 | # time so use "0". This will be set to the real pid when the | |
264 | # parent does its initial disconnect. There is no collision | |
265 | # problem because the fifos are deleted immediately anyway. | |
266 | ||
267 | set datearg [clock format [clock seconds]] | |
268 | ||
269 | fifo_pair_create 0 $datearg $argv | |
270 | ||
271 | # to debug by faking child, comment out fork and set pid to a | |
272 | # non-zero int, then you can read/write to pipes manually | |
273 | ||
274 | set pid [fork] | |
275 | say "after fork, pid = $pid" | |
276 | if {$pid==0} { | |
277 | child $datearg $argv | |
278 | } | |
279 | ||
280 | # parent thinks of child as pid==0 for reason given earlier | |
281 | set pid 0 | |
282 | } | |
283 | ||
284 | say "examining pid" | |
285 | ||
286 | if {![info exists pid]} { | |
287 | global fifos date proc | |
288 | ||
289 | say "pid does not exist" | |
290 | ||
291 | pidfile_read | |
292 | ||
293 | set count 0 | |
294 | foreach pid [array names date] { | |
295 | incr count | |
296 | } | |
297 | ||
298 | if {$count==0} { | |
299 | puts "no connectable processes" | |
300 | exit | |
301 | } elseif {$count==1} { | |
302 | puts "one connectable process: $proc($pid)" | |
303 | puts "pid $pid, started $date($pid)" | |
304 | send_user "connect? \[y] " | |
305 | expect_user -re "(.*)\n" {set buf $expect_out(1,string)} | |
306 | if {$buf!="y" && $buf!=""} exit | |
307 | } else { | |
308 | puts "connectable processes:" | |
309 | set count 1 | |
310 | puts " # pid date started process" | |
311 | foreach pid [array names date] { | |
312 | puts [format "%2d %6d %.19s %s" \ | |
313 | $count $pid $date($pid) $proc($pid)] | |
314 | set index($count) $pid | |
315 | incr count | |
316 | } | |
317 | set pid [choose] | |
318 | } | |
319 | } | |
320 | ||
321 | say "opening [outfifoname $pid] for write" | |
322 | spawn -noecho -open [open [outfifoname $pid] w] | |
323 | set out $spawn_id | |
324 | ||
325 | say "opening [infifoname $pid] for read" | |
326 | set catfid [open "|cat $catflags < [infifoname $pid]" "r"] | |
327 | set catpid [pid $catfid] | |
328 | spawn -noecho -open $catfid | |
329 | set in $spawn_id | |
330 | ||
331 | puts "Escape sequence is $escape_printable" | |
332 | ||
333 | proc prompt1 {} { | |
334 | return "$::argv0[history nextid]> " | |
335 | } | |
336 | ||
337 | rename exit exitReal | |
338 | ||
339 | proc exit {} { | |
340 | exec /bin/kill $::catpid | |
341 | exitReal | |
342 | } | |
343 | ||
344 | interact { | |
345 | -reset $escape escape | |
346 | -output $out | |
347 | -input $in | |
348 | } | |
349 | ||
350 |