Revise stty settings used in testsuite

[dejagnu.git] / lib / remote.exp

# Copyright (C) 1992-2019, 2020 Free Software Foundation, Inc.
#
# This file is part of DejaGnu.
#
# DejaGnu is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or
# (at your option) any later version.
#
# DejaGnu is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with DejaGnu; if not, write to the Free Software Foundation,
# Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1301, USA.

# This file was written by Rob Savoye <rob@welcomehome.org>.

# Load various protocol support modules.

load_lib "telnet.exp"
load_lib "rlogin.exp"
load_lib "kermit.exp"
load_lib "tip.exp"
load_lib "rsh.exp"
load_lib "ssh.exp"
load_lib "ftp.exp"

# Open a connection to a remote host or target. This requires the target_info
# array be filled in with the proper info to work.
#
# type is either "build", "host", "target", or the name of a board loaded
# into the board_info array. The default is target if no name is supplied.
# It returns the spawn id of the process that is the connection.
#
proc remote_open { args } {
    global reboot

    if { [llength $args] == 0 } {
        set type "target"
    } else {
        set type $args
    }

    # Shudder...
    if { $reboot && $type eq "target" } {
        reboot_target
    }

    return [call_remote "" open $type]
}

proc remote_raw_open { args } {
    return [eval call_remote raw open $args]
}

# Close a spawn ID, and wait for the process to die.  If PID is not
# -1, then the process is killed if it doesn't exit gracefully.
#
proc close_wait_program { program_id pid {wres_varname ""} } {
    if {$wres_varname ne "" } {
        upvar 1 $wres_varname wres
    }

    set exec_pid -1

    if { $pid > 0 } {
        # Tcl has no kill primitive, so we have to execute an external
        # command in order to kill the process.
        verbose "doing kill, pid is $pid"
        # Send SIGINT to give the program a better chance to interrupt
        # whatever it might be doing and react to stdin closing.
        # eg, in case of GDB, this should get it back to the prompt.
        # Do so separately for each PID in the list to avoid differences
        # in return value behavior for kill between shells
        foreach spid $pid {
            # Prepend "-" to generate the "process group ID" needed by
            # kill.
            exec sh -c "exec > /dev/null 2>&1 && (kill -2 -$spid || kill -2 $spid)"
        }

        # If the program doesn't exit gracefully when stdin closes,
        # we'll need to kill it.  But only do this after 'wait'ing a
        # bit, to avoid killing the wrong process in case of a
        # PID-reuse race.  The extra sleep at the end is there to give
        # time to kill $exec_pid without having _that_ be subject to a
        # PID reuse race.
        set secs 5
        set sh_cmd "exec > /dev/null 2>&1"
        append sh_cmd " && sleep $secs && ("
        foreach spid $pid {
            append sh_cmd "(kill -15 -$spid || kill -15 $spid);"
        }
        append sh_cmd ") && sleep $secs && ("
        foreach spid $pid {
            append sh_cmd "(kill -9 -$spid || kill -9 $spid);"
        }
        append sh_cmd ") && sleep $secs"
        set exec_pid [exec sh -c $sh_cmd &]
    }
    verbose "pid is $pid"

    # This closes the program's stdin.  This should cause well behaved
    # interactive programs to exit.  This will hang if the kill
    # doesn't work.  Nothin' to do, and it's not OK.
    catch "close -i $program_id"

    # Reap it.
    set res [catch "wait -i $program_id" wres]
    if { $exec_pid != -1 && [llength $pid] == 1 } {
        # We reaped the process, so cancel the pending force-kills, as
        # otherwise if the PID is reused for some other unrelated
        # process, we'd kill the wrong process.
        #
        # Do this if the PID list only has a single entry however, as
        # otherwise `wait' will have returned right away regardless of
        # whether any process of the pipeline has exited.
        #
        # Use `catch' in case the force-kills have completed, so as not
        # to cause TCL to choke if `kill' returns a failure.
        catch {exec sh -c "kill -9 $exec_pid" >& /dev/null}
    }

    return $res
}

