/usr/bin/expect_dislocate is in expect 5.45-6.
This file is owned by root:root, with mode 0o755.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 | #!/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
}
|