URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [expect/] [example/] [dislocate] - Blame information for rev 1774

Go to most recent revision | Details | Compare with Previous | View Log


#!../expect --
# dislocate - allow disconnection and reconnection to a background program
# Author: Don Libes, NIST
 
exp_version -exit 5.1
 
# The following code attempts to intuit whether cat buffers by default.
# The -u flag is required on HPUX (8 and 9) and IBM AIX (3.2) systems.
if [file exists $exp_exec_library/cat-buffers] {
        set catflags "-u"
} else {
        set catflags ""
}
# If this fails, you can also force it by commenting in one of the following.
# Or, you can use the -catu flag to the script.
#set catflags ""
#set catflags "-u"
 
set escape \035                 ;# control-right-bracket
set escape_printable "^\]"
 
set pidfile "~/.dislocate"
set prefix "disc"
set timeout -1
set debug_flag 0
 
while {$argc} {
        set flag [lindex $argv 0]
        switch -- $flag \
        "-catu" {
                set catflags "-u"
                set argv [lrange $argv 1 end]
                incr argc -1
        } "-escape" {
                set escape [lindex $argv 1]
                set escape_printable $escape
                set argv [lrange $argv 2 end]
                incr argc -2
        } "-debug" {
                log_file [lindex $argv 1]
                set debug_flag 1
                set argv [lrange $argv 2 end]
                incr argc -2
        } default {
                break
        }
}
 
# These are correct from parent's point of view.
# In child, we will reset these so that they appear backwards
# thus allowing following two routines to be used by both parent and child
set  infifosuffix ".i"
set outfifosuffix ".o"
 
proc infifoname {pid} {
        global prefix infifosuffix
 
        return "/tmp/$prefix$pid$infifosuffix"
}
 
proc outfifoname {pid} {
        global prefix outfifosuffix
 
        return "/tmp/$prefix$pid$outfifosuffix"
}
 
proc pid_remove {pid} {
        global date proc
 
        say "removing $pid $proc($pid)"
 
        unset date($pid)
        unset proc($pid)
}
 
# lines in data file looks like this:
# pid#date-started#argv
 
# allow element lookups on empty arrays
set date(dummy) dummy;  unset date(dummy)
set proc(dummy) dummy;  unset proc(dummy)
 
# load pidfile into memory
proc pidfile_read {} {
        global date proc pidfile
 
        if [catch {open $pidfile} fp] return
 
        #
        # read info out of file
        #
 
        say "reading pidfile"
        set line 0
        while {[gets $fp buf]!=-1} {
                # while pid and date can't have # in it, proc can
                if [regexp "(\[^#]*)#(\[^#]*)#(.*)" $buf junk pid xdate xproc] {
                        set date($pid) $xdate
                        set proc($pid) $xproc
                } else {
                        puts "warning: inconsistency in $pidfile line $line"
                }
                incr line
        }
        close $fp
        say "read $line entries"
 
        #
        # see if pids and fifos are still around
        #
 
        foreach pid [array names date] {
                if {$pid && [catch {exec /bin/kill -0 $pid}]} {
                        say "$pid no longer exists, removing"
                        pid_remove $pid
                        continue
                }
 
                # pid still there, see if fifos are
                if {![file exists [infifoname $pid]] || ![file exists [outfifoname $pid]]} {
                        say "$pid fifos no longer exists, removing"
                        pid_remove $pid
                        continue
                }
        }
}
 
proc pidfile_write {} {
        global pidfile date proc
 
        say "writing pidfile"
 
        set fp [open $pidfile w]
        foreach pid [array names date] {
                puts $fp "$pid#$date($pid)#$proc($pid)"
                say "wrote $pid#$date($pid)#$proc($pid)"
        }
        close $fp
}
 
proc fifo_pair_remove {pid} {
        global date proc prefix
 
        pidfile_read
        pid_remove $pid
        pidfile_write
 
        catch {exec rm -f [infifoname $pid] [outfifoname $pid]}
}
 
proc fifo_pair_create {pid argdate argv} {
        global prefix date proc
 
        pidfile_read
        set date($pid) $argdate
        set proc($pid) $argv
        pidfile_write
 
        mkfifo [infifoname $pid]
        mkfifo [outfifoname $pid]
}
 
