File: //bin/dislocate
#!/bin/sh
# -*- tcl -*-
# The next line is executed by /bin/sh, but not tcl \
exec tclsh8.6 "$0" ${1+"$@"}
package require 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} {
return "/tmp/$::prefix$pid$::infifosuffix"
}
proc outfifoname {pid} {
return "/tmp/$::prefix$pid$::outfifosuffix"
}
proc pid_remove {pid} {
say "removing $pid $::proc($pid)"
unset ::date($pid)
unset ::proc($pid)
}
# lines in data file look 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)
proc say {msg} {
if {!$::debug_flag} return
if {[catch {puts "parent: $msg"}]} {
send_log "child: $msg\n"
}
}
# load pidfile into memory
proc pidfile_read {} {
global date proc pidfile
say "opening $pidfile"
if {[catch {open $pidfile} fp]} return
#
# read info from 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
file delete -force [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 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"
set catfid [open "|cat $::catflags < [infifoname $pid]" "r"]
set ::catpid $catfid
spawn -open $catfid
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 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 -eof exit
puts "returning ..."
}
# interactively query user to choose process, return pid
proc choose {} {
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 [clock format [clock seconds]]
fifo_pair_create 0 $datearg $argv
# to debug by faking child, comment out fork and set pid to a
# non-zero int, then you can read/write to pipes manually
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"
set catfid [open "|cat $catflags < [infifoname $pid]" "r"]
set catpid [pid $catfid]
spawn -noecho -open $catfid
set in $spawn_id
puts "Escape sequence is $escape_printable"
proc prompt1 {} {
return "$::argv0[history nextid]> "
}
rename exit exitReal
proc exit {} {
exec /bin/kill $::catpid
exitReal
}
interact {
-reset $escape escape
-output $out
-input $in
}