# Run the specified COMMANDLINE on the local machine, redirecting
# input from file INP (if non-empty), redirecting output to file OUTP
# (if non-empty), and waiting TIMEOUT seconds for the command to
# complete before killing it. A list of two elements is returned: the
# first member is the exit status of the command, the second is any
# output produced from the command (if output is redirected, this may
# or may not be empty). If output is redirected, both stdout and
# stderr will appear in the specified file.
#
# Caveats: A pipeline is used if input or output is redirected. There
# will be problems with killing the program if a pipeline is used. Either
# the "tee" command or the "cat" command is used in the pipeline if input
# or output is redirected. If the program needs to be killed, /bin/sh and
# the kill command will be invoked.
#
proc local_exec { commandline inp outp timeout } {
    # Tcl's exec is a pile of crap. It does two very inappropriate things.
    # Firstly, it has no business returning an error if the program being
    # executed happens to write to stderr. Secondly, it appends its own
    # error messages to the output of the command if the process exits with
    # non-zero status.
    #
    # So, ok, we do this funny stuff with using spawn sometimes and
    # open others because of spawn's inability to invoke commands with
    # redirected I/O. We also hope that nobody passes in a command that's
    # a pipeline, because spawn can't handle it.
    #
    # We want to use spawn in most cases, because Tcl's pipe mechanism
    # doesn't assign process groups correctly and we can't reliably kill
    # programs that bear children. We can't use Tcl's exec because it has
    # no way to timeout programs that hang.
    #
    # The expect command will close the connection when it sees
    # EOF. Closing the connection may send SIGHUP to the child and
    # cause it to exit before it can exit normally.  The child should
    # ignore SIGHUP.
    global errorInfo
    if { $inp eq "" && $outp eq "" } {
        set id -1
        set result [catch "eval spawn -ignore SIGHUP \{${commandline}\}" pid]
        if { $result == 0 } {
            set result2 0
        } else {
            set pid 0
            set result2 5
        }
    } else {
        # Use a command pipeline with open.
        if { $inp ne "" } {
            set inp "< $inp"
            set mode "r"
        } else {
            set mode "w"
        }

        set use_tee 0
        # We add |& cat so that Tcl exec doesn't freak out if the
        # program writes to stderr.
        if { $outp eq "" } {
            set outp "|& cat"
        } else {
            set outpf $outp
            set outp "> $outp"
            if { $inp ne "" } {
                set use_tee 1
            }
        }
        # Why do we use tee? Because open can't redirect both input and output.
        if { $use_tee } {
            set result [catch {open "| $commandline $inp |& tee $outpf" RDONLY} id]
        } else {
            set result [catch {open "| $commandline $inp $outp" $mode} id]
        }

        if { $result != 0 } {
            return [list -1 "open of $commandline $inp $outp failed: $errorInfo"]
        }
        set pid [pid $id]
        set result [catch "spawn -ignore SIGHUP -leaveopen $id" result2]
    }
    # Prepend "-" to each pid, to generate the "process group IDs" needed by
    # kill.
    set pgid "-[join $pid { -}]"
    verbose "pid is $pid $pgid"
    if { $result != 0 || $result2 != 0 } {
        # This shouldn't happen.
        if {[info exists errorInfo]} {
            set foo $errorInfo
        } else {
            set foo ""
        }
        verbose "spawn -open $id failed, $result $result2, $foo"
        catch "close $id"
        return [list -1 "spawn failed"]
    }

    set got_eof 0
    set output ""

    # Wait for either $timeout seconds to elapse, or for the program to
    # exit.
    expect {
        -i $spawn_id -timeout $timeout -re ".+" {
            append output $expect_out(buffer)
            exp_continue -continue_timer
        }
        timeout {
            warning "program timed out"
        }
        eof {
            set got_eof 1
        }
    }

    # If we didn't get EOF, we have to kill the poor defenseless program.
    if { $got_eof } {
        set pid -1
    }
    set r2 [close_wait_program $spawn_id $pid wres]
    if { $id > 0 } {
        if { $pid > 0 } {
            # If timed-out, don't wait for all the processes associated
            # with the pipeline to terminate as a stuck one would cause
            # us to hang.
            catch {fconfigure $id -blocking false}
        }
        set r2 [catch "close $id" res]
    } else {
        verbose "waitres is $wres" 2
        if { $r2 == 0 } {
            set r2 [lindex $wres 3]
            if { [llength $wres] > 4 } {
                if { [lindex $wres 4] eq "CHILDKILLED" } {
                    set r2 1
                }
            }
            if { $r2 != 0 } {
                set res $wres
            } else {
                set res ""
            }
        } else {
            set res "wait failed"
        }
    }
    if { $r2 != 0 || $res ne "" || ! $got_eof } {
        verbose "close result is $res"
        set status 1
    } else {
        set status 0
    }
    verbose "output is $output status $status"
    if { $outp eq "" || $outp eq "|& cat" } {
        return [list $status $output]
    } else {
        return [list $status ""]
    }
}

#
# Execute the supplied program on HOSTNAME. There are four optional arguments
# the first is a set of arguments to pass to PROGRAM, the second is an
# input file to feed to stdin of PROGRAM, the third is the name of an
# output file where the output from PROGRAM should be written, and
# the fourth is a timeout value (we give up after the specified # of seconds
# has elapsed).
#
# A two-element list is returned. The first value is the exit status of the
# program (-1 if the exec failed). The second is any output produced by
# the program (which may or may not be empty if output from the program was
# redirected).
#
proc remote_exec { hostname program args } {
    if { [llength $args] > 0 } {
        set pargs [lindex $args 0]
    } else {
        set pargs ""
    }

    if { [llength $args] > 1 } {
        set inp "[lindex $args 1]"
    } else {
        set inp ""
    }

    if { [llength $args] > 2 } {
        set outp "[lindex $args 2]"
    } else {
        set outp ""
    }

    # call_remote below gets its timeout from global variable, so set
    # it here.
    global timeout
    set old_timeout $timeout
    # 300 is probably a lame default.
    if { [llength $args] > 3 } {
        set timeout "[lindex $args 3]"
    } else {
        set timeout 300
    }

    verbose -log "Executing on $hostname: $program $pargs $inp $outp (timeout = $timeout)" 2

    # Run it locally if appropriate.
    if { ![isremote $hostname] } {
        set result [local_exec "$program $pargs" $inp $outp $timeout]
    } else {
        if { [board_info $hostname exists remotedir] } {
            set remotedir [board_info $hostname remotedir]
            # This is a bit too clever. Join cd $remotedir and
            # $program on the command line with ';' and not '&&'. When
            # called, $program may be mkdir to initially create the
            # remote directory, in which case cd would fail.
            set program "test -d $remotedir && cd $remotedir; $program"
        }
        set result [call_remote "" exec $hostname $program $pargs $inp $outp]
    }

    # Restore timeout.
    set timeout $old_timeout
    return $result
}