proc mkfifo {f} {
        if [file exists $f] {
                say "uh, fifo already exists?"
                return
        }
 
        if 0==[catch {exec mkfifo $f}] return           ;# POSIX
        if 0==[catch {exec mknod $f p}] return
        # some systems put mknod in wierd places
        if 0==[catch {exec /usr/etc/mknod $f p}] return ;# Sun
        if 0==[catch {exec /etc/mknod $f p}] return     ;# AIX, Cray
        puts "Couldn't figure out how to make a fifo - where is mknod?"
        exit
}
 
proc child {argdate argv} {
        global catflags infifosuffix outfifosuffix
 
        disconnect
 
        # these are backwards from the child's point of view so that
        # we can make everything else look "right"
        set  infifosuffix ".o"
        set outfifosuffix ".i"
        set pid 0
 
        eval spawn $argv
        set proc_spawn_id $spawn_id
 
        while {1} {
                say "opening [infifoname $pid] for read"
                spawn -open [open "|cat $catflags < [infifoname $pid]" "r"]
                set in $spawn_id
 
                say "opening [outfifoname $pid] for write"
                spawn -open [open [outfifoname $pid] w]
                set out $spawn_id
 
                fifo_pair_remove $pid
 
                say "interacting"
                interact {
                        -u $proc_spawn_id eof exit
                        -output $out
                        -input $in
                }
 
                # parent has closed connection
                say "parent closed connection"
                catch {close -i $in}
                catch {wait -i $in}
                catch {close -i $out}
                catch {wait -i $out}
 
                # switch to using real pid
                set pid [pid]
                # put entry back
                fifo_pair_create $pid $argdate $argv
        }
}
 
proc say {msg} {
        global debug_flag
 
        if !$debug_flag return
 
        if [catch {puts "parent: $msg"}] {
                send_log "child: $msg\n"
        }
}
 
proc escape {} {
        # export process handles so that user can get at them
        global in out
 
        puts "\nto disconnect, enter: exit (or ^D)"
        puts "to suspend, press appropriate job control sequence"
        puts "to return to process, enter: return"
        interpreter
        puts "returning ..."
}
 
# interactively query user to choose process, return pid
proc choose {} {
        global index date
 
        while 1 {
                send_user "enter # or pid: "
                expect_user -re "(.*)\n" {set buf $expect_out(1,string)}
                if [info exists index($buf)] {
                        set pid $index($buf)
                } elseif [info exists date($buf)] {
                        set pid $buf
                } else {
                        puts "no such # or pid"
                        continue
                }
                return $pid
        }
}
 
if {$argc} {
        # initial creation occurs before fork because if we do it after
        # then either the child or the parent may have to spin retrying
        # the fifo open.  Unfortunately, we cannot know the pid ahead of
        # time so use "0".  This will be set to the real pid when the
        # parent does its initial disconnect.  There is no collision
        # problem because the fifos are deleted immediately anyway.
 
        set datearg [exec date]
        fifo_pair_create 0 $datearg $argv
 
        set pid [fork]
        say "after fork, pid = $pid"
        if $pid==0 {
                child $datearg $argv
        }
        # parent thinks of child as pid==0 for reason given earlier
        set pid 0
}
 
say "examining pid"
 
if ![info exists pid] {
        global fifos date proc
 
        say "pid does not exist"
 
        pidfile_read
 
        set count 0
        foreach pid [array names date] {
                incr count
        }
 
        if $count==0 {
                puts "no connectable processes"
                exit
        } elseif $count==1 {
                puts "one connectable process: $proc($pid)"
                puts "pid $pid, started $date($pid)"
                send_user "connect? \[y] "
                expect_user -re "(.*)\n" {set buf $expect_out(1,string)}
                if {$buf!="y" && $buf!=""} exit
        } else {
                puts "connectable processes:"
                set count 1
                puts " #   pid      date started      process"
                foreach pid [array names date] {
                        puts [format "%2d %6d  %.19s  %s" \
                                $count $pid $date($pid) $proc($pid)]
                        set index($count) $pid
                        incr count
                }
                set pid [choose]
        }
}
 
say "opening [outfifoname $pid] for write"
spawn -noecho -open [open [outfifoname $pid] w]
set out $spawn_id
 
say "opening [infifoname $pid] for read"
spawn -noecho -open [open "|cat $catflags < [infifoname $pid]" "r"]
set in $spawn_id
 
puts "Escape sequence is $escape_printable"
 
proc prompt1 {} {
        global argv0
 
        return "$argv0[history nextid]> "
}
 
interact {
        -reset $escape escape
        -output $out
        -input $in
}
 

Browse

Tools

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [expect/] [example/] [dislocate] - Blame information for rev 1774

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