Subversion Repositories or1k

#!../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
}