proc standard_exec { hostname args } {
    return [eval rsh_exec \"$hostname\" $args]
}

# Close the remote connection.
#       arg - This is the name of the machine whose connection we're closing,
#             or target, host or build.
#
proc remote_close { host } {
    while { 1 } {
        set result [call_remote "" close $host]
        if { [remote_pop_conn $host] ne "pass" } {
            break
        }
    }
    return $result
}

proc remote_raw_close { host } {
    return [call_remote raw close $host]
}

proc standard_close { host } {
    global board_info

    if {[board_info $host exists fileid]} {
        set shell_id [board_info $host fileid]
        set pid -1

        verbose "Closing the remote shell $shell_id" 2
        if {[board_info $host exists fileid_origid]} {
            set oid [board_info $host fileid_origid]
            set pid [pid $oid]
            unset board_info($host,fileid_origid)
        } else {
            set result [catch "exp_pid -i $shell_id" pid]
            if { $result != 0 || $pid <= 0 } {
                set result [catch "pid $shell_id" pid]
                if { $result != 0 } {
                    set pid -1
                }
            }
        }

        close_wait_program $shell_id $pid

        if {[info exists oid]} {
            if { $pid > 0 } {
                # Don't wait for all the processes associated with the
                # pipeline to terminate as a stuck one would cause us
                # to hang.
                catch {fconfigure $oid -blocking false}
            }
            catch "close $oid"
        }

        unset board_info($host,fileid)
        verbose "Shell closed."
    }
    return 0
}

# Set the connection into "binary" mode, a.k.a. no processing of input
# characters.
#
proc remote_binary { host } {
    return [call_remote "" binary $host]
}

proc remote_raw_binary { host } {
    return [call_remote raw binary $host]
}

\f
# Return value of this function depends on actual implementation of reboot that
# will be used, in practice it is expected that remote_reboot returns 1 on
# success and 0 on failure.
#
proc remote_reboot { host } {
    clone_output "\nRebooting $host\n"
    # FIXME: don't close the host connection, or all the remote
    # procedures will fail.
    # remote_close $host
    set status [call_remote "" reboot $host]
    if {[board_info $host exists name]} {
        set host [board_info $host name]
    }
    if { [info procs ${host}_init] ne "" } {
        ${host}_init $host
    }
    return $status
}

# It looks like that this proc is never called, instead ${board}_reboot defined
# in base-config.exp will be used because it has higher priority and
# base-config.exp is always imported by runtest.
#
proc standard_reboot { host } {
    return 1
}
#
# Download file FILE to DEST. If the optional DESTFILE is specified,
# that file will be used on the destination board. It returns either
# "" (indicating that the download failed), or the name of the file on
# the destination machine.
#

proc remote_download { dest file args } {
    if { [llength $args] > 0 } {
        set destfile [lindex $args 0]
    } else {
        set destfile [file tail $file]
    }

    if { ![isremote $dest] } {
        if { $destfile eq "" || $destfile == $file } {
            return $file
        } else {
            verbose -log "Downloading on $dest to $destfile: $file" 2
            set result [catch "exec cp -p $file $destfile" output]
            if {[regexp "same file|are identical" $output]} {
                set result 0
                set output ""
            } else {
                # try to make sure we can read it
                # and write it (in case we copy onto it again)
                catch {exec chmod u+rw $destfile}
            }
            if { $result != 0 || $output ne "" } {
                perror "remote_download to $dest of $file to $destfile: $output"
                return ""
            } else {
                return $destfile
            }
        }
    }
    if { [board_info $dest exists remotedir] } {
        set remotedir [board_info $dest remotedir]
        set status [remote_exec $dest mkdir "-p $remotedir"]
        if { [lindex $status 0] != 0 } {
            perror "Couldn't create remote directory $remotedir on $dest"
            return ""
        }
        set destfile $remotedir/$destfile
    }

    return [call_remote "" download $dest $file $destfile]
}

# The default download procedure. Uses rcp to download to $dest.
#
proc standard_download {dest file destfile} {
    set orig_destfile $destfile

    if {[board_info $dest exists nfsdir]} {
        set destdir [board_info $dest nfsdir]
        if {[board_info $dest exists nfsroot_server]} {
            set dest [board_info $dest nfsroot_server]
        } else {
            set dest ""
        }
        set destfile $destdir/$destfile
    }

    if { $dest ne "" } {
        set result [rsh_download $dest $file $destfile]
        if { $result eq $destfile } {
            return $orig_destfile
        } else {
            return $result
        }
    }

    set result [catch "exec cp -p $file $destfile" output]
    if {[regexp "same file|are identical" $output]} {
        set result 0
        set output ""
    } else {
        # try to make sure we can read it
        # and write it (in case we copy onto it again)
        catch {exec chmod u+rw $destfile}
    }
    if { $result != 0 || $output ne "" } {
        perror "remote_download to $dest of $file to $destfile: $output"
        return ""
    } else {
        return $orig_destfile
    }
}

proc remote_upload {dest srcfile args} {
    if { [llength $args] > 0 } {
        set destfile [lindex $args 0]
    } else {
        set destfile [file tail $srcfile]
    }

    if { ![isremote $dest] } {
        if { $destfile eq "" || $srcfile eq $destfile } {
            return $srcfile
        }
        set result [catch "exec cp -p $srcfile $destfile" output]
        return $destfile
    }

    return [call_remote "" upload $dest $srcfile $destfile]
}

proc standard_upload { dest srcfile destfile } {
    set orig_srcfile $srcfile

    if {[board_info $dest exists nfsdir]} {
        set destdir [board_info $dest nfsdir]
        if {[board_info $dest exists nfsroot_server]} {
            set dest [board_info $dest nfsroot_server]
        } else {
            set dest ""
        }
        set srcfile $destdir/$srcfile
    }

    if { $dest ne "" } {
        return [rsh_upload $dest $srcfile $destfile]
    }

    set result [catch "exec cp -p $srcfile $destfile" output]
    if {[regexp "same file|are identical" $output]} {
        set result 0
        set output ""
    } else {
        # try to make sure we can read it
        # and write it (in case we copy onto it again)
        catch {exec chmod u+rw $destfile}
    }
    if { $result != 0 || $output ne "" } {
        perror "remote_upload to $dest of $srcfile to $destfile: $output"
        return ""
    } else {
        return $destfile
    }
}

# A standard procedure to call the appropriate function. It first looks
# for a board-specific version, then a version specific to the protocol,
# and then finally it will call standard_$proc.
#
proc call_remote { type proc dest args } {
    if {[board_info $dest exists name]} {
        set dest [board_info $dest name]
    }

    if { $proc eq "reboot" } {
        regsub {/.*} $dest "" dest
        verbose "Changed dest to $dest"
    }

    if { $dest ne "host" && $dest ne "build" && $dest ne "target" } {
        if { ![board_info $dest exists name] } {
            global board

            if {[info exists board]} {
                error "board exists"
            }
            load_board_description $dest
            if { $proc eq "reboot" } {
                regsub {/.*} $dest "" dest
                verbose "Changed dest to $dest"
            }
        }
    }

    set high_prot ""
    if { $type ne "raw" } {
        if {[board_info $dest exists protocol]} {
            set high_prot "$dest [board_info $dest protocol]"
        } else {
            set high_prot "$dest [board_info $dest generic_name]"
        }
    }

    verbose "call_remote $type $proc $dest $args " 3
    # Close has to be handled specially.
    if { $proc eq "close" || $proc eq "open" } {
        foreach try "$high_prot [board_info $dest connect] telnet standard" {
            if { $try ne "" } {
                if { [info procs "${try}_${proc}"] ne "" } {
                    verbose "call_remote calling ${try}_${proc}" 3
                    set result [eval ${try}_${proc} \"$dest\" $args]
                    break
                }
            }
        }
        set ft "[board_info $dest file_transfer]"
        if { [info procs "${ft}_${proc}"] ne "" } {
            verbose "calling ${ft}_${proc} $dest $args" 3
            set result2 [eval ${ft}_${proc} \"$dest\" $args]
        }
        if {![info exists result]} {
            if {[info exists result2]} {
                set result $result2
            } else {
                set result ""
            }
        }
        return $result
    }
    foreach try "$high_prot [board_info $dest file_transfer] [board_info $dest connect] telnet standard" {
        verbose "looking for ${try}_${proc}" 4
        if { $try ne "" } {
            if { [info procs "${try}_${proc}"] ne "" } {
                verbose "call_remote calling ${try}_${proc}" 3
                return [eval ${try}_${proc} \"$dest\" $args]
            }
        }
    }
    if { $proc eq "close" } {
        return ""
    }
    error "No procedure for '$proc' in call_remote"
}

# Send FILE through the existing session established to DEST.
#
proc remote_transmit { dest file } {
    return [call_remote "" transmit $dest $file]
}

proc remote_raw_transmit { dest file } {
    return [call_remote raw transmit $dest $file]
}

# The default transmit procedure if no other exists. This feeds the
# supplied file directly into the connection.
#
proc standard_transmit {dest file} {
    if {[board_info $dest exists name]} {
        set dest [board_info $dest name]
    }
    if {[board_info $dest exists baud]} {
        set baud [board_info $dest baud]
    } else {
        set baud 9600
    }
    set shell_id [board_info $dest fileid]

    set lines 0
    set chars 0
    set fd [open $file r]
    while { [gets $fd cur_line] >= 0 } {
        set errmess ""
        catch "send -i $shell_id \"$cur_line\r\"" errmess
        if {[string match "write\(spawn_id=\[0-9\]+\):" $errmess]} {
            perror "sent \"$cur_line\" got expect error \"$errmess\""
            catch "close $fd"
            return -1
        }
        set chars [expr {$chars + ([string length $cur_line] * 10)}]
        if { $chars > $baud } {
            sleep 1
            set chars 0
        }
        verbose "." 3
        verbose "Sent $cur_line" 4
        incr lines
    }
    verbose "$lines lines transmitted" 2
    close $fd
    return 0
}

proc remote_send { dest string } {
    return [call_remote "" send $dest $string]
}

proc remote_raw_send { dest string } {
    return [call_remote raw send $dest $string]
}

proc standard_send { dest string } {
    if {![board_info $dest exists fileid]} {
        perror "no fileid for $dest"
        return "no fileid for $dest"
    } else {
        set shell_id [board_info $dest fileid]
        verbose "shell_id in standard_send is $shell_id" 3
        verbose "send -i [board_info $dest fileid] -- $string" 3
        if {[catch "send -i [board_info $dest fileid] -- \$string" errorInfo]} {
            return $errorInfo
        } else {
            return ""
        }
    }
}

proc file_on_host { op file args } {
    return [eval remote_file host \"$op\" \"$file\" $args]
}

proc file_on_build { op file args } {
    return [eval remote_file build \"$op\" \"$file\" $args]
}

proc remote_file { dest args } {
    return [eval call_remote \"\" file \"$dest\" $args]
}

proc remote_raw_file { dest args } {
    return [eval call_remote raw file \"$dest\" $args]
}

# Perform the specified file op on a remote Unix board.
#
proc standard_file { dest op args } {
    set file [lindex $args 0]
    verbose "dest in proc standard_file is $dest" 3
    if { ![isremote $dest] } {
        switch -- $op {
            cmp {
                set otherfile [lindex $args 1]
                if { [file exists $file] && [file exists $otherfile]
                     && [file size $file] == [file size $otherfile] } {
                    set r [remote_exec build cmp "$file $otherfile"]
                    if { [lindex $r 0] == 0 } {
                        return 0
                    }
                }
                return 1
            }
            tail {
                return [file tail $file]
            }
            dirname {
                if { [file pathtype $file] eq "relative" } {
                    set file [remote_file $dest absolute $file]
                }
                set result [file dirname $file]
                if { $result eq "" } {
                    return "/"
                }
                return $result
            }
            join {
                return [file join [lindex $args 0] [lindex $args 1]]
            }
            absolute {
                return [unix_clean_filename $dest $file]
            }
            exists {
                return [file exists $file]
            }
            delete {
                foreach x $args {
                    if { [file exists $x] && [file isfile $x] } {
                        file delete -force -- $x
                    }
                }
                return {}
            }
        }
    } else {
        switch -- $op {
            exists {
                set status [remote_exec $dest "test -f $file"]
                return [expr {[lindex $status 0] == 0}]
            }
            delete {
                set file ""
                # Allow multiple files to be deleted at once.
                foreach x $args {
                    append file " $x"
                }
                verbose "remote_file deleting $file"
                set status [remote_exec $dest "rm -f $file"]
                return [lindex $status 0]
            }
        }
    }
}

# Return an absolute version of the filename in $file, with . and ..
# removed.
#
proc unix_clean_filename { dest file } {
    if { [file pathtype $file] eq "relative" } {
        set file [remote_file $dest join [pwd] $file]
    }
    set result ""
    foreach x [split $file "/"] {
        if { $x eq "." || $x eq "" } {
            continue
        }
        if { $x eq ".." } {
            set rlen [expr {[llength $result] - 2}]
            if { $rlen >= 0 } {
                set result [lrange $result 0 $rlen]
            } else {
                set result ""
            }
            continue
        }
        lappend result $x
    }
    return "/[join $result /]"
}

#
# Start COMMANDLINE running on DEST. By default it is not possible to
# redirect I/O. If the optional keyword "readonly" is specified, input
# to the command may be redirected. If the optional keyword
# "writeonly" is specified, output from the command may be redirected.
#
# If the command is successfully started, a positive "spawn id" is returned.
# If the spawn fails, a negative value will be returned.
#
# Once the command is spawned, you can interact with it via the remote_expect
# and remote_wait functions.
#
proc remote_spawn { dest commandline args } {
    global board_info

    if {![isremote $dest]} {
        if {[info exists board_info($dest,fileid)]} {
            unset board_info($dest,fileid)
        }
        verbose "remote_spawn is local" 3
        if {[board_info $dest exists name]} {
            set dest [board_info $dest name]
        }

        verbose "spawning command $commandline"

        if { [llength $args] > 0 } {
            if { [lindex $args 0] eq "readonly" } {
                set result [catch { open "| $commandline |& cat" "r" } id]
                if { $result != 0 } {
                    return -1
                }
            } else {
                set result [catch {open "| $commandline" "w"} id]
                if { $result != 0 } {
                    return -1
                }
            }
            set result [catch "spawn -leaveopen $id" result2]
            if { $result == 0 && $result2 == 0} {
                verbose "setting board_info($dest,fileid) to $spawn_id" 3
                set board_info($dest,fileid) $spawn_id
                set board_info($dest,fileid_origid) $id
                return $spawn_id
            } else {
                # This shouldn't happen.
                global errorInfo
                if {[info exists errorInfo]} {
                    set foo $errorInfo
                } else {
                    set foo ""
                }
                verbose "spawn -open $id failed, $result $result2, $foo"
                catch "close $id"
                return -1
            }
        } else {
            set result [catch "spawn $commandline" pid]
            if { $result == 0 } {
                verbose "setting board_info($dest,fileid) to $spawn_id" 3
                set board_info($dest,fileid) $spawn_id
                return $spawn_id
            } else {
                verbose -log "spawn of $commandline failed"
                return -1
            }
        }
    }

    # Seems to me there should be a cleaner way to do this.
    if { $args eq "" } {
        return [call_remote "" spawn $dest $commandline]
    } else {
        return [call_remote "" spawn $dest $commandline $args]
    }
}

proc remote_raw_spawn { dest commandline } {
    return [call_remote raw spawn $dest $commandline]
}

# The default spawn procedure. Uses rsh to connect to $dest.
#
proc standard_spawn { dest commandline } {
    global board_info

    if {![board_info $dest exists rsh_prog]} {
        if { [which remsh] != 0 } {
            set RSH remsh
        } else {
            set RSH rsh
        }
    } else {
        set RSH [board_info $dest rsh_prog]
    }

    if {[board_info $dest exists hostname]} {
        set remote [board_info $dest hostname]
    } else {
        set remote $dest
    }

    if {![board_info $dest exists username]} {
        spawn $RSH $remote $commandline
    } else {
        spawn $RSH -l [board_info $dest username] $remote $commandline
    }

    set board_info($dest,fileid) $spawn_id
    return $spawn_id
}

# Run PROG on DEST, with optional arguments, input and output files.
# It returns a list of two items. The first is ether "pass" if the
# program loaded, ran and exited with a zero exit status, or "fail"
# otherwise.  The second argument is any output produced by the
# program while it was running.
#
proc remote_load { dest prog args } {
    global tool

    set dname [board_info $dest name]
    set cache "[getenv REMOTELOAD_CACHE]/$tool/$dname/[file tail $prog]"
    set empty [isremote $dest]
    if { [board_info $dest exists is_simulator] || [getenv REMOTELOAD_CACHE] eq "" } {
        set empty 0
    } else {
        for { set x 0 } {$x < [llength $args] } {incr x} {
            if { [lindex $args $x] ne "" } {
                set empty 0
                break
            }
        }
    }
    if {$empty} {
        global sum_program

        if {[info exists sum_program]} {
            if {![target_info exists objcopy]} {
                set_currtarget_info objcopy [find_binutils_prog objcopy]
            }
            if {[isremote host]} {
                set dprog [remote_download host $prog "a.out"]
            } else {
                set dprog $prog
            }
            set status [remote_exec host "[target_info objcopy]" "-O srec $dprog $dprog.sum"]
            if {[isremote host]} {
                remote_file upload $dprog.sum $prog.sum
            }
            if { [lindex $status 0] == 0 } {
                set sumout [remote_exec build $sum_program $prog.sum]
                set sum [lindex $sumout 1]
                regsub "\[\r\n \t\]+$" $sum "" sum
            } else {
                set sumout [remote_exec build $sum_program $prog]
                set sum [lindex $sumout 1]
                regsub "\[\r\n \t\]+$" $sum "" sum
            }
            remote_file build delete $prog.sum
        }
        if {[file exists $cache]} {
            set same 0
            if {[info exists sum_program]} {
                set id [open $cache "r"]
                set oldsum [read $id]
                close $id
                if { $oldsum == $sum } {
                    set same 1
                }
            } else {
                if { [remote_file build cmp $prog $cache] == 0 } {
                    set same 1
                }
            }
            if { $same } {
                set fd [open $cache.res "r"]
                gets $fd l1
                set result [list $l1 [read $fd]]
                close $fd
            }
        }
    }
    if {![info exists result]} {
        set result [eval call_remote \"\" load \"$dname\" \"$prog\" $args]
        # Not quite happy about the "pass" condition, but it makes sense if
        # you think about it for a while-- *why* did the test not pass?
        if { $empty && [lindex $result 0] eq "pass" } {
            if { [getenv LOAD_REMOTECACHE] ne "" } {
                set dir "[getenv REMOTELOAD_CACHE]/$tool/$dname"
                if {![file exists $dir]} {
                    file mkdir $dir
                }
                if {[file exists $dir]} {
                    if {[info exists sum_program]} {
                        set id [open $cache "w"]
                        puts -nonewline $id $sum
                        close $id
                    } else {
                        remote_exec build cp "$prog $cache"
                    }
                    set id [open $cache.res "w"]
                    puts $id [lindex $result 0]
                    puts -nonewline $id [lindex $result 1]
                    close $id
                }
            }
        }
    }
    return $result
}

proc remote_raw_load { dest prog args } {
    return [eval call_remote raw load \"$dest\" \"$prog\" $args ]
}

# The default load procedure if no other exists for $dest. It uses
# remote_download and remote_exec to load and execute the program.
#
proc standard_load { dest prog args } {
    global board_info

    if { [llength $args] > 0 } {
        set pargs [lindex $args 0]
    } else {
        set pargs ""
    }

    if { [llength $args] > 1 } {
        set inp "[lindex $args 1]"
    } else {
        set inp ""
    }

    if {![file exists $prog]} then {
        # We call both here because this should never happen.
        perror "$prog does not exist in standard_load."
        verbose -log "$prog does not exist." 3
        return "untested"
    }

    if {[isremote $dest]} {
        if {![board_info $dest exists remotedir]} {
            set board_info($dest,remotedir) "/tmp/runtest.[pid]"
        }
        set remotefile [file tail $prog]
        set remotefile [remote_download $dest $prog $remotefile]
        if { $remotefile eq "" } {
            verbose -log "Download of $prog to [board_info $dest name] failed." 3
            return "unresolved"
        }
        if {[board_info $dest exists remote_link]} {
            if {[[board_info $dest remote_link] $remotefile]} {
                verbose -log "Couldn't do remote link"
                remote_file target delete $remotefile
                return "unresolved"
            }
        }
        set status [remote_exec $dest $remotefile $pargs $inp]
        remote_file $dest delete $remotefile
    } else {
        set status [remote_exec $dest $prog $pargs $inp]
    }
    if { [lindex $status 0] < 0 } {
        verbose -log "Couldn't execute $prog, [lindex $status 1]" 3
        return "unresolved"
    }
    set output [lindex $status 1]
    set status [lindex $status 0]

    verbose -log "Executed $prog, status $status" 2
    if { $output ne "" } {
        verbose -log -- $output 2
    }
    if { $status == 0 } {
        return [list "pass" $output]
    } else {
        return [list "fail" $output]
    }
}

# Loads PROG into DEST.
#
proc remote_ld { dest prog } {
    return [eval call_remote \"\" ld \"$dest\" \"$prog\"]
}

proc remote_raw_ld { dest prog } {
    return [eval call_remote raw ld \"$dest\" \"$prog\"]
}

# Wait up to TIMEOUT seconds for the last spawned command on DEST to
# complete. A list of two values is returned; the first is the exit
# status (-1 if the program timed out), and the second is any output
# produced by the command.
#
proc remote_wait { dest timeout } {
    return [eval call_remote \"\" wait \"$dest\" $timeout]
}

proc remote_raw_wait { dest timeout } {
    return [eval call_remote raw wait \"$dest\" $timeout]
}

# The standard wait procedure, used for commands spawned on the local
# machine.
#
proc standard_wait { dest timeout } {
    set output ""
    set status -1

    if {[info exists exp_close_result]} {
        unset exp_close_result
    }
    remote_expect $dest $timeout {
        -re ".+" {
            append output $expect_out(buffer)
            exp_continue -continue_timer
        }
        timeout {
            warning "program timed out."
        }
        eof {
            # There may be trailing characters in the buffer.
            # Append them, too.
            append output $expect_out(buffer)
            if {[board_info $dest exists fileid_origid]} {
                global board_info

                set id [board_info $dest fileid]
                set oid [board_info $dest fileid_origid]
                verbose "$id $oid"
                unset board_info($dest,fileid)
                unset board_info($dest,fileid_origid)
                catch "close -i $id"
                # I don't believe this. You HAVE to do a wait, even tho
                # it won't work! stupid ()*$%*)(% expect...
                catch "wait -i $id"
                set r2 [catch "close $oid" res]
                if { $r2 != 0 } {
                    verbose "close result is $res"
                    set status 1
                } else {
                    set status 0
                }
            } else {
                set s [wait -i [board_info $dest fileid]]
                if { [lindex $s 0] != 0 && [lindex $s 2] == 0 } {
                    set status [lindex $s 3]
                    if { [llength $s] > 4 } {
                        if { [lindex $s 4] eq "CHILDKILLED" } {
                            set status 1
                        }
                    }
                }
            }
        }
    }

    remote_close $dest
    return [list $status $output]
}

# This checks the value contained in the variable named "variable" in
# the calling procedure for output from the status wrapper and returns
# a non-negative value if it exists; otherwise, it returns -1. The
# output from the wrapper is removed from the variable.
#
proc check_for_board_status  { variable } {
    upvar $variable output

    # If all programs of this board have a wrapper that always outputs a
    # status message, then the absence of it means that the program
    # crashed, regardless of status found elsewhere (e.g. simulator exit
    # code).
    if { [target_info needs_status_wrapper] ne "" } then {
        set nomatch_return 2
    } else {
        set nomatch_return -1
    }

    if {[regexp "(^|\[\r\n\])\\*\\*\\* EXIT code" $output]} {
        regsub "^.*\\*\\*\\* EXIT code " $output "" result
        regsub "\[\r\n\].*$" $result "" result
        regsub -all "(^|\[\r\n\]|\r\n)\\*\\*\\* EXIT code \[^\r\n\]*(\[\r\n\]\[\r\n\]?|$)" $output "" output
        regsub "^\[^0-9\]*" $result "" result
        regsub "\[^0-9\]*$" $result "" result
        verbose "got board status $result" 3
        verbose "output is $output" 3
        if { $result eq "" } {
            return $nomatch_return
        } else {
            return [expr {$result}]
        }
    } else {
        return $nomatch_return
    }
}

# remote_expect works basically the same as standard expect, but it
# also takes care of getting the file descriptor from the specified
# host and also calling the timeout/eof/default section if there is an
# error on the expect call.
#
proc remote_expect { board timeout args } {
    global errorInfo errorCode
    global remote_suppress_flag

    set spawn_id [board_info $board fileid]

    if { [llength $args] == 1 } {
        set args "[lindex $args 0]"
    }

    set res {}
    set got_re 0
    set need_append 1

    set orig $args

    set error_sect ""
    set save_next 0

    if { $spawn_id eq "" } {
        # This should be an invalid spawn id.
        set spawn_id 1000
    }

    for { set i 0 } { $i < [llength $args] } { incr i }  {
        if { $need_append } {
            append res "\n-i $spawn_id "
            set need_append 0
        }

        set x "[lrange $args $i $i]"
        regsub "^\n*\[ \t\]*" $x "" x

        if { $x eq "-i" || $x eq "-timeout" || $x eq "-ex" } {
            append res "$x "
            set next [expr {$i + 1}]
            append res "[lrange $args $next $next]"
            incr i
            continue
        }
        if { $x eq "-n" || $x eq "-notransfer" || $x eq "-nocase" || $x eq "-indices" } {
            append res "$x "
            continue
        }
        if { $x eq "-re" } {
            append res "$x "
            set next [expr {$i + 1}]
            set y [lrange $args $next $next]
            append res "$y "
            set got_re 1
            incr i
            continue
        }
        if { $got_re } {
            set need_append 0
            append res "$x "
            set got_re 0
            if { $save_next } {
                set save_next 0
                set error_sect [lindex $args $i]
            }
        } else {
            if { $x eq "eof" } {
                set save_next 1
            } elseif { $x eq "default" || $x eq "timeout" } {
                if { $error_sect eq "" } {
                    set save_next 1
                }
            }
            append res "$x "
            set got_re 1
        }
    }

    if {[info exists remote_suppress_flag]} {
        if { $remote_suppress_flag } {
            set code 1
        }
    }
    if {![info exists code]} {
        set res "\n-timeout $timeout $res"
        set body "expect \{\n-i $spawn_id -timeout $timeout $orig\}"
        set code [catch {uplevel $body} string]
    }

    if {$code == 1} {
        if {[info exists string]} {
            perror "$errorInfo $errorCode $string"
        }

        if { $error_sect ne "" } {
            set code [catch {uplevel $error_sect} string]
        } else {
            warning "remote_expect statement without a default case"
            return
        }
    }

    if {$code == 1} {
        return -code error -errorinfo $errorInfo -errorcode $errorCode $string
    } else {
        return -code $code $string
    }
}

# Push the current connection to HOST onto a stack.
#
proc remote_push_conn { host } {
    global board_info

    set name [board_info $host name]

    if { $name eq "" } {
        return "fail"
    }

    if {![board_info $host exists fileid]} {
        return "fail"
    }

    set fileid [board_info $host fileid]
    set conninfo [board_info $host conninfo]
    if {![info exists board_info($name,fileid_stack)]} {
        set board_info($name,fileid_stack) {}
    }
    set board_info($name,fileid_stack) [list $fileid $conninfo $board_info($name,fileid_stack)]
    unset board_info($name,fileid)
    if {[info exists board_info($name,conninfo)]} {
        unset board_info($name,conninfo)
    }
    return "pass"
}

# Pop a previously-pushed connection from a stack. You should have closed the
# current connection before doing this.
#
proc remote_pop_conn { host } {
    global board_info

    set name [board_info $host name]

    if { $name eq "" } {
        return "fail"
    }
    if {![info exists board_info($name,fileid_stack)]} {
        return "fail"
    }
    set stack $board_info($name,fileid_stack)
    if { [llength $stack] < 3 } {
        return "fail"
    }
    set board_info($name,fileid) [lindex $stack 0]
    set board_info($name,conninfo) [lindex $stack 1]
    set board_info($name,fileid_stack) [lindex $stack 2]
    return "pass"
}

# Swap the current connection with the topmost one on the stack.
#
proc remote_swap_conn { host } {
    global board_info
    set name [board_info $host name]

    if {![info exists board_info($name,fileid)]} {
        return "fail"
    }

    set fileid $board_info($name,fileid)
    if {[info exists board_info($name,conninfo)]} {
        set conninfo $board_info($name,conninfo)
    } else {
        set conninfo {}
    }
    if { [remote_pop_conn $host] ne "pass" } {
        set board_info($name,fileid) $fileid
        set board_info($name,conninfo) $conninfo
        return "fail"
    }
    set newfileid $board_info($name,fileid)
    set newconninfo $board_info($name,conninfo)
    set board_info($name,fileid) $fileid
    set board_info($name,conninfo) $conninfo
    remote_push_conn $host
    set board_info($name,fileid) $newfileid
    set board_info($name,conninfo) $newconninfo
    return "pass"
}

set sum_program "testcsum"