| # Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 |
| # 2002, 2003, 2005, 2006, 2007, 2008, 2009, 2010 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 == "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 != "" } { |
| 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" |
| # Prepend "-" to generate the "process group ID" needed by |
| # kill. |
| set pgid "-$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. |
| exec sh -c "exec > /dev/null 2>&1 && (kill -2 $pgid || kill -2 $pid)" |
| |
| # 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 && (kill -15 $pgid || kill -15 $pid)" |
| append sh_cmd " && sleep $secs && (kill -9 $pgid || kill -9 $pid)" |
| 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} { |
| # 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. |
| exec sh -c "exec > /dev/null 2>&1 && kill -9 $exec_pid" |
| } |
| |
| 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" == "" && "$outp" == "" } { |
| 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 != "" } { |
| 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 } { |
| 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 } { |
| 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 status $status" |
| if { $outp == "" || $outp == "|& 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 { ![is_remote $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] != "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]} { |
| 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"] |
| } |
| |
| |
| # 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] != "" } { |
| ${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 { ![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 |
| } |
| } |
| } |
| 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" != "" } { |
| set result [rsh_download $dest $file $destfile] |
| if { $result == $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 != "" } { |
| 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 { ![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 } { |
| 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" != "" } { |
| 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 != "" } { |
| 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 == "reboot" } { |
| regsub {/.*} "$dest" "" dest |
| verbose "Changed dest to $dest" |
| } |
| |
| if { $dest != "host" && $dest != "build" && $dest != "target" } { |
| if { ![board_info $dest exists name] } { |
| global board |
| |
| if {[info exists board]} { |
| error "board exists" |
| } |
| load_board_description $dest |
| if { $proc == "reboot" } { |
| regsub {/.*} "$dest" "" dest |
| verbose "Changed dest to $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 procs "${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 procs "${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 procs "${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" |
| } |
| |
| # 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 { ![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] } { |
| 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] == "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 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 [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 } { |
| 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 {[is_remote $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 == "" } { |
| 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) |
| 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] == "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] != "" } 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 == "" } { |
| 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 == "" } { |
| # 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 {[info exists string]} { |
| perror "$errorInfo $errorCode $string" |
| } |
| |
| 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 |
| } 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 == "" } { |
| 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" |