diff options
Diffstat (limited to 'dejagnu/lib/remote.exp')
| -rw-r--r-- | dejagnu/lib/remote.exp | 1265 |
1 files changed, 1265 insertions, 0 deletions
diff --git a/dejagnu/lib/remote.exp b/dejagnu/lib/remote.exp new file mode 100644 index 00000000000..0bc8ed09b73 --- /dev/null +++ b/dejagnu/lib/remote.exp @@ -0,0 +1,1265 @@ +# Copyright (C) 92, 93, 94, 95, 96, 97, 98, 1999 Free Software Foundation, Inc. + +# This program 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 2 of the License, or +# (at your option) any later version. +# +# This program 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 this program; if not, write to the Free Software +# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +# Please email any bugs, comments, and/or additions to this file to: +# bug-dejagnu@prep.ai.mit.edu + +# This file was written by Rob Savoye. (rob@cygnus.com) + +# load various protocol support modules + +load_lib "mondfe.exp" +load_lib "xsh.exp" +load_lib "telnet.exp" +load_lib "rlogin.exp" +load_lib "kermit.exp" +load_lib "tip.exp" +load_lib "rsh.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 == "target" } { + reboot_target; + } + + return [call_remote "" open $type]; +} + +proc remote_raw_open { args } { + return [eval call_remote raw open $args]; +} + +# Run the specified COMMANDLINE on the local machine, redirecting input +# to 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 two-member list 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. *sigh* + # + if { "$inp" == "" && "$outp" == "" } { + set id -1; + set result [catch "eval spawn \{${commandline}\}" pid]; + if { $result == 0 } { + set result2 0; + } else { + set pid 0; + set result2 5; + } + } else { + # Can you say "uuuuuugly"? I knew you could! + # All in the name of non-infinite hangs. + if { $inp != "" } { + 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 == "" } { + set outp "|& cat" + } else { + set outpf "$outp"; + set outp "> $outp" + if { $inp != "" } { + 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 } { + global errorInfo + return [list -1 "open of $commandline $inp $outp failed: $errorInfo"]; + } + set pid [pid $id]; + set result [catch "spawn -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. + global errorInfo; + 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); + if { [string length $output] < 512000 } { + exp_continue -continue_timer; + } + } + timeout { + warning "program timed out."; + } + eof { + set got_eof 1; + } + } + + # Uuuuuuugh. Now I'm getting really sick. + # If we didn't get an EOF, we have to kill the poor defenseless program. + # However, TCL has no kill primitive, so we have to execute an external + # command in order to execute the execution. (English. Gotta love it.) + if { ! $got_eof } { + verbose "killing $pid $pgid"; + exec sh -c "exec > /dev/null 2>&1 && (kill -2 $pgid || kill -2 $pid) && sleep 5 && (kill -15 $pgid || kill $pid) && sleep 5 && (kill -9 $pgid || kill -9 $pid)" &; + } + # This will hang if the kill doesn't work. Nothin' to do, and it's not ok. + catch "close -i $spawn_id"; + set r2 [catch "wait -i $spawn_id" wres]; + if { $id > 0 } { + 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] == "CHILDKILLED" } { + set r2 1; + } + } + if { $r2 != 0 } { + set res "$wres"; + } else { + set res ""; + } + } else { + set res "wait failed"; + } + } + if { $r2 != 0 || $res != "" || ! $got_eof } { + verbose "close result is $res"; + set status 1; + } else { + set status 0; + } + verbose "output is $output"; + if { $outp == "" } { + 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 "" + } + + # 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 { ![is_remote $hostname] } { + return [local_exec "$program $pargs" $inp $outp $timeout]; + } else { + return [call_remote "" exec $hostname $program $pargs $inp $outp]; + } +} + +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] != "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; + } + } + } + if { $pid > 0 } { + verbose "doing kill, pid is $pid"; + # This is very, very nasty. Then again, if after did something + # reasonable... + set pgid "-[join $pid { -}]"; + exec sh -c "exec > /dev/null 2>&1 && (kill -2 $pgid || kill -2 $pid) && sleep 5 && (kill $pgid || kill $pid) && sleep 5 && (kill -9 $pgid || kill -9 $pid)" &; + } + verbose "pid is $pid"; + catch "close -i $shell_id"; + if [info exists oid] { + catch "close $oid"; + } + catch "wait -i $shell_id"; + 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"]; +} + + + +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 proc ${host}_init] != "" } { + ${host}_init $host; + } + return $status; +} + +proc standard_reboot { host } { + return ""; +} +# +# 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 { ![is_remote $dest] } { + if { $destfile == "" || $destfile == $file } { + return $file; + } else { + 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 != "" } { + perror "remote_download to $dest of $file to $destfile: $output" + return ""; + } else { + return $destfile; + } + } + } + + return [call_remote "" download $dest $file $destfile]; +} + +# +# The default download procedure. Uses rcp to download to $dest. +# + +proc standard_download {dest file destfile} { + return [rsh_download $dest $file $destfile]; +} + +proc remote_upload {dest srcfile args} { + if { [llength $args] > 0 } { + set destfile [lindex $args 0]; + } else { + set destfile [file tail $srcfile]; + } + + if { ![is_remote $dest] } { + if { $destfile == "" || $srcfile == $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 } { + return [rsh_upload $dest $srcfile $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 { $dest != "host" && $dest != "build" && $dest != "target" } { + if { ![board_info $dest exists name] } { + global board; + + if [info exists board] { + blooie + } + load_board_description $dest; + } + } + + set high_prot "" + if { $type != "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 == "close" || $proc == "open" } { + foreach try "$high_prot [board_info $dest connect] telnet standard" { + if { $try != "" } { + if { [info proc "${try}_${proc}"] != "" } { + verbose "call_remote calling ${try}_${proc}" 3 + set result [eval ${try}_${proc} \"$dest\" $args]; + break; + } + } + } + set ft "[board_info $dest file_transfer]" + if { [info proc "${ft}_${proc}"] != "" } { + 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 != "" } { + if { [info proc "${try}_${proc}"] != "" } { + verbose "call_remote calling ${try}_${proc}" 3 + return [eval ${try}_${proc} \"$dest\" $args]; + } + } + } + if { $proc == "close" } { + return "" + } + error "No procedure for '$proc' in call_remote" + return -1; +} + +# +# 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 standard_file is $dest"; + if { ![is_remote $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] == "relative" } { + set file [remote_file $dest absolute $file]; + } + set result [file dirname $file]; + if { $result == "" } { + 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] } { + exec rm -f $x; + } + } + return; + } + } + } + switch $op { + exists { + # mmmm, quotes. + set status [remote_exec $dest "sh -c 'exit `\[ -f $file \]`'"]; + return [lindex $status 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] == "relative" } { + set file [remote_file $dest join [pwd] $file]; + } + set result ""; + foreach x [split $file "/"] { + if { $x == "." || $x == "" } { + continue; + } + if { $x == ".." } { + 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 ![is_remote $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] == "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" == "" } { + 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 hostname] { + set remote [board_info $dest hostname]; + } else { + set remote $dest; + } + spawn rsh $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 [is_remote $dest]; + if { [board_info $dest exists is_simulator] || [getenv REMOTELOAD_CACHE] == "" } { + set empty 0; + } else { + for { set x 0; } {$x < [llength $args] } {incr x} { + if { [lindex $args $x] != "" } { + 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 [is_remote 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 [is_remote 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] == "pass" } { + if { [getenv LOAD_REMOTECACHE] != "" } { + 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 } { + 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 [is_remote $dest] { + set remotefile "/tmp/[file tail $prog].[pid]" + set remotefile [remote_download $dest $prog $remotefile]; + if { $remotefile == "" } { + 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 ![string match "" $output] { + 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); + if { [string length $output] > 512000 } { + remote_close $dest; + set status 1; + } else { + exp_continue -continue_timer; + } + } + timeout { + warning "program timed out."; + } + eof { + 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] == "CHILDKILLED" } { + set status 1; + } + } + } + } + } + } + + remote_close $dest; + return [list $status $output]; +} + +# This checks the value cotained 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 [regexp "(^|\[\r\n\])\\*\\*\\* EXIT code" $output] { + regsub "^.*\\*\\*\\* EXIT code " $output "" result; + regsub "\[\r\n\].*$" $result "" result; + regsub -all "(^|\[\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 == "" } { + return -1; + } else { + return [expr $result]; + } + } else { + return -1; + } +} + +# +# 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 == "" } { + # 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*\[ \]*" "$x" "" x; + + if { $x == "-i" || $x == "-timeout" || $x == "-ex" } { + append res "$x "; + set next [expr ${i}+1]; + append res "[lrange $args $next $next]"; + incr i; + continue; + } + if { $x == "-n" || $x == "-notransfer" || $x == "-nocase" || $x == "-indices" } { + append res "${x} "; + continue; + } + if { $x == "-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} == "eof" } { + set save_next 1; + } elseif { ${x} == "default" || ${x} == "timeout" } { + if { $error_sect == "" } { + 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 { $error_sect != "" } { + 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 + } elseif {$code == 2} { + return -code return $string + } elseif {$code == 3} { + return + } elseif {$code > 4} { + 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 == "" } { + 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 == "" } { + 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] != "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"